| [613] | 1 | PSUDBQUE ; 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 | ;
|
|---|
| 9 | START ;
|
|---|
| 10 | EN ;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
|
|---|
| 41 | ZIS ;
|
|---|
| 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
|
|---|
| 48 | ZISQ ;
|
|---|
| 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 | ;
|
|---|
| 66 | QUE1 ;
|
|---|
| 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 | ;
|
|---|
| 82 | DEQUE1 ;> 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 | ;
|
|---|
| 88 | COMPUTE ;>do computing | routine
|
|---|
| 89 | ;
|
|---|
| 90 | D @(PSU("RC")) ; >>>PERFORM THE COMPUTE ROUTINE<<< ;stuffed if not provided with NORC^PSUDBQUE
|
|---|
| 91 | ;
|
|---|
| 92 | QUE2 ;
|
|---|
| 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
|
|---|
| 108 | DEQUE2 ;>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 | ;--------
|
|---|
| 118 | END ;>End | cleanup
|
|---|
| 119 | ;
|
|---|
| 120 | I $G(PSU("RX"))'="" D @(PSU("RX")) ; >>>PERFORM CLEANUP ROUTINE<<<
|
|---|
| 121 | ;
|
|---|
| 122 | END0 ;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
|
|---|
| 124 | END1 ;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
|
|---|
| 132 | ENDC ;EP - end computing cycle
|
|---|
| 133 | I $G(PSU("RP"))="" G END
|
|---|
| 134 | G END0
|
|---|
| 135 | ;
|
|---|
| 136 | ;----------------
|
|---|
| 137 | ;----------------
|
|---|
| 138 | SUB ;>Subroutines
|
|---|
| 139 | ;----------
|
|---|
| 140 | NORC ;used if no PSURC identified
|
|---|
| 141 | Q
|
|---|
| 142 | ;
|
|---|
| 143 | SETIOPN ;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
|
|---|
| 158 | PGMNOTE ;
|
|---|
| 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
|
|---|
