source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIFGG.m@ 724

Last change on this file since 724 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1DIFGG ;SFISC/XAK,EDE(OHPRD)-FILEGRAM GENERATOR ;7/25/92 2:15 PM
2 ;;22.0;VA FileMan;;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 K DIFG S DIFG=DIC,DIC("A")="Select FILEGRAM TEMPLATE: "
5 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
6 D IX^DIC K DIC,DY Q:Y<0 S (DIFG("TEMPLATE"),DIFGT)=+Y
7 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)
8 D START,SEND,LOG K DIFG,^UTILITY("DIFG",$J) Q
9 ;
10EN ; EXTERNAL ENTRY POINT
11START ;
12 D INIT
13 I DIFG("QFLG") D EOJ Q
14 D HDR,ENV,BODY,TLR,EOJ
15 Q
16 ;
17HDR ; FILEGRAM HEADER
18 S V="$DAT"_U_DIFG(DILL,"FNAME")_U_DIFG(DILL,"FILE")_U_DIFG("PARM")_U
19 D INCSET^DIFGGU
20 K Y Q
21 ;
22ENV ; ENVIRONMENTAL VARS
23 I $D(DIFG("ENV"))
24 E Q
25 S DIFG("EV")=""
26 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
27 K DIFG("EV") Q
28 ;
29BODY ; FILEGRAM BODY
30 D BASE
31 K DIFG("NOKEY")
32 D NEXTLVL
33 Q
34 ;
35BASE ; BASEFILE ENTRY
36 D LOOKUP^DIFGGU
37 D FIELDS
38 Q
39 ;
40NEXTLVL ; DO NEXT LEVEL FILES/SUBFILES (CALLED RECURSIVELY)
41 S DIFG(DILL,"DIFGI")=DIFGI
42 S DILL=DILL+1
43 F DIFGI=DIFGI:0 S DIFGI=$O(^DIPT(DIFGT,1,DIFGI)) Q:DIFGI'=+DIFGI S X=^(DIFGI,0) D NEXTLVL2 Q:DIFGI=""
44 S DILL=DILL-1
45 S DIFGI=DIFG(DILL,"DIFGI")
46 Q
47 ;
48NEXTLVL2 ; CHECK TEMPLATE ENTRY
49 I $P(X,U,2)<DILL S DIFGI="" Q
50 Q:$P(X,U,3)'=DIFG(DILL-1,"FILE") ; this is probably a template error
51 D FVARS^DIFGGI
52 I DIFG(DILL,"XREF")?1A.E D DIFGG3^DIFGG4 Q ; file shift
53 I DIFG(DILL,"XREF")=3 D ^DIFGG4 Q ; subfile shift
54 Q:'DIFG(DILL,"FE")
55 ; only things left are dinum back pointers, direct forward pointers,
56 ; and lookup file shifts, I think.
57 D LOOKUP^DIFGGU
58 I $D(DIFGGUQ) K DIFGGUQ Q
59 D FIELDS
60 D RECURSE
61 S DITAB=2*(DILL-1)
62 S V=":" D INCSET^DIFGGU
63 Q
64 ;
65RECURSE ; RECURSION FOR DINUM BACK POINTERS AND FORWARD DIRECT POINTERS
66 D NEXTLVL
67 Q
68 ;
69FIELDS ; FILEGRAM FIELDS
70 S DITAB=DITAB+2 D ^DIFGG2 S DITAB=DITAB-2
71 Q
72 ;
73LOG ; RECORD THE SENDING
74 Q:$D(DIAR)!$D(DY)
75 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)
76 S ^DIAR(1.12,+Y,0)=$P(Y,U,2)_"^s^"_DIFG("DUZ")_U_DIFG_U_DIFG("FE")_U_XMZ_U_DIFG("TEMPLATE")
77 K DIC,DIE,DR,DA,DLAYGO,DIADD,XMZ
78 Q
79 ;
80 ;
81SEND ; CALL MAILMAN
82 Q:$D(DIAR)!$D(DY)
83 S XMSUB="FILEGRAM for entry #"_DIFG("FE")_" in "_$O(^DD(DIFG,0,"NM",0))_" FILE (#"_DIFG_")."
84 S XMTEXT=DIFG("FGR"),XMDUZ=DUZ D ^XMD
85 Q
86 ;
87TLR ; FILEGRAM TRAILER
88 S V="$END DAT",DITAB=0
89 D INCSET^DIFGGU
90 Q
91 ;
92INIT ; INITIALIZATION
93 D ^DIFGGI
94 Q
95 ;
96EOJ ;
97 S:DIFG("QFLG") DIFGER=DIFG("QFLG")
98 F I=0:0 S I=$O(DIFG(I)) Q:I'=+I K DIFG(I)
99 K ^UTILITY("DIFGLINK",$J)
100 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
101 K %H,%K,%W,S,V,X
102 Q
Note: See TracBrowser for help on using the repository browser.