Routine: DIFG1

DIFG1 ;SFISC/DG(OHPRD)-SINGLE VALUED FIELDS ; [ 02/03/93  3:17 PM ]

 ;;22.0;VA FileMan;;Mar 30, 1999

 ;Per VHA Directive 10-93-142, this routine should not be modified.

START ;ASSIGNMENT STATEMENT FOR SINGLE VALUED FIELD

 I DIFGTYPE="WP FIELD" D WPFIELD G X1

 S DIFGSECP=$P(DIFGDIX,"=",2)

 I DIFGSECP="^" S DIFGVAL="@" D SETDR G X1

 I DIFGSECP?1"@"1N.N,'^UTILITY("DIFG@",$J,DIFGSECP),$D(DIFG("UNRESOLVED",DIFGSECP)) S DIFGER=21_U_DIFGY D ERROR^DIFG G X2

 I $P(^DD(DIC,DIFGNUM,0),U,2)["P",DIFGSECP'?1"@"1N.N D LOOKUP I 1

 E  I DIFGSECP'?1"@"1N.N,DIFGSECP[";" D PARSE S DIFGVAL="^S X="_DIFGSECP I 1

 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))

 I DIFGER G X1

 D SETDR

 K DIFGSECP,DIFGPC,DIFGFLD,DIFGVAL,DIFGDOL,DIFGNOLK,DIFGPARS,DIFGDOLF

X1 Q

