DIFG1 ;SFISC/DG(OHPRD)-SINGLE VALUED FIELDS ;02/03/93 3:17 PM
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
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_"""")
Q
;
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
Q
;
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")
Q
;
BUILD ;
S ^UTILITY("DIFG",$J,DIFGINCR,DIC,"WP",DIFG("COUNT"))=$E(DIFGDIX,2,$L(DIFGDIX)-1)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFG1 2526 printed Dec 13, 2024@02:47:36 Page 2
DIFG1 ;SFISC/DG(OHPRD)-SINGLE VALUED FIELDS ;02/03/93 3:17 PM
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
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 ;
