source: FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUDBQUE.m@ 1804

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

initial load of FOIAVistA 6/30/08 version
File size: 7.7 KB
Line 
1PSUDBQUE ; IHS/ADC/GTH - DOUBLE QUEUING SHELL HANDLER; 04 NOV 1997
2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
3 ; XB*3*5 - IHS/ADC/GTH 10-31-97
4 ; Thanks to Paul Wesley, DSD, for the original routine.
5 ; ---------------------------------------------------------
6 ; Programmer documentation included at end of routine - PGMNOTE
7 ; ---------------------------------------------------------
8 ;
9START ;
10EN ;PEP for double queuing
11 NEW PSU ; use a fresh array in case of nesting double queues
12 ; insure IO array is set fully
13 I ($D(IO)'>10) S IOP="HOME" D ^%ZIS
14 I $D(ZTQUEUED) S PSUFQ=1 S:'$D(PSUDTH) PSUDTH="NOW" ; insure auto-requeue if called from a queued
15 I '$D(PSURC),'$D(PSURP) Q ; insure one of RC or RP exist
16 I $D(PSUTITLE) S PSU("TITLE")=PSUTITLE K PSUTITLE
17 I IO="" S ION="NULL",(IOST,IOM,IOSL)=0
18 S PSU("IOP1")=ION_";"_IOST_";"_IOM_";"_IOSL ; store current IO params
19 I $G(IOPAR)]"" S PSU("IOPAR")=IOPAR ; store IOPAR
20 I $L($G(PSURC))=0 S PSURC="NORC^PSUDBQUE" ; no compute identified
21 S PSU("RC")=PSURC,PSU("RP")=$G(PSURP),PSU("RX")=$G(PSURX)
22 ; load PSUNS="xx;yy;.." into PSU("NS",xx*) ...
23 S PSUNS=$TR("PSUNS",",",";") ; allow "," seperator
24 F PSUI=1:1 S PSUNSX=$P($G(PSUNS),";",PSUI) Q:PSUNSX="" S:(PSUNSX'["*") PSUNSX=PSUNSX_"*" S PSU("NS",PSUNSX)=""
25 S PSU("NS","PSU*")=""
26 ; load PSUNS("xxx") array into PSU("NS","xxx")
27 S PSUNSX=""
28 F S PSUNSX=$O(PSUNS(PSUNSX)) Q:PSUNSX="" S PSU("NS",PSUNSX)=""
29 ; if this is a double queue with PSU("IOP") setup .. pull the parameters out
30 ; of a ^%ZIS call to set up the parameters without an open
31 S PSU("IOP")=$G(PSUIOP)
32 I $D(PSUIOP) S IOP=PSUIOP
33 ; PSU*3*5 - IHS/ADC/GTH 10-31-97 start block
34 I $G(PSU("IOPAR"))]"" S %ZIS("IOPAR")=PSU("IOPAR") D
35 . I PSU("IOPAR")'?1"(""".E1""":""".E1""")" Q ; skip HFS if not an HFS
36 . S PSUHFSNM=$P(PSU("IOPAR"),":"),PSUHFSNM=$TR(PSUHFSNM,"()""")
37 . S PSUHFSMD=$P(PSU("IOPAR"),":",2),PSUHFSMD=$TR(PSUHFSMD,"()""")
38 . S %ZIS("HFSNAME")=PSUHFSNM,%ZIS("HFSMODE")=PSUHFSMD
39 . ;this code drops through
40 ; PSU*3*5 - IHS/ADC/GTH 10-31-97 end block
41ZIS ;
42 KILL IO("Q")
43 I $G(PSURC)]"",$G(PSURP)="" G ZISQ
44 S %ZIS="PQM"
45 D ^%ZIS ; get parameters without an open
46 I POP W !,"REPORTING-ABORTED",*7 G END1
47 S PSU("IO")=IO,PSU("IOP")=ION_";"_IOST_";"_IOM_";"_IOSL,PSU("IOPAR")=$G(IOPAR),PSU("CPU")=$G(IOCPU),PSU("ION")=ION
48ZISQ ;
49 I '$D(IO("Q")),'$G(PSUFQ) D
50 . I $D(ZTQUEUED) S PSUFQ=1 Q
51 . I IO=IO(0),$G(PSURP)]"" Q
52 . KILL DIR
53 . S DIR(0)="Y",DIR("B")="Y",DIR("A")="Won't you queue this "
54 . D ^DIR
55 . KILL DIR
56 . I X["^" S PSUQUIT=1
57 . S:Y=1 IO("Q")=1
58 . Q
59 ;
60 KILL PSU("ZTSK")
61 I $D(ZTQUEUED),$G(ZTSK) S PSU("ZTSK")=ZTSK
62 KILL ZTSK
63 ; quit if user says so
64 I $G(PSUQUIT) KILL DIR S DIR(0)="E",DIR("A")="Report Aborted .. <CR> to continue" D ^DIR KILL DIR G END1
65 ;
66QUE1 ;
67 I ($D(IO("Q"))!($G(PSUFQ))) D K IO("Q") W:(($G(ZTSK))&('$D(PSU("ZTSK")))) !,"Tasked with ",ZTSK W:'$G(ZTSK) !,*7,"Que not successful ... REPORTING ABORTED" D:'$D(ZTQUEUED) ^%ZISC S IOP=PSU("IOP1") D:'$D(ZTQUEUED) ^%ZIS G END1 ;--->
68 . ;I '$D(ZTQUEUED),IO=IO(0),$G(PSURP)]"" W !,"Queing to slave printer not allowed ... Report Aborting" Q ;---^
69 . I $D(PSU("TITLE")) S ZTDESC=PSU("TITLE")_" compute"
70 . E S ZTDESC="Double Que COMPUTing "_PSURC_" "_$G(PSURP)
71 . S ZTIO="",ZTRTN="DEQUE1^PSUDBQUE"
72 . S:$D(PSUDTH) ZTDTH=PSUDTH
73 . S:$G(PSU("CPU"))]"" ZTCPU=PSU("CPU")
74 . S PSUNSX=""
75 . F S PSUNSX=$O(PSU("NS",PSUNSX)) Q:PSUNSX="" S ZTSAVE(PSUNSX)=""
76 . KILL PSURC,PSURP,PSURX,PSUNS,PSUFQ,PSUDTH,PSUIOP,PSUPAR,PSUDTH,PSUNSX,PSUI
77 . S ZTIO="" ; insure no device loaded
78 . D ^%ZTLOAD
79 . Q ; these do .s branch to END1
80 ; (((if queued the above code branched to END)))
81 ;
82DEQUE1 ;> 1st deque
83 ;
84 KILL PSURC,PSURP,PSURX,PSUNS,PSUFQ,PSUDTH,PSUIOP,PSUPAR,PSUDTH
85 KILL PSU("ZTSK")
86 I $D(ZTQUEUED),$G(ZTSK) S PSU("ZTSK")=ZTSK
87 ;
88COMPUTE ;>do computing | routine
89 ;
90 D @(PSU("RC")) ; >>>PERFORM THE COMPUTE ROUTINE<<< ;stuffed if not provided with NORC^PSUDBQUE
91 ;
92QUE2 ;
93 ;
94 I $D(ZTQUEUED) D G ENDC ;===> automatically requeue if queued
95 . Q:PSU("RP")=""
96 . I $D(PSU("TITLE")) S ZTDESC=PSU("TITLE")_" print"
97 . E S ZTDESC="Double Que PRINT "_PSU("RC")_" "_PSU("RP")
98 . S ZTIO=PSU("IO"),ZTDTH=$H,ZTRTN="DEQUE2^PSUDBQUE"
99 . S PSUNSX=""
100 . F S PSUNSX=$O(PSU("NS",PSUNSX)) Q:PSUNSX="" S ZTSAVE(PSUNSX)=""
101 . D SETIOPN K ZTIO
102 . D ^%ZTLOAD
103 . I '$D(ZTSK) S PSUERR="SECOND QUE FAILED" D @^%ZOSF("ERRTN") Q
104 . S PSUDBQUE=1
105 . Q ; ======> this branches to ENDC
106 ;
107 ; device opened from the first que ask
108DEQUE2 ;>EP 2nd Deque | printing
109 KILL PSU("ZTSK")
110 I $D(ZTQUEUED),$G(ZTSK) S PSU("ZTSK")=ZTSK
111 ;open printer device for printing with all selected parameters
112 G:(PSU("RP")="") END ;---> exit if no print
113 ;
114 U IO
115 D @(PSU("RP")) ; >>>PERFORM PRINTING ROUTINE
116 ;
117 ;--------
118END ;>End | cleanup
119 ;
120 I $G(PSU("RX"))'="" D @(PSU("RX")) ; >>>PERFORM CLEANUP ROUTINE<<<
121 ;
122END0 ;EP - from compute cycle when PSU("RP") EXISTS
123 I $D(PSU("ZTSK")) S PSUTZTSK=$G(ZTSK),ZTSK=PSU("ZTSK") D KILL^%ZTLOAD K ZTSK S:$G(PSUTZTSK) ZTSK=PSUTZTSK KILL PSUTZTSK
124END1 ;EP clean out PSU as passed in
125 D:'$D(ZTQUEUED) ^%ZISC
126 S IOP=PSU("IOP1") ; restore original IO parameters
127 D:'$D(ZTQUEUED) ^%ZIS
128 K IOPAR,IOUPAR,IOP
129 KILL PSU,PSURC,PSURP,PSURX,PSUNS,PSUFQ,PSUDTH,PSUIOP,PSUPAR,PSUDTH,PSUERR,PSUI,PSUNSX,PSUQUIT,PSUDBQUE
130 ;
131 Q
132ENDC ;EP - end computing cycle
133 I $G(PSU("RP"))="" G END
134 G END0
135 ;
136 ;----------------
137 ;----------------
138SUB ;>Subroutines
139 ;----------
140NORC ;used if no PSURC identified
141 Q
142 ;
143SETIOPN ;EP Set IOP parameters with (N)o open
144 Q:'$D(PSU("IOP"))
145 S IOP=PSU("IOP")
146 ; PSU*3*5 - IHS/ADC/GTH 10-31-97 start block
147 I $G(PSU("IOPAR"))]"" S %ZIS("IOPAR")=PSU("IOPAR") D
148 . I PSU("IOPAR")'?1"(""".E1""":""".E1""")" Q ; skip HFS if not an HFS
149 . S PSUHFSNM=$P(PSU("IOPAR"),":"),PSUHFSNM=$TR(PSUHFSNM,"()""")
150 . S PSUHFSMD=$P(PSU("IOPAR"),":",2),PSUHFSMD=$TR(PSUHFSMD,"()""")
151 . S %ZIS("HFSNAME")=PSUHFSNM,%ZIS("HFSMODE")=PSUHFSMD
152 . Q
153 ; PSU*3*5 - IHS/ADC/GTH 10-31-97 end block
154 S %ZIS="N"
155 S %H=299
156 D ^%ZIS
157 Q
158PGMNOTE ;
159 ;----------------------
160 ;NOTES FOR PROGRAMMERS|
161 ;----------------------
162 ; VARIABLES NEEDED FROM CALLING PROGRAM
163 ;
164 ;MANDATORY
165 ; Either PSURC=Compute Routine or PSURP=Print Routine.
166 ;
167 ;OPTIONAL
168 ; PSURC= [label]^routine for code that will collect/compute data
169 ; PSURP= [label]^routine for code that will perform output
170 ; PSURX= [label]^routine for exit processing (clean up variables, etc.) HIGHLY RECOMMENDED.
171 ; PSUNS= namespace(s) of variables to be auto-loaded into ZTSAVE("namespace*")=""
172 ; ="DG;AUPN;PS;..." ; (will add '*'if missing).
173 ; or="DG,AUPN,PS,..." ; (may be semi-colon or comma delimited)
174 ; PSUNS("xxx")="" - ZTSAVE variable arrays where xxx is as described for ZTSAVE("xxxx")="".
175 ; PSUFQ= 1 Force Queueing, =0 Prompt for Queueing
176 ; PSUDTH= Tasking date.time in FM format.
177 ; PSUIOP= pre-selected print device constructed with ION ; IOST ; IOSL ; IOM
178 ; (mandatory if the calling routine is a queued routine).
179 ; PSUPAR= %ZIS("IOPAR") values for host file with PSUIOP if needed.
180 ;
181 ;ACTIONS
182 ; %ZIS with "PQM" is called by PSUDBQUE if '$D(PSUIOP).
183 ;
184 ; The user will be asked to queue if queuing has not been
185 ; selected.
186 ;
187 ; IO variables for printing as necessary are automatically stored.
188 ;
189 ; PSUxx input variables are killed after loading into a PSU array.
190 ;
191 ; PSUDBQUE can be nested.
192 ;
193 ; The compute and print phases can call PSUDBQUE individually
194 ; (PSUIOP is required).
195 ;
196 ; The appropriate %ZTSK node is killed.
197 ;
198 ;EX:
199 ; S PSURC="C^AGTEST",PSURP="P^AGTEST",PSURX="END^AGTEST",PSUNS="AG"
200 ; D ^PSUDBQUE ;handles foreground and tasking
201 ; Q
Note: See TracBrowser for help on using the repository browser.