DIFGG ;SFISC/XAK,EDE(OHPRD)-FILEGRAM GENERATOR ;7/25/92 2:15 PM
;;22.0;VA FileMan;;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
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
DIFGG ;SFISC/XAK,EDE(OHPRD)-FILEGRAM GENERATOR ;7/25/92 2:15 PM
+1 ;;22.0;VA FileMan;;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 KILL DIFG
SET DIFG=DIC
SET DIC("A")="Select FILEGRAM TEMPLATE: "
+4 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
+5 DO IX^DIC
KILL DIC,DY
IF Y<0
QUIT
SET (DIFG("TEMPLATE"),DIFGT)=+Y
+6 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)
+7 DO START
DO SEND
DO LOG
KILL DIFG,^UTILITY("DIFG",$JOB)
QUIT
+8 ;
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
