- 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_"""")
- 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
- ;
- 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 ;
