source: FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXTRANS.m@ 649

Last change on this file since 649 was 628, checked in by George Lilly, 16 years ago

initial load of FOIAVistA 6/30/08 version
File size: 8.4 KB
Line 
1ECXTRANS ;ALB/GTS,JAP,BIR/DMA-Extract from Local Editing Files and Transmit ; 12/14/04 9:10am
2 ;;3.0;DSS EXTRACTS;**2,9,12,8,13,14,23,24,33,49,54,75,71**;Dec 22, 1997
3EN ;entry point
4 N ECDA,ECRE,ECTMP,ECCHK,ECDIVVR,ECXDIQ,JJ,SS,OUT,DIR,DUOUT
5 N DTOUT,DIRUT,DIC,X,Y,ECXLOGIC,ECSD,FODMN
6 S ECXQUEUE=$P($G(^ECX(728,1,"QUEUE")),"^",1)
7 I ECXQUEUE'?1"DM"1U D Q
8 .W !,"You have not defined a proper transmission queue"
9 .W !,"for entry number 1 in the DSS EXTRACTS file (#728)."
10 .W !,"No transmission allowed."
11 .D PAUSE
12 ;** check divisions for transmission
13 S ECCHK=$$DIV4^XUSER(.ECTMP,DUZ)
14 I 'ECCHK D Q
15 .W !,"You do not have any divisions defined in your user set up and cannot transmit."
16 .S DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." D ^DIR K DIR,X,Y
17 W !!,"Your user setup will only allow you to transmit extracts from the"
18 W !,"following divisions:",!
19 S ECDIVVR=""
20 F S ECDIVVR=$O(ECTMP(ECDIVVR)) Q:'(+ECDIVVR) D
21 .K ECXDIC S DA=ECDIVVR,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01"
22 .D EN^DIQ1 W !," ",$G(ECXDIC(4,DA,.01,"I")) K DIC,DIQ,DA,DR,ECXDIC
23 W !!,"If you can't select an extract, it is probably from another division.",!
24 D PAUSE Q:OUT
25AGAIN S ECRE="",DIC="^ECX(727,",DIC(0)="AEQM"
26 S DIC("A")="Transmit which extract: "
27 S DIC("S")="I '$D(^ECX(727,+Y,""L"")),'$D(^ECX(727,+Y,""PURG"")),$D(ECTMP(+$P($G(^ECX(727,+Y,""DIV"")),U,1)))"
28 D ^DIC
29 I Y<0 W !! Q
30 ;get data on extract
31 S DR="1;2;3;4;5;6;14;15",(ECDA,DA)=+Y,DIQ(0)="IE",DIQ="ECXDIQ" D EN^DIQ1
32 I ECXDIQ(727,ECDA,14,"I")="" D
33 .S ECXDIQ(727,ECDA,14,"I")=$$FISCAL^ECXUTL1(ECXDIQ(727,ECDA,3,"I"))
34 .S ECXDIQ(727,ECDA,14,"E")=ECXDIQ(727,ECDA,14,"I")
35 S ECXLOGIC=ECXDIQ(727,ECDA,14,"I")
36 S ECSD=ECXDIQ(727,ECDA,3,"I")
37 W !!,ECXDIQ(727,ECDA,6,"E")_" Extract (#"_ECDA_")",?42,"Records: ",ECXDIQ(727,ECDA,5,"E")
38 W !,"Generated on: ",ECXDIQ(727,ECDA,1,"E"),?42,"Start date: ",ECXDIQ(727,ECDA,3,"E")
39 W !,"Division: ",$E(ECXDIQ(727,ECDA,15,"E"),1,26),?42,"End date: ",ECXDIQ(727,ECDA,4,"E")
40 S X=$E(ECXDIQ(727,ECDA,14,"I"),5) S X=$S((X="")!(X=" "):"",1:"revision "_X_" of ")
41 W !!,"The data was extracted using "_X_"fiscal year "_$E(ECXDIQ(727,ECDA,14,"I"),1,4)_" logic."
42 W !!,"MailMan transmission of the "_ECXDIQ(727,ECDA,2,"E")_" extract is set to a"
43 W !,"limit of 131,000 bytes per message. Each extract record ends with a ^~."
44 I $G(^ECX(727,ECDA,"TR")) S ECX=^("TR") D Q:OUT
45 .S OUT=0
46 .W !!,"This extract was transmitted on ",$TR($$FMTE^XLFDT(ECX,"5DF")," ","0")
47 .K ECX S DIR(0)="Y",DIR("A")="Do you want to retransmit " D ^DIR K DIR
48 .I 'Y S OUT=1 Q
49 .K ^ECX(727,ECDA,"TR")
50 .S ECRE="re"
51 S ECTYPE=$P(^ECX(727,ECDA,0),U,3),ECIEN=+$O(^ECX(727.1,"AC",ECTYPE,0))
52 S ECPIECE=$P($G(^ECX(727.1,ECIEN,0)),U,10)
53 I ECPIECE>0,$P($G(^ECX(728,1,7.1)),U,ECPIECE)]"" D Q
54 .D MES^XPDUTL(" ")
55 .D MES^XPDUTL("An "_ECTYPE_" Extract is currently running or scheduled to run.")
56 .D MES^XPDUTL("Please wait until that job has completed before attempting")
57 .D MES^XPDUTL("this transmission.")
58 .D MES^XPDUTL(" ")
59 .D PAUSE
60 S ZTSK=$G(^ECX(727,ECDA,"Q"))
61 I ZTSK D STAT^%ZTLOAD I ZTSK(0) I ZTSK(1)<3 D Q
62 .W !!,"Task ",ZTSK," is already queued to transmit this extract."
63 .K ZTSK
64 .D PAUSE
65 S FODMN=$$FODMN()
66 ;Field office reminder
67 I FODMN D
68 .W !
69 .W !,"** This extract is being sent from a field office domain. **"
70 .W !,"** Extract message(s) will only be delivered to you and **"
71 .W !,"** will be placed into your 'DSSXMIT' mail basket. **"
72 .W !
73 .;Ensure user has a DSSXMIT mail basket
74 .N TMPARR
75 .D LISTBSKT^XMXAPIB(DUZ,,,,"DSSXMIT","TMPARR")
76 .I '$D(TMPARR("XMLIST","BSKT","DSSXMIT")) D
77 ..;Create DSSXMIT basket
78 ..N IEN,XMERR
79 ..D CRE8BSKT^XMXAPIB(DUZ,"DSSXMIT",.IEN)
80 ..K ^TMP("XMERR",$J)
81 ;Test queue clearance
82 ;I 'FODMN I (ECXLOGIC'=$$FISCAL^ECXUTL1(ECSD))!((ECXLOGIC>$$FISCAL^ECXUTL1(DT))!(ECXLOGIC=$$FISCAL^ECXUTL1(DT))) D Q:OUT
83 ;.S OUT=0
84 ;.K DIR
85 ;.S DIR(0)="Y"
86 ;.S DIR("A",1)="** This extract will be transmitted to the AAC test queue **"
87 ;.S DIR("A")="Do you want to continue "
88 ;.W !! D ^DIR
89 ;.I 'Y S OUT=1 Q
90 ;.S ECXQUEUE=$P($G(^ECX(728,1,"QUEUE")),"^",2)
91 ;.S:ECXQUEUE="" ECXQUEUE="DMT"
92 S ZTSAVE("ECDA")="",ZTSAVE("ECXQUEUE")="",ZTSAVE("ECRE")=""
93 S ZTRTN="START^ECXTRANS",ZTIO=""
94 S ZTDESC="Transmission of extract # "_ECDA
95 W !! D ^%ZTLOAD
96 I $D(ZTSK) D
97 .W !,"Request queued as Task #",ZTSK,"."
98 .S ^ECX(727,ECDA,"Q")=ZTSK K ZTSK
99 .D PAUSE
100 Q
101 ; entry point for task
102START N DA,DIC,DIQ,DR,ECAR1,ECAR2,ECC1,ECC2,ECED,ECGPR,ECF,ECGRP,ECHEAD,ECINST
103 N ECMAX,ECMAXR,ECMSN,ECPACK,ECSIZ,ECVER,ECXDIC,I,J,EXDT
104 N STR,STRCNT,X,ECSD,ECXLOGIC
105 S:$P(^ECX(727,ECDA,0),U,3)'="Prosthetics" ECINST=$P(^ECX(728,1,0),U)
106 S:$P(^ECX(727,ECDA,0),U,3)="Prosthetics" ECINST=$P(^("DIV"),U)
107 S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
108 D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I"))
109 S ECF=^ECX(727,ECDA,"FILE"),ECHEAD=^("HEAD"),ECGRP=^("GRP")
110 S X=^(0),ECPACK=$P(X,U,3),ECSD=$P(X,U,4),ECED=$P(X,U,5)
111 S X=$G(^("VER")),ECVER=$P(X,"^",1),ECXLOGIC=$P(X,"^",2)
112 S:'ECVER ECVER=1 S ECVER=$$RJ^XLFSTR(ECVER,3,0)
113 I ECXLOGIC="" S ECXLOGIC=$$FISCAL^ECXUTL1(ECSD)
114 S ECXLOGIC=$$PAD^ECXUTL1(ECXLOGIC,5,"B"," ")
115 I ECPACK["(setup)" S ECXQUEUE="DMU"
116 K ^TMP($J)
117 S ECHD(1)=ECINST_ECHEAD_$$ECXYM^ECXUTL(ECED)_ECVER_ECXLOGIC
118 S ECMAX=130000,ECMAXR=250,ECLN=2,ECMSN=1,(ECRN,ECSIZ)=0,J=""
119 F S J=$O(^ECX(ECF,"AC",ECDA,J)) Q:('J) D
120 .M ECAR1=^ECX(ECF,J) S (ECAR2,ECC2)=1,(ECAR2(ECC2),ECC1)=""
121 .F S ECC1=$O(ECAR1(ECC1)) Q:ECC1="" D
122 ..S:ECC1=0 ECAR1(ECC1)=$P(ECAR1(ECC1),"^",4,999)
123 ..S ECAR2(ECC2)=ECAR2(ECC2)_ECAR1(ECC1) I $L(ECAR2(ECC2))>ECMAXR D
124 ...F I=ECMAXR:-1:1 Q:$E(ECAR2(ECC2),I)="^"
125 ...S (X,ECAR2)=ECAR2+1,ECAR2(X)=$E(ECAR2(ECC2),I+1,$L(ECAR2(ECC2)))
126 ...S ECAR2(ECC2)=$E(ECAR2(ECC2),1,I),ECC2=X
127 .S ECAR2(ECC2)=ECAR2(ECC2)_"^~",ECRN=ECRN+1,X=""
128 .F S X=$O(ECAR2(X)) Q:X="" D
129 ..S ^TMP($J,ECMSN,ECLN,0)=ECAR2(X),ECLN=ECLN+1,ECSIZ=ECSIZ+$L(ECAR2(X))
130 .K ECAR1,ECAR2
131 .I (ECSIZ>ECMAX),($O(^ECX(ECF,"AC",ECDA,J))) D
132 ..S ECLN=2,ECMSN=ECMSN+1,ECSIZ=0
133 ;quit if user stopped task
134 I $$S^%ZTLOAD D CLEAN Q
135 ;generate mailman messages to aac
136 S ECXLNCNT=9,(ECXXMZ,STRCNT)=0,STR=""
137 F ECMS=1:1:ECMSN D
138 .D SEND(.ECXXMZ)
139 .S STR=STR_$$RJ^XLFSTR(ECXXMZ,18," "),STRCNT=STRCNT+1 I STRCNT=4 D
140 ..S ^TMP($J,"LOC",ECXLNCNT,0)=STR,ECXLNCNT=ECXLNCNT+1
141 ..S STR="",STRCNT=0
142 I STR]"" S ^TMP($J,"LOC",ECXLNCNT,0)=STR
143 ;send msg to local dss grp
144 D SENDLOC,CLEAN
145 Q
146 ;
147SEND(ECXXMZ) ;send individual messages
148 N ECXDD,DA,DIC,DIE,DINUM,X,Y,Z,XMDUZ,XMTEXT,XMSUB,XMY,XMZ,FODMN
149 S XMSUB="("_ECGRP_") "_ECINST_" - "_ECPACK_" DSS EXTRACT, MESSAGE "_ECMS_" OF "_ECMSN
150 S XMDUZ="DSS SYSTEM",^TMP($J,ECMS,1,0)=ECHD(1)
151 S XMY("XXX@Q-"_ECXQUEUE_".VA.GOV")=""
152 ;Send extracts done at field offices to user instead of AAC
153 S FODMN=$$FODMN()
154 I FODMN D
155 .K XMY
156 .S XMY(DUZ)=""
157 S XMTEXT="^TMP($J,ECMS,"
158 D ^XMD
159 S ECXXMZ=XMZ
160 ;store msg# in extract log
161 D FIELD^DID(727,301,"","SPECIFIER","ECXDD")
162 S DA(1)=ECDA,DIC(0)="L",DIC("P")=ECXDD("SPECIFIER")
163 S DIC="^ECX(727,"_DA(1)_",1,",X=XMZ,DINUM=X
164 K DD,DO D FILE^DICN
165 ;Move message to DSSXMIT basket if sending from field office
166 I FODMN D
167 .N XMERR
168 .D MOVEMSG^XMXAPI(DUZ,,XMZ,"DSSXMIT",.X)
169 .K ^TMP("XMERR",$J)
170 Q
171 ;
172SENDLOC ; send message to mail group 'DSS-ECGRP'
173 S TIME=$P($$HTE^XLFDT($H),":",1,2)
174 S XMSUB=ECINST_" - "_ECPACK_" EXTRACT FOR DSS",XMDUZ="DSS SYSTEM"
175 K XMY S XMY(DUZ)="",XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))=""
176 S ^TMP($J,"LOC",1,0)="The DSS "_ECPACK_" ("_ECHEAD_") extract, #"_ECDA_","
177 S ^TMP($J,"LOC",2,0)="was "_ECRE_"transmitted on "_$P(TIME,"@")_" at "_$P(TIME,"@",2)_". "
178 S ^TMP($J,"LOC",3,0)=" "
179 S ^TMP($J,"LOC",4,0)="Maximum number of Bytes (characters) per message: 131,000 "
180 S ^TMP($J,"LOC",5,0)=" "
181 S ^TMP($J,"LOC",6,0)="A total of "_ECRN_" records were written."
182 S ^TMP($J,"LOC",7,0)="A total of "_ECMSN_" messages were sent."
183 S ^TMP($J,"LOC",8,0)=" Message numbers :"
184 S XMTEXT="^TMP($J,""LOC"","
185 D ^XMD
186 S ^ECX(727,ECDA,"TR")=DT
187 Q
188 ;
189CLEAN ;clean-up
190 S ZTREQ="@"
191 K ^TMP($J),^ECX(727,ECDA,"Q"),XMDUZ,XMTEXT,XMSUB,XMY,XMZ
192 K ECDA,ECRE,ECTMP,ECCHK,ECDIVVR,ECXDIQ,ECXMAX,ECXMSG
193 D ^ECXKILL
194 I $$S^%ZTLOAD K ZTREQ S ZTSTOP=1
195 Q
196 ;
197PAUSE ;pause screen
198 S OUT=0
199 I $E(IOST)="C" D
200 .S SS=22-$Y F JJ=1:1:SS W !
201 .K DIR S DIR(0)="E" W ! D ^DIR K DIR
202 I 'Y S OUT=1
203 W !!
204 Q
205 ;
206FODMN(DOMAIN) ;Is domain a field office domain
207 ;Input : DOMAIN - Domain name to check
208 ; - Default value pulled from ^XMB("NETNAME")
209 ;Output: 1 = Yes / 0 = No
210 ;
211 N X,SUB,OUT
212 S DOMAIN=$G(DOMAIN)
213 S:(DOMAIN="") DOMAIN=$G(^XMB("NETNAME"))
214 S OUT=0
215 F X=1:1:$L(DOMAIN,".") D Q:OUT
216 .S SUB=$P(DOMAIN,".",X)
217 .I ($E(SUB,1,3)="FO-")!($E(SUB,1,4)="ISC-") S OUT=1
218 Q OUT
Note: See TracBrowser for help on using the repository browser.