Return to DIFG1.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DIFG1.m, revision 1.1.1.1

1.1       snw         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:        ;