DIFG2 ;SFISC/DG(OHPRD)-PROCESSING OF MULTIPLES FROM FILEGRAM ;02/02/93 4:21 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 ;CALLED BY DIFG
S DIFG=DIFG+1
I DIFGMULT=0 S DIFGNDC=0,DIFGM(0)=DIC ;ENTERING HIGHEST LEVEL MULTIPLE
N DIC
D MULT
I DIFGER G X1
I '$D(DIFG("NOLKUP")) D ^DIFG3 I 1
E D NOLOOK
I DIFGER G X1
D SET
K DIFGALNK,DIFGMLND,DIFGPC,DIFGFLD,DIFGVAL,DIFGDOL,DIFGNUMF,DIFGNOLK,DIFGLAGO,Y,DIFG("NOLKUP"),DIFG("ACGRV"),DIFGDIC(DIFGDIC)
D FILE^DIFG
K DIFGSKIP(DIFGMULT) ;Going up one level so kill this variable which tells lower level multiples not to do lookup
D CHANGEDA
S DIFG=DIFG-1
X1 Q
;
MULT ;MULTIPLE FIELD LOOKUP AND CALL TO SET DR STRING FOR MULTIPLE
I DIFGMULT=0 S DIFGMGBL(DIFGMULT)=$S(DIFGM(0):^DIC(DIFGM(0),0,"GL"),1:DIC),DIFGDA(DIFGMULT)=DA
S DIFGNODE=$P($P(DIFGMLND,"^",4),";")
S DIFGLAGO=0
I $P(^DD(DIFGNUM,.01,0),U,2)'["'"!($D(DIFGENV("LAYGO",DIFGNUM,.01))) S DIFGLAGO=1 ;Not a ptr or a ptr and laygo allowed
S DIFGMULT=DIFGMULT+1
I $D(DIFGSKIP(DIFGMULT-1)) S DIFGSKIP(DIFGMULT)=""
S DIFGMGBL(DIFGMULT)=DIFGMGBL(DIFGMULT-1)_DIFGDA(DIFGMULT-1)_","_""""_DIFGNODE_""""_","
S DIFGM(DIFGMULT)=DIFGNUM
S DIC=DIFGNUM D BASE^DIFG0 Q:DIFGER D FUNC^DIFG0
Q
;
NOLOOK ;IF NO LOOKUP REQUIRED, SET DA ARRAY
F DIFGI=DIFGMULT:-1:1 S DA(DIFGI)=$S(DIFGI=1:DA,1:DA(DIFGI-1))
Q
;
SET ;
I '$D(DIFGSKIP(DIFGMULT)) S (DA,DIFGDA(DIFGMULT))=+Y
E S (DA,DIFGDA(DIFGMULT))=DIFGALNK I '$D(DIFGFLUS) D
. S ^UTILITY("DIFG",$J,DIFGINCR,DIC,"X")=$S($E(X)="`":$E(X,2,245)_"^N",($D(DIFG("ACGRV"))!(X[("^UTILITY(""DIFG@"","_$J))):X_"^N",1:X_"^"),^("MODE")="A"_"^"_$P(^("MODE"),U,2),^("DIC(""P"")")=$P(DIFGMLND,U,2)
S DIC=DIFGM(DIFGMULT)
S ^UTILITY("DIFG",$J,DIFGINCR,DIC,"DA")=DA,^("GL")=DIFGMGBL(DIFGMULT),^($S($D(DIFGSKIP(DIFGMULT))&('$D(DIFGFLUS)):"DIC(""DR"")",1:"DR"))="" F DIFGI=1:1:DIFGMULT S ^("DA("_DIFGI_")")=DA(DIFGI)
I $D(DIFGSKIP(DIFGMULT)),'$D(DIFGFLUS) D ENADD^DIFG4
K DIFGTYP,DIFGFLUS ;DIFGTYP exists due to DIFG3 not killing it if DIFGTYP="MV FIELD" - Needed in case one calls ENADD^DIFG4
Q
;
CHANGEDA ;BACK DOWN ONE LEVEL DA'S, I.E. DA=DA(1),DA(1)=DA(2) ETC.
S DA=DA(1)
I DIFGMULT>1 F DIFGI=DIFGMULT:-1:2 S DA(DIFGI-1)=DA(DIFGI)
K DA(DIFGMULT)
S DIFGMULT=DIFGMULT-1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFG2 2549 printed Apr 09, 2024@21:46:24 Page 2
DIFG2 ;SFISC/DG(OHPRD)-PROCESSING OF MULTIPLES FROM FILEGRAM ;02/02/93 4:21 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 ;CALLED BY DIFG
+1 SET DIFG=DIFG+1
+2 ;ENTERING HIGHEST LEVEL MULTIPLE
IF DIFGMULT=0
SET DIFGNDC=0
SET DIFGM(0)=DIC
+3 NEW DIC
+4 DO MULT
+5 IF DIFGER
GOTO X1
+6 IF '$DATA(DIFG("NOLKUP"))
DO ^DIFG3
IF 1
+7 IF '$TEST
DO NOLOOK
+8 IF DIFGER
GOTO X1
+9 DO SET
+10 KILL DIFGALNK,DIFGMLND,DIFGPC,DIFGFLD,DIFGVAL,DIFGDOL,DIFGNUMF,DIFGNOLK,DIFGLAGO,Y,DIFG("NOLKUP"),DIFG("ACGRV"),DIFGDIC(DIFGDIC)
+11 DO FILE^DIFG
+12 ;Going up one level so kill this variable which tells lower level multiples not to do lookup
KILL DIFGSKIP(DIFGMULT)
+13 DO CHANGEDA
+14 SET DIFG=DIFG-1
X1 QUIT
+1 ;
MULT ;MULTIPLE FIELD LOOKUP AND CALL TO SET DR STRING FOR MULTIPLE
+1 IF DIFGMULT=0
SET DIFGMGBL(DIFGMULT)=$SELECT(DIFGM(0):^DIC(DIFGM(0),0,"GL"),1:DIC)
SET DIFGDA(DIFGMULT)=DA
+2 SET DIFGNODE=$PIECE($PIECE(DIFGMLND,"^",4),";")
+3 SET DIFGLAGO=0
+4 ;Not a ptr or a ptr and laygo allowed
IF $PIECE(^DD(DIFGNUM,.01,0),U,2)'["'"!($DATA(DIFGENV("LAYGO",DIFGNUM,.01)))
SET DIFGLAGO=1
+5 SET DIFGMULT=DIFGMULT+1
+6 IF $DATA(DIFGSKIP(DIFGMULT-1))
SET DIFGSKIP(DIFGMULT)=""
+7 SET DIFGMGBL(DIFGMULT)=DIFGMGBL(DIFGMULT-1)_DIFGDA(DIFGMULT-1)_","_""""_DIFGNODE_""""_","
+8 SET DIFGM(DIFGMULT)=DIFGNUM
+9 SET DIC=DIFGNUM
DO BASE^DIFG0
if DIFGER
QUIT
DO FUNC^DIFG0
+10 QUIT
+11 ;
NOLOOK ;IF NO LOOKUP REQUIRED, SET DA ARRAY
+1 FOR DIFGI=DIFGMULT:-1:1
SET DA(DIFGI)=$SELECT(DIFGI=1:DA,1:DA(DIFGI-1))
+2 QUIT
+3 ;
SET ;
+1 IF '$DATA(DIFGSKIP(DIFGMULT))
SET (DA,DIFGDA(DIFGMULT))=+Y
+2 IF '$TEST
SET (DA,DIFGDA(DIFGMULT))=DIFGALNK
IF '$DATA(DIFGFLUS)
Begin DoDot:1
+3 SET ^UTILITY("DIFG",$JOB,DIFGINCR,DIC,"X")=$SELECT($EXTRACT(X)="`":$EXTRACT(X,2,245)_"^N",($DATA(DIFG("ACGRV"))!(X[("^UTILITY(""DIFG@"","_$JOB))):X_"^N",1:X_"^")
SET ^("MODE")="A"_"^"_$PIECE(^("MODE"),U,2)
SET ^("DIC(""P"")")=$PIECE(DIFGMLND,U,2)
End DoDot:1
+4 SET DIC=DIFGM(DIFGMULT)
+5 SET ^UTILITY("DIFG",$JOB,DIFGINCR,DIC,"DA")=DA
SET ^("GL")=DIFGMGBL(DIFGMULT)
SET ^($SELECT($DATA(DIFGSKIP(DIFGMULT))&('$DATA(DIFGFLUS)):"DIC(""DR"")",1:"DR"))=""
FOR DIFGI=1:1:DIFGMULT
SET ^("DA("_DIFGI_")")=DA(DIFGI)
+6 IF $DATA(DIFGSKIP(DIFGMULT))
IF '$DATA(DIFGFLUS)
DO ENADD^DIFG4
+7 ;DIFGTYP exists due to DIFG3 not killing it if DIFGTYP="MV FIELD" - Needed in case one calls ENADD^DIFG4
KILL DIFGTYP,DIFGFLUS
+8 QUIT
+9 ;
CHANGEDA ;BACK DOWN ONE LEVEL DA'S, I.E. DA=DA(1),DA(1)=DA(2) ETC.
+1 SET DA=DA(1)
+2 IF DIFGMULT>1
FOR DIFGI=DIFGMULT:-1:2
SET DA(DIFGI-1)=DA(DIFGI)
+3 KILL DA(DIFGMULT)
+4 SET DIFGMULT=DIFGMULT-1
+5 QUIT
+6 ;
