Return to DIFG1.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Restructure repository

    1: DIFG1	;SFISC/DG(OHPRD)-SINGLE VALUED FIELDS ; [ 02/03/93  3:17 PM ]
    2: 	;;21.0;VA FileMan;;Dec 28, 1994
    3: 	;Per VHA Directive 10-93-142, this routine should not be modified.
    4: START	;ASSIGNMENT STATEMENT FOR SINGLE VALUED FIELD
    5: 	I DIFGTYPE="WP FIELD" D WPFIELD G X1
    6: 	S DIFGSECP=$P(DIFGDIX,"=",2)
    7: 	I DIFGSECP="^" S DIFGVAL="@" D SETDR G X1
    8: 	I DIFGSECP?1"@"1N.N,'^UTILITY("DIFG@",$J,DIFGSECP),$D(DIFG("UNRESOLVED",DIFGSECP)) S DIFGER=21_U_DIFGY D ERROR^DIFG G X2
    9: 	I $P(^DD(DIC,DIFGNUM,0),U,2)["P",DIFGSECP'?1"@"1N.N D LOOKUP I 1
   10: 	E  I DIFGSECP'?1"@"1N.N,DIFGSECP[";" D PARSE S DIFGVAL="^S X="_DIFGSECP I 1
   11: 	E  S DIFGVAL=$S(DIFGSECP'?1"@"1N.N:DIFGSECP,^UTILITY("DIFG@",$J,DIFGSECP)[DIFGSECP:"^S X="_"""`""_^UTILITY(""DIFG@"","_$J_","""_DIFGSECP_""")",DIFGNUM'=.01:"/"_^UTILITY("DIFG@",$J,DIFGSECP),1:"`"_^UTILITY("DIFG@",$J,DIFGSECP))
   12: 	I DIFGER G X1
   13: 	D SETDR
   14: 	K DIFGSECP,DIFGPC,DIFGFLD,DIFGVAL,DIFGDOL,DIFGNOLK,DIFGPARS,DIFGDOLF
   15: X1	Q
   16: 	;
   17: PARSE	; PARSE AND CHANGE DIFGSECP IF CONTAINS ";"
   18: 	NEW I S DIFGPARS="" F I=0:0 S DIFGDOLF=$F(DIFGSECP,";") Q:'DIFGDOLF  S DIFGPARS=DIFGPARS_$S(DIFGDOLF>2:""""_$E(DIFGSECP,1,DIFGDOLF-2)_"""_",1:"")_"$C(59)_" S DIFGSECP=$E(DIFGSECP,DIFGDOLF,245)
   19: 	S DIFGSECP=$S(DIFGSECP="":$E(DIFGPARS,1,$L(DIFGPARS)-1),1:DIFGPARS_""""_DIFGSECP_"""")
   20: 	Q
   21: 	;
   22: SETDR	;
   23: 	S:'$D(^UTILITY("DIFG",$J,DIFGINCR,DIC,"DR")) ^("DR")=""
   24: 	I $L(^UTILITY("DIFG",$J,DIFGINCR,DIC,"DR"))+$L(DIFGNUM_"///"_DIFGVAL_";")<241 S ^("DR")=^("DR")_DIFGNUM_"///"_DIFGVAL_";" G X2
   25: 	I $D(^UTILITY("DIFG",$J,DIFGINCR,DIC,"DR",DIFGNDC)),$L(^(DIFGNDC))+$L(DIFGNUM_"///"_DIFGVAL_";")<241 S ^(DIFGNDC)=^(DIFGNDC)_DIFGNUM_"///"_DIFGVAL_";"
   26: 	E  S DIFGNDC=DIFGNDC+1,^(DIFGNDC)=DIFGNUM_"///"_DIFGVAL_";"
   27: X2	Q
   28: 	;
   29: LOOKUP	;FIELD LOOKUP
   30: 	S DIFG=DIFG+1
   31: 	S X=$P(DIFGDIX,"=",2)
   32: 	S DIFGLAGO=0
   33: 	I $P(^DD(DIC,DIFGNUM,0),U,2)'["'"!($D(DIFGENV("LAYGO",DIC,DIFGNUM))) S DIFGLAGO=1
   34: 	D ^DIFG3
   35: 	I DIFGER G X3
   36: 	I Y>0 S DIFGVAL="/"_+Y G X3
   37: 	S DIFGVAL="^S X="_"""`""_"_DIFGALNK
   38: X3	S DIFG=DIFG-1
   39: 	K Y,DIFGLAGO
   40: 	Q
   41: 	;
   42: WPFIELD	;PROCESS WP FIELD
   43: 	S DIFG("COUNT")=0
   44: 	S ^UTILITY("DIFG",$J,DIFGINCR,DIC,"WP",DIFG("COUNT"))=DIFGFLDN
   45: 	F DIFGL=0:0 X DIFGLINE Q:DIFGDIX="."  S DIFG("COUNT")=DIFG("COUNT")+1 D BUILD
   46: 	K DIFG("COUNT")
   47: 	Q
   48: 	;
   49: BUILD	;
   50: 	S ^UTILITY("DIFG",$J,DIFGINCR,DIC,"WP",DIFG("COUNT"))=$E(DIFGDIX,2,$L(DIFGDIX)-1)
   51: 	Q
   52: 	;