- 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 Feb 19, 2025@00:13:51 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 ;
