- DIFGG ;SFISC/XAK,EDE(OHPRD)-FILEGRAM GENERATOR ;7/25/92 2:15 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.
- ;
- K DIFG S DIFG=DIC,DIC("A")="Select FILEGRAM TEMPLATE: "
- S DK=+Y,DIC="^DIPT(",DIC("S")="I $P(^(0),U,8)=1 S %=^(0) I $P(%,U,4)=DK!'$L($P(%,U,4))",DIC(0)="QEAIS",D="F"_+Y
- D IX^DIC K DIC,DY Q:Y<0 S (DIFG("TEMPLATE"),DIFGT)=+Y
- S DIC=DIFG,DIC(0)="QEAM" D ^DIC Q:Y<0 S DIFG("FE")=+Y,DIFG("FUNC")="L",DIFG("DUZ")=$S($D(^VA(200,DUZ,0)):$P(^(0),U),$D(^DIC(3,DUZ,0)):$P(^(0),U),1:DUZ)
- D START,SEND,LOG K DIFG,^UTILITY("DIFG",$J) Q
- ;
- EN ; EXTERNAL ENTRY POINT
- START ;
- D INIT
- I DIFG("QFLG") D EOJ Q
- D HDR,ENV,BODY,TLR,EOJ
- Q
- ;
- HDR ; FILEGRAM HEADER
- S V="$DAT"_U_DIFG(DILL,"FNAME")_U_DIFG(DILL,"FILE")_U_DIFG("PARM")_U
- D INCSET^DIFGGU
- K Y Q
- ;
- ENV ; ENVIRONMENTAL VARS
- I $D(DIFG("ENV"))
- E Q
- S DIFG("EV")=""
- F S DIFG("EV")=$O(DIFG("ENV",DIFG("EV"))) Q:DIFG("EV")="" S V="ENVIRONMENT:"_DIFG("EV")_"="""_DIFG("ENV",DIFG("EV"))_"""" D INCSET^DIFGGU ;ihs/ohprd/dg;patch 2;8-22-91
- K DIFG("EV") Q
- ;
- BODY ; FILEGRAM BODY
- D BASE
- K DIFG("NOKEY")
- D NEXTLVL
- Q
- ;
- BASE ; BASEFILE ENTRY
- D LOOKUP^DIFGGU
- D FIELDS
- Q
- ;
- NEXTLVL ; DO NEXT LEVEL FILES/SUBFILES (CALLED RECURSIVELY)
- S DIFG(DILL,"DIFGI")=DIFGI
- S DILL=DILL+1
- F DIFGI=DIFGI:0 S DIFGI=$O(^DIPT(DIFGT,1,DIFGI)) Q:DIFGI'=+DIFGI S X=^(DIFGI,0) D NEXTLVL2 Q:DIFGI=""
- S DILL=DILL-1
- S DIFGI=DIFG(DILL,"DIFGI")
- Q
- ;
- NEXTLVL2 ; CHECK TEMPLATE ENTRY
- I $P(X,U,2)<DILL S DIFGI="" Q
- Q:$P(X,U,3)'=DIFG(DILL-1,"FILE") ; this is probably a template error
- D FVARS^DIFGGI
- I DIFG(DILL,"XREF")?1A.E D DIFGG3^DIFGG4 Q ; file shift
- I DIFG(DILL,"XREF")=3 D ^DIFGG4 Q ; subfile shift
- Q:'DIFG(DILL,"FE")
- ; only things left are dinum back pointers, direct forward pointers,
- ; and lookup file shifts, I think.
- D LOOKUP^DIFGGU
- I $D(DIFGGUQ) K DIFGGUQ Q
- D FIELDS
- D RECURSE
- S DITAB=2*(DILL-1)
- S V=":" D INCSET^DIFGGU
- Q
- ;
- RECURSE ; RECURSION FOR DINUM BACK POINTERS AND FORWARD DIRECT POINTERS
- D NEXTLVL
- Q
- ;
- FIELDS ; FILEGRAM FIELDS
- S DITAB=DITAB+2 D ^DIFGG2 S DITAB=DITAB-2
- Q
- ;
- LOG ; RECORD THE SENDING
- Q:$D(DIAR)!$D(DY)
- S DIC=1.12,X="NOW",DIC(0)="L",DLAYGO=1.12,DIADD=1 D ^DIC Q:Y<0 G LOG:'$P(Y,U,3)
- S ^DIAR(1.12,+Y,0)=$P(Y,U,2)_"^s^"_DIFG("DUZ")_U_DIFG_U_DIFG("FE")_U_XMZ_U_DIFG("TEMPLATE")
- K DIC,DIE,DR,DA,DLAYGO,DIADD,XMZ
- Q
- ;
- ;
- SEND ; CALL MAILMAN
- Q:$D(DIAR)!$D(DY)
- S XMSUB="FILEGRAM for entry #"_DIFG("FE")_" in "_$O(^DD(DIFG,0,"NM",0))_" FILE (#"_DIFG_")."
- S XMTEXT=DIFG("FGR"),XMDUZ=DUZ D ^XMD
- Q
- ;
- TLR ; FILEGRAM TRAILER
- S V="$END DAT",DITAB=0
- D INCSET^DIFGGU
- Q
- ;
- INIT ; INITIALIZATION
- D ^DIFGGI
- Q
- ;
- EOJ ;
- S:DIFG("QFLG") DIFGER=DIFG("QFLG")
- F I=0:0 S I=$O(DIFG(I)) Q:I'=+I K DIFG(I)
- K ^UTILITY("DIFGLINK",$J)
- K DIFG2,DIFGI,DIFGT,DILL,DITAB,DIFGENV,DIFGGU,DIFGGF ;Don't kill DILC used by EN^DIFGG;ihs/ohprd/dwg;patch 2;8-22-91
- K %H,%K,%W,S,V,X
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFGG 3217 printed Feb 19, 2025@00:14:02 Page 2
- DIFGG ;SFISC/XAK,EDE(OHPRD)-FILEGRAM GENERATOR ;7/25/92 2:15 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 KILL DIFG
- SET DIFG=DIC
- SET DIC("A")="Select FILEGRAM TEMPLATE: "
- +8 SET DK=+Y
- SET DIC="^DIPT("
- SET DIC("S")="I $P(^(0),U,8)=1 S %=^(0) I $P(%,U,4)=DK!'$L($P(%,U,4))"
- SET DIC(0)="QEAIS"
- SET D="F"_+Y
- +9 DO IX^DIC
- KILL DIC,DY
- if Y<0
- QUIT
- SET (DIFG("TEMPLATE"),DIFGT)=+Y
- +10 SET DIC=DIFG
- SET DIC(0)="QEAM"
- DO ^DIC
- if Y<0
- QUIT
- SET DIFG("FE")=+Y
- SET DIFG("FUNC")="L"
- SET DIFG("DUZ")=$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),$DATA(^DIC(3,DUZ,0)):$PIECE(^(0),U),1:DUZ)
- +11 DO START
- DO SEND
- DO LOG
- KILL DIFG,^UTILITY("DIFG",$JOB)
- QUIT
- +12 ;
- EN ; EXTERNAL ENTRY POINT
- START ;
- +1 DO INIT
- +2 IF DIFG("QFLG")
- DO EOJ
- QUIT
- +3 DO HDR
- DO ENV
- DO BODY
- DO TLR
- DO EOJ
- +4 QUIT
- +5 ;
- HDR ; FILEGRAM HEADER
- +1 SET V="$DAT"_U_DIFG(DILL,"FNAME")_U_DIFG(DILL,"FILE")_U_DIFG("PARM")_U
- +2 DO INCSET^DIFGGU
- +3 KILL Y
- QUIT
- +4 ;
- ENV ; ENVIRONMENTAL VARS
- +1 IF $DATA(DIFG("ENV"))
- +2 IF '$TEST
- QUIT
- +3 SET DIFG("EV")=""
- +4 ;ihs/ohprd/dg;patch 2;8-22-91
- FOR
- SET DIFG("EV")=$ORDER(DIFG("ENV",DIFG("EV")))
- if DIFG("EV")=""
- QUIT
- SET V="ENVIRONMENT:"_DIFG("EV")_"="""_DIFG("ENV",DIFG("EV"))_""""
- DO INCSET^DIFGGU
- +5 KILL DIFG("EV")
- QUIT
- +6 ;
- BODY ; FILEGRAM BODY
- +1 DO BASE
- +2 KILL DIFG("NOKEY")
- +3 DO NEXTLVL
- +4 QUIT
- +5 ;
- BASE ; BASEFILE ENTRY
- +1 DO LOOKUP^DIFGGU
- +2 DO FIELDS
- +3 QUIT
- +4 ;
- NEXTLVL ; DO NEXT LEVEL FILES/SUBFILES (CALLED RECURSIVELY)
- +1 SET DIFG(DILL,"DIFGI")=DIFGI
- +2 SET DILL=DILL+1
- +3 FOR DIFGI=DIFGI:0
- SET DIFGI=$ORDER(^DIPT(DIFGT,1,DIFGI))
- if DIFGI'=+DIFGI
- QUIT
- SET X=^(DIFGI,0)
- DO NEXTLVL2
- if DIFGI=""
- QUIT
- +4 SET DILL=DILL-1
- +5 SET DIFGI=DIFG(DILL,"DIFGI")
- +6 QUIT
- +7 ;
- NEXTLVL2 ; CHECK TEMPLATE ENTRY
- +1 IF $PIECE(X,U,2)<DILL
- SET DIFGI=""
- QUIT
- +2 ; this is probably a template error
- if $PIECE(X,U,3)'=DIFG(DILL-1,"FILE")
- QUIT
- +3 DO FVARS^DIFGGI
- +4 ; file shift
- IF DIFG(DILL,"XREF")?1A.E
- DO DIFGG3^DIFGG4
- QUIT
- +5 ; subfile shift
- IF DIFG(DILL,"XREF")=3
- DO ^DIFGG4
- QUIT
- +6 if 'DIFG(DILL,"FE")
- QUIT
- +7 ; only things left are dinum back pointers, direct forward pointers,
- +8 ; and lookup file shifts, I think.
- +9 DO LOOKUP^DIFGGU
- +10 IF $DATA(DIFGGUQ)
- KILL DIFGGUQ
- QUIT
- +11 DO FIELDS
- +12 DO RECURSE
- +13 SET DITAB=2*(DILL-1)
- +14 SET V=":"
- DO INCSET^DIFGGU
- +15 QUIT
- +16 ;
- RECURSE ; RECURSION FOR DINUM BACK POINTERS AND FORWARD DIRECT POINTERS
- +1 DO NEXTLVL
- +2 QUIT
- +3 ;
- FIELDS ; FILEGRAM FIELDS
- +1 SET DITAB=DITAB+2
- DO ^DIFGG2
- SET DITAB=DITAB-2
- +2 QUIT
- +3 ;
- LOG ; RECORD THE SENDING
- +1 if $DATA(DIAR)!$DATA(DY)
- QUIT
- +2 SET DIC=1.12
- SET X="NOW"
- SET DIC(0)="L"
- SET DLAYGO=1.12
- SET DIADD=1
- DO ^DIC
- if Y<0
- QUIT
- if '$PIECE(Y,U,3)
- GOTO LOG
- +3 SET ^DIAR(1.12,+Y,0)=$PIECE(Y,U,2)_"^s^"_DIFG("DUZ")_U_DIFG_U_DIFG("FE")_U_XMZ_U_DIFG("TEMPLATE")
- +4 KILL DIC,DIE,DR,DA,DLAYGO,DIADD,XMZ
- +5 QUIT
- +6 ;
- +7 ;
- SEND ; CALL MAILMAN
- +1 if $DATA(DIAR)!$DATA(DY)
- QUIT
- +2 SET XMSUB="FILEGRAM for entry #"_DIFG("FE")_" in "_$ORDER(^DD(DIFG,0,"NM",0))_" FILE (#"_DIFG_")."
- +3 SET XMTEXT=DIFG("FGR")
- SET XMDUZ=DUZ
- DO ^XMD
- +4 QUIT
- +5 ;
- TLR ; FILEGRAM TRAILER
- +1 SET V="$END DAT"
- SET DITAB=0
- +2 DO INCSET^DIFGGU
- +3 QUIT
- +4 ;
- INIT ; INITIALIZATION
- +1 DO ^DIFGGI
- +2 QUIT
- +3 ;
- EOJ ;
- +1 if DIFG("QFLG")
- SET DIFGER=DIFG("QFLG")
- +2 FOR I=0:0
- SET I=$ORDER(DIFG(I))
- if I'=+I
- QUIT
- KILL DIFG(I)
- +3 KILL ^UTILITY("DIFGLINK",$JOB)
- +4 ;Don't kill DILC used by EN^DIFGG;ihs/ohprd/dwg;patch 2;8-22-91
- KILL DIFG2,DIFGI,DIFGT,DILL,DITAB,DIFGENV,DIFGGU,DIFGGF
- +5 KILL %H,%K,%W,S,V,X
- +6 QUIT