DIFG3 ;SFISC/DG(OHPRD)-LOOKUP PROCESSING ;3/11/93 1:33 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.
;
S DIFGTYP="" X DIFGLINE
N DIC,DIFGDRAD,DIFGDRCT,DIFGFLUS
S DIFG=DIFG+1
D BEGIN G:DIFGER X5
S DIFGTYP=$S(DIFGTYPE="MV FIELD":"MV FIELD",DIFGTYPE="SV FIELD":"SV FIELD",1:"FILE")
I $D(DIFGDINM) K DIFGDINM S Y=^UTILITY("DIFG",$J,DIFGINCR,DIC,"DA") S:'$D(@(^DIC(DIC,0,"GL")_"Y)")) DIFGER=19_U_DIFGY D ERROR^DIFG:DIFGER,SET^DIFG3A:'DIFGER G X5
I '$D(DIFGNOLK) D PREDIC I 1
E I DIFGTYP="MV FIELD",$D(DIFGNOLK) D MVFIELD^DIFG3A I 1
E S DIFGDIC=DIC D ^DIFG4,SET^DIFG3A
X5 S DIFG=DIFG-1 K DIFGNOLK,DIFGCOND,DIFG("CONDSET") I DIFGTYP'="MV FIELD" K DIFGTYP
Q
BEGIN I $P(DIFGDIX,":")'="BEGIN" S DIFGER=6_U_DIFGY D ERROR^DIFG G X
S DIFGDRCT=0,DIC=$S(+$P(DIFGDIX,U,2):+$P(DIFGDIX,U,2),1:$O(^DIC("B",$P($P(DIFGDIX,U),":",2),""))),DIC("S")="F DIFGI=1:1 Q:'$D(DIFGDIC(DIFGDIC,DIFGI))!('$T) X DIFGDIC(DIFGDIC,DIFGI)"
I '$D(^DD(DIC)) S DIFGER=20_U_DIFGY D ERROR^DIFG G X
I DIFGTYP="" S %=DIFGLAGO NEW DIFGLAGO S DIFGHAT=$P(^DD(DIC,.01,0),U,2) S DIFGLAGO=$S(%=0:0,DIFGHAT'["'":1,$D(DIFGENV("LAYGO",DIC,.01)):1,1:0) K %
K DIFGHAT
I DIFGTYPE="SV FIELD"!($D(DIFG("CHKCOND"))) S:$D(^DD(DIC,0,"FD")) DIFGCOND(DIFG,DIC)="" K DIFG("CHKCOND")
D LINK^DIFG5
F DIFGL=0:0 X DIFGLINE S DIFGFIRP=$P(DIFGDIX,":") Q:DIFGFIRP="END"!DIFGER D LINES
Q
LINES I DIFGFIRP="BEGIN" D RCR S:$S($D(Y):Y<0,1:1) DIFGNOLK="" G:DIFGER X S:'$D(DIFGNOLK) X="`"_+Y S:$D(DIFGNOLK)&(DIFGTYP'="MV FIELD")&(DIFGTYP'="FILE") X=DIFGALNK D:$D(DIFGDIC(DIC))&'$D(DIFGNOLK) ARRAY^DIFG5 K Y G X
I DIFGFIRP="IDENTIFIER"!(DIFGFIRP="SPECIFIER") D ^DIFG0 G:DIFGER X S:'$D(DIFGPTER(DIFGCT)) DIFGSVVL(DIFGCT)=DIFGVAL(DIFGCT) I $D(DIFGPTER(DIFGCT)) D IDENSPEC^DIFG5 G X
I DIFGFIRP="KEY" S DIFGKEY="" D KEY^DIFG5
I DIFGFIRP="$DAT" S DIFGER=3_U_DIFGY D ERROR^DIFG
X Q
RCR N DIC,DIFGDRAD,DIFGDRCT,DIFGNOLK,DIFGFLUS
S DIFG=DIFG+1,DIFG("CHKCOND")=""
D BEGIN G:DIFGER X
I '$D(DIFGNOLK) D PREDIC I 1
E S DIFGDIC=DIC D ^DIFG4,SET^DIFG3A
I $D(DIFGDIC)#2 K DIFGCOND(DIFG,DIFGDIC)
S DIFG=DIFG-1
Q
PREDIC I $D(DIFGKEY) D:DIFGTYPE="MV FIELD" MVFIELD^DIFG3A G X2
S DIFGDIC=DIC
I DIFGTYP="MV FIELD" D MVFIELD^DIFG3A G X2
I DIFGTYP="FILE",$P(DIFGMO(DIFGMULT),U)="A" S DIFGSKIP(DIFGMULT)="" D ^DIFG4,SET^DIFG3A G X2
I '$D(DIFGFLUS) D CALLDIC I 1
E D SET^DIFG3A
X2 K DIFGKEY,DIFGSAVE(DIFG,"@NUM")
K:DIFGTYP'="MV FIELD" DIFG("ACGRV")
Q
CALLDIC K D
I $D(DIFGXRF(DIFGMULT)),(DIFGTYP="MV FIELD"!(DIFGTYP="FILE")) S DIFGX=X,X=^UTILITY("DIFG@",$J,$P(DIFGXRF(DIFGMULT),"=",2)) G:X["^UTILITY(""DIFG@""" NOLK S D=$P(DIFGXRF(DIFGMULT),"="),DIC(0)="FI" D G:$D(DIFGNK) NOLK
. I $E(DIFGX)="`" S DIFGGRAV="",DIFGX=$E(DIFGX,2,245)
. E NEW X S X=DIFGX X $P(^DD(DIFGDIC,.01,0),U,5,99) S:$D(X) DIFGX=X I '$D(X) S DIFGNK="" Q
. F DIFGI=1:1 Q:'$D(DIFGDIC(DIFGDIC,DIFGI))
. S DIFGDIC(DIFGDIC,DIFGI)="I $P(^(0),U)=DIFGX"
E I $E(X)'="`"!($P(^DD(DIFGDIC,.01,0),U,5,99)["DINUM") S DIC(0)="MFI"
E S X=$E(X,2,245),DIC(0)="FI",D="B",DIFG("ACGRV")=""
I $D(D),'$D(^DD(DIFGDIC,0,"IX",D)) D DOLO^DIFG5 I '$D(DIFG("FOUND")) S DIFGER=18_U_DIFGY D ERROR^DIFG G X6
K DIFGNK F DIFGI=1:1 Q:'$D(DIFGDIC(DIFGDIC,DIFGI))!$D(DIFGNK) I $P(DIFGDIC(DIFGDIC,DIFGI),"=",2)["DIFGVAL",@$P(DIFGDIC(DIFGDIC,DIFGI),"=",2)["DIFG(" S DIFGNK=""
I '$D(DIFG("FOUND")),'$D(DIFGNK) D @$S($D(D):"IX^DIC",1:"^DIC")
NOLK I X["^UTILITY(""DIFG@"""!$D(DIFGNK) S Y=-1
I $D(DIFGX) S X=$S($D(DIFGGRAV):"`",1:"")_DIFGX K DIFGX,DIFGGRAV
D CHECKY^DIFG5
D:'DIFGER SET^DIFG3A
X6 K DIFG("FOUND"),D,DR,DIFGNK
I DIFGTYP="MV FIELD"!(DIFGTYP="FILE") K DIFGXRF(DIFGMULT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFG3 3894 printed Apr 09, 2024@21:43:58 Page 2
DIFG3 ;SFISC/DG(OHPRD)-LOOKUP PROCESSING ;3/11/93 1:33 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 ;
+7 SET DIFGTYP=""
XECUTE DIFGLINE
+8 NEW DIC,DIFGDRAD,DIFGDRCT,DIFGFLUS
+9 SET DIFG=DIFG+1
+10 DO BEGIN
if DIFGER
GOTO X5
+11 SET DIFGTYP=$SELECT(DIFGTYPE="MV FIELD":"MV FIELD",DIFGTYPE="SV FIELD":"SV FIELD",1:"FILE")
+12 IF $DATA(DIFGDINM)
KILL DIFGDINM
SET Y=^UTILITY("DIFG",$JOB,DIFGINCR,DIC,"DA")
if '$DATA(@(^DIC(DIC,0,"GL")_"Y)"))
SET DIFGER=19_U_DIFGY
if DIFGER
DO ERROR^DIFG
if 'DIFGER
DO SET^DIFG3A
GOTO X5
+13 IF '$DATA(DIFGNOLK)
DO PREDIC
IF 1
+14 IF '$TEST
IF DIFGTYP="MV FIELD"
IF $DATA(DIFGNOLK)
DO MVFIELD^DIFG3A
IF 1
+15 IF '$TEST
SET DIFGDIC=DIC
DO ^DIFG4
DO SET^DIFG3A
X5 SET DIFG=DIFG-1
KILL DIFGNOLK,DIFGCOND,DIFG("CONDSET")
IF DIFGTYP'="MV FIELD"
KILL DIFGTYP
+1 QUIT
BEGIN IF $PIECE(DIFGDIX,":")'="BEGIN"
SET DIFGER=6_U_DIFGY
DO ERROR^DIFG
GOTO X
+1 SET DIFGDRCT=0
SET DIC=$SELECT(+$PIECE(DIFGDIX,U,2):+$PIECE(DIFGDIX,U,2),1:$ORDER(^DIC("B",$PIECE($PIECE(DIFGDIX,U),":",2),"")))
SET DIC("S")="F DIFGI=1:1 Q:'$D(DIFGDIC(DIFGDIC,DIFGI))!('$T) X DIFGDIC(DIFGDIC,DIFGI)"
+2 IF '$DATA(^DD(DIC))
SET DIFGER=20_U_DIFGY
DO ERROR^DIFG
GOTO X
+3 IF DIFGTYP=""
SET %=DIFGLAGO
NEW DIFGLAGO
SET DIFGHAT=$PIECE(^DD(DIC,.01,0),U,2)
SET DIFGLAGO=$SELECT(%=0:0,DIFGHAT'["'":1,$DATA(DIFGENV("LAYGO",DIC,.01)):1,1:0)
KILL %
+4 KILL DIFGHAT
+5 IF DIFGTYPE="SV FIELD"!($DATA(DIFG("CHKCOND")))
if $DATA(^DD(DIC,0,"FD"))
SET DIFGCOND(DIFG,DIC)=""
KILL DIFG("CHKCOND")
+6 DO LINK^DIFG5
+7 FOR DIFGL=0:0
XECUTE DIFGLINE
SET DIFGFIRP=$PIECE(DIFGDIX,":")
if DIFGFIRP="END"!DIFGER
QUIT
DO LINES
+8 QUIT
LINES IF DIFGFIRP="BEGIN"
DO RCR
if $SELECT($DATA(Y)
SET DIFGNOLK=""
if DIFGER
GOTO X
if '$DATA(DIFGNOLK)
SET X="`"_+Y
if $DATA(DIFGNOLK)&(DIFGTYP'="MV FIELD")&(DIFGTYP'="FILE")
SET X=DIFGALNK
if $DATA(DIFGDIC(DIC))&'$DATA(DIFGNOLK)
DO ARRAY^DIFG5
KILL Y
GOTO X
+1 IF DIFGFIRP="IDENTIFIER"!(DIFGFIRP="SPECIFIER")
DO ^DIFG0
if DIFGER
GOTO X
if '$DATA(DIFGPTER(DIFGCT))
SET DIFGSVVL(DIFGCT)=DIFGVAL(DIFGCT)
IF $DATA(DIFGPTER(DIFGCT))
DO IDENSPEC^DIFG5
GOTO X
+2 IF DIFGFIRP="KEY"
SET DIFGKEY=""
DO KEY^DIFG5
+3 IF DIFGFIRP="$DAT"
SET DIFGER=3_U_DIFGY
DO ERROR^DIFG
X QUIT
RCR NEW DIC,DIFGDRAD,DIFGDRCT,DIFGNOLK,DIFGFLUS
+1 SET DIFG=DIFG+1
SET DIFG("CHKCOND")=""
+2 DO BEGIN
if DIFGER
GOTO X
+3 IF '$DATA(DIFGNOLK)
DO PREDIC
IF 1
+4 IF '$TEST
SET DIFGDIC=DIC
DO ^DIFG4
DO SET^DIFG3A
+5 IF $DATA(DIFGDIC)#2
KILL DIFGCOND(DIFG,DIFGDIC)
+6 SET DIFG=DIFG-1
+7 QUIT
PREDIC IF $DATA(DIFGKEY)
if DIFGTYPE="MV FIELD"
DO MVFIELD^DIFG3A
GOTO X2
+1 SET DIFGDIC=DIC
+2 IF DIFGTYP="MV FIELD"
DO MVFIELD^DIFG3A
GOTO X2
+3 IF DIFGTYP="FILE"
IF $PIECE(DIFGMO(DIFGMULT),U)="A"
SET DIFGSKIP(DIFGMULT)=""
DO ^DIFG4
DO SET^DIFG3A
GOTO X2
+4 IF '$DATA(DIFGFLUS)
DO CALLDIC
IF 1
+5 IF '$TEST
DO SET^DIFG3A
X2 KILL DIFGKEY,DIFGSAVE(DIFG,"@NUM")
+1 if DIFGTYP'="MV FIELD"
KILL DIFG("ACGRV")
+2 QUIT
CALLDIC KILL D
+1 IF $DATA(DIFGXRF(DIFGMULT))
IF (DIFGTYP="MV FIELD"!(DIFGTYP="FILE"))
SET DIFGX=X
SET X=^UTILITY("DIFG@",$JOB,$PIECE(DIFGXRF(DIFGMULT),"=",2))
if X["^UTILITY(""DIFG@"""
GOTO NOLK
SET D=$PIECE(DIFGXRF(DIFGMULT),"=")
SET DIC(0)="FI"
Begin DoDot:1
+2 IF $EXTRACT(DIFGX)="`"
SET DIFGGRAV=""
SET DIFGX=$EXTRACT(DIFGX,2,245)
+3 IF '$TEST
NEW X
SET X=DIFGX
XECUTE $PIECE(^DD(DIFGDIC,.01,0),U,5,99)
if $DATA(X)
SET DIFGX=X
IF '$DATA(X)
SET DIFGNK=""
QUIT
+4 FOR DIFGI=1:1
if '$DATA(DIFGDIC(DIFGDIC,DIFGI))
QUIT
+5 SET DIFGDIC(DIFGDIC,DIFGI)="I $P(^(0),U)=DIFGX"
End DoDot:1
if $DATA(DIFGNK)
GOTO NOLK
+6 IF '$TEST
IF $EXTRACT(X)'="`"!($PIECE(^DD(DIFGDIC,.01,0),U,5,99)["DINUM")
SET DIC(0)="MFI"
+7 IF '$TEST
SET X=$EXTRACT(X,2,245)
SET DIC(0)="FI"
SET D="B"
SET DIFG("ACGRV")=""
+8 IF $DATA(D)
IF '$DATA(^DD(DIFGDIC,0,"IX",D))
DO DOLO^DIFG5
IF '$DATA(DIFG("FOUND"))
SET DIFGER=18_U_DIFGY
DO ERROR^DIFG
GOTO X6
+9 KILL DIFGNK
FOR DIFGI=1:1
if '$DATA(DIFGDIC(DIFGDIC,DIFGI))!$DATA(DIFGNK)
QUIT
IF $PIECE(DIFGDIC(DIFGDIC,DIFGI),"=",2)["DIFGVAL"
IF @$PIECE(DIFGDIC(DIFGDIC,DIFGI),"=",2)["DIFG("
SET DIFGNK=""
+10 IF '$DATA(DIFG("FOUND"))
IF '$DATA(DIFGNK)
DO @$SELECT($DATA(D):"IX^DIC",1:"^DIC")
NOLK IF X["^UTILITY(""DIFG@"""!$DATA(DIFGNK)
SET Y=-1
+1 IF $DATA(DIFGX)
SET X=$SELECT($DATA(DIFGGRAV):"`",1:"")_DIFGX
KILL DIFGX,DIFGGRAV
+2 DO CHECKY^DIFG5
+3 if 'DIFGER
DO SET^DIFG3A
X6 KILL DIFG("FOUND"),D,DR,DIFGNK
+1 IF DIFGTYP="MV FIELD"!(DIFGTYP="FILE")
KILL DIFGXRF(DIFGMULT)
+2 QUIT
