- DIFG3 ;SFISC/DG(OHPRD)-LOOKUP PROCESSING ;3/11/93 1:33 PM
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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
- DIFG3 ;SFISC/DG(OHPRD)-LOOKUP PROCESSING ;3/11/93 1:33 PM
- +1 ;;22.0;VA FileMan;;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 SET DIFGTYP=""
- XECUTE DIFGLINE
- +4 NEW DIC,DIFGDRAD,DIFGDRCT,DIFGFLUS
- +5 SET DIFG=DIFG+1
- +6 DO BEGIN
- IF DIFGER
- GOTO X5
- +7 SET DIFGTYP=$SELECT(DIFGTYPE="MV FIELD":"MV FIELD",DIFGTYPE="SV FIELD":"SV FIELD",1:"FILE")
- +8 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
- +9 IF '$DATA(DIFGNOLK)
- DO PREDIC
- IF 1
- +10 IF '$TEST
- IF DIFGTYP="MV FIELD"
- IF $DATA(DIFGNOLK)
- DO MVFIELD^DIFG3A
- IF 1
- +11 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