PARSE ; PARSE AND CHANGE DIFGSECP IF CONTAINS ";"

 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)

 S DIFGSECP=$S(DIFGSECP="":$E(DIFGPARS,1,$L(DIFGPARS)-1),1:DIFGPARS_""""_DIFGSECP_"""")

SETDR ;

 S:'$D(^UTILITY("DIFG",$J,DIFGINCR,DIC,"DR")) ^("DR")=""

 I $L(^UTILITY("DIFG",$J,DIFGINCR,DIC,"DR"))+$L(DIFGNUM_"///"_DIFGVAL_";")<241 S ^("DR")=^("DR")_DIFGNUM_"///"_DIFGVAL_";" G X2

 I $D(^UTILITY("DIFG",$J,DIFGINCR,DIC,"DR",DIFGNDC)),$L(^(DIFGNDC))+$L(DIFGNUM_"///"_DIFGVAL_";")<241 S ^(DIFGNDC)=^(DIFGNDC)_DIFGNUM_"///"_DIFGVAL_";"

 E  S DIFGNDC=DIFGNDC+1,^(DIFGNDC)=DIFGNUM_"///"_DIFGVAL_";"

X2 Q

LOOKUP ;FIELD LOOKUP

 S DIFG=DIFG+1

 S X=$P(DIFGDIX,"=",2)

 S DIFGLAGO=0

 I $P(^DD(DIC,DIFGNUM,0),U,2)'["'"!($D(DIFGENV("LAYGO",DIC,DIFGNUM))) S DIFGLAGO=1

 D ^DIFG3

 I DIFGER G X3

 I Y>0 S DIFGVAL="/"_+Y G X3

 S DIFGVAL="^S X="_"""`""_"_DIFGALNK

X3 S DIFG=DIFG-1

 K Y,DIFGLAGO

WPFIELD ;PROCESS WP FIELD

 S DIFG("COUNT")=0

 S ^UTILITY("DIFG",$J,DIFGINCR,DIC,"WP",DIFG("COUNT"))=DIFGFLDN

 F DIFGL=0:0 X DIFGLINE Q:DIFGDIX="."  S DIFG("COUNT")=DIFG("COUNT")+1 D BUILD

 K DIFG("COUNT")

BUILD ;

 S ^UTILITY("DIFG",$J,DIFGINCR,DIC,"WP",DIFG("COUNT"))=$E(DIFGDIX,2,$L(DIFGDIX)-1)

DIFG1     ;SFISC/DG(OHPRD)-SINGLE VALUED FIELDS ; [ 02/03/93  3:17 PM ]

 +1       ;;22.0;VA FileMan;;Mar 30, 1999

 +2       ;Per VHA Directive 10-93-142, this routine should not be modified.

START     ;ASSIGNMENT STATEMENT FOR SINGLE VALUED FIELD

 +1        IF DIFGTYPE="WP FIELD"

               DO WPFIELD

               GOTO X1

 +2        SET DIFGSECP=$PIECE(DIFGDIX,"=",2)

 +3        IF DIFGSECP="^"

               SET DIFGVAL="@"

               DO SETDR

               GOTO X1

 +4        IF DIFGSECP?1"@"1N.N

               IF '^UTILITY("DIFG@",$JOB,DIFGSECP)

                   IF $DATA(DIFG("UNRESOLVED",DIFGSECP))

                       SET DIFGER=21_U_DIFGY

                       DO ERROR^DIFG

                       GOTO X2

 +5        IF $PIECE(^DD(DIC,DIFGNUM,0),U,2)["P"

               IF DIFGSECP'?1"@"1N.N

                   DO LOOKUP

                   IF 1

 +6       IF '$TEST

               IF DIFGSECP'?1"@"1N.N

                   IF DIFGSECP[";"

                       DO PARSE

                       SET DIFGVAL="^S X="_DIFGSECP

                       IF 1

 +7       IF '$TEST

               SET DIFGVAL=$SELECT(DIFGSECP'?1"@"1N.N:DIFGSECP,^UTILITY("DIFG@",$JOB,DIFGSECP)[DIFGSECP:"^S X="_"""`""_^UTILITY(""DIFG@"","_$JOB_","""_DIFGSECP_""")",DIFGNUM'=.01:"/"_^UTILITY("DIFG@",$JOB,DIFGSECP),1:"`"_^UTILITY("DIFG@",$JOB,DIFGSECP))

 +8        IF DIFGER

               GOTO X1

 +9        DO SETDR

 +10       KILL DIFGSECP,DIFGPC,DIFGFLD,DIFGVAL,DIFGDOL,DIFGNOLK,DIFGPARS,DIFGDOLF

X1         QUIT

 +1       ;

PARSE     ; PARSE AND CHANGE DIFGSECP IF CONTAINS ";"

 +1        NEW I

           SET DIFGPARS=""

           FOR I=0:0

               SET DIFGDOLF=$FIND(DIFGSECP,";")

               IF 'DIFGDOLF

                   QUIT

               SET DIFGPARS=DIFGPARS_$SELECT(DIFGDOLF>2:""""_$EXTRACT(DIFGSECP,1,DIFGDOLF-2)_"""_",1:"")_"$C(59)_"

               SET DIFGSECP=$EXTRACT(DIFGSECP,DIFGDOLF,245)

 +2        SET DIFGSECP=$SELECT(DIFGSECP="":$EXTRACT(DIFGPARS,1,$LENGTH(DIFGPARS)-1),1:DIFGPARS_""""_DIFGSECP_"""")

 +3        QUIT

 +4       ;

SETDR     ;

 +1        IF '$DATA(^UTILITY("DIFG",$JOB,DIFGINCR,DIC,"DR"))

               SET ^("DR")=""

 +2        IF $LENGTH(^UTILITY("DIFG",$JOB,DIFGINCR,DIC,"DR"))+$LENGTH(DIFGNUM_"///"_DIFGVAL_";")<241

               SET ^("DR")=^("DR")_DIFGNUM_"///"_DIFGVAL_";"

               GOTO X2

 +3        IF $DATA(^UTILITY("DIFG",$JOB,DIFGINCR,DIC,"DR",DIFGNDC))

               IF $LENGTH(^(DIFGNDC))+$LENGTH(DIFGNUM_"///"_DIFGVAL_";")<241

                   SET ^(DIFGNDC)=^(DIFGNDC)_DIFGNUM_"///"_DIFGVAL_";"

 +4       IF '$TEST

               SET DIFGNDC=DIFGNDC+1

               SET ^(DIFGNDC)=DIFGNUM_"///"_DIFGVAL_";"

X2         QUIT

 +1       ;

LOOKUP    ;FIELD LOOKUP

 +1        SET DIFG=DIFG+1

 +2        SET X=$PIECE(DIFGDIX,"=",2)

 +3        SET DIFGLAGO=0

 +4        IF $PIECE(^DD(DIC,DIFGNUM,0),U,2)'["'"!($DATA(DIFGENV("LAYGO",DIC,DIFGNUM)))

               SET DIFGLAGO=1

 +5        DO ^DIFG3

 +6        IF DIFGER

               GOTO X3

 +7        IF Y>0

               SET DIFGVAL="/"_+Y

               GOTO X3

 +8        SET DIFGVAL="^S X="_"""`""_"_DIFGALNK

X3         SET DIFG=DIFG-1

 +1        KILL Y,DIFGLAGO

 +2        QUIT

 +3       ;

WPFIELD   ;PROCESS WP FIELD

 +1        SET DIFG("COUNT")=0

 +2        SET ^UTILITY("DIFG",$JOB,DIFGINCR,DIC,"WP",DIFG("COUNT"))=DIFGFLDN

 +3        FOR DIFGL=0:0

               XECUTE DIFGLINE

               IF DIFGDIX="."

                   QUIT

               SET DIFG("COUNT")=DIFG("COUNT")+1

               DO BUILD

 +4        KILL DIFG("COUNT")

 +5        QUIT

 +6       ;

BUILD     ;

 +1        SET ^UTILITY("DIFG",$JOB,DIFGINCR,DIC,"WP",DIFG("COUNT"))=$EXTRACT(DIFGDIX,2,$LENGTH(DIFGDIX)-1)

 +2        QUIT

 +3       ;

DIFG1.m