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