202 lines
7.7 KiB
Mathematica
202 lines
7.7 KiB
Mathematica
PSUDBQUE ; IHS/ADC/GTH - DOUBLE QUEUING SHELL HANDLER; 04 NOV 1997
|
|
;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
|
|
; XB*3*5 - IHS/ADC/GTH 10-31-97
|
|
; Thanks to Paul Wesley, DSD, for the original routine.
|
|
; ---------------------------------------------------------
|
|
; Programmer documentation included at end of routine - PGMNOTE
|
|
; ---------------------------------------------------------
|
|
;
|
|
START ;
|
|
EN ;PEP for double queuing
|
|
NEW PSU ; use a fresh array in case of nesting double queues
|
|
; insure IO array is set fully
|
|
I ($D(IO)'>10) S IOP="HOME" D ^%ZIS
|
|
I $D(ZTQUEUED) S PSUFQ=1 S:'$D(PSUDTH) PSUDTH="NOW" ; insure auto-requeue if called from a queued
|
|
I '$D(PSURC),'$D(PSURP) Q ; insure one of RC or RP exist
|
|
I $D(PSUTITLE) S PSU("TITLE")=PSUTITLE K PSUTITLE
|
|
I IO="" S ION="NULL",(IOST,IOM,IOSL)=0
|
|
S PSU("IOP1")=ION_";"_IOST_";"_IOM_";"_IOSL ; store current IO params
|
|
I $G(IOPAR)]"" S PSU("IOPAR")=IOPAR ; store IOPAR
|
|
I $L($G(PSURC))=0 S PSURC="NORC^PSUDBQUE" ; no compute identified
|
|
S PSU("RC")=PSURC,PSU("RP")=$G(PSURP),PSU("RX")=$G(PSURX)
|
|
; load PSUNS="xx;yy;.." into PSU("NS",xx*) ...
|
|
S PSUNS=$TR("PSUNS",",",";") ; allow "," seperator
|
|
F PSUI=1:1 S PSUNSX=$P($G(PSUNS),";",PSUI) Q:PSUNSX="" S:(PSUNSX'["*") PSUNSX=PSUNSX_"*" S PSU("NS",PSUNSX)=""
|
|
S PSU("NS","PSU*")=""
|
|
; load PSUNS("xxx") array into PSU("NS","xxx")
|
|
S PSUNSX=""
|
|
F S PSUNSX=$O(PSUNS(PSUNSX)) Q:PSUNSX="" S PSU("NS",PSUNSX)=""
|
|
; if this is a double queue with PSU("IOP") setup .. pull the parameters out
|
|
; of a ^%ZIS call to set up the parameters without an open
|
|
S PSU("IOP")=$G(PSUIOP)
|
|
I $D(PSUIOP) S IOP=PSUIOP
|
|
; PSU*3*5 - IHS/ADC/GTH 10-31-97 start block
|
|
I $G(PSU("IOPAR"))]"" S %ZIS("IOPAR")=PSU("IOPAR") D
|
|
. I PSU("IOPAR")'?1"(""".E1""":""".E1""")" Q ; skip HFS if not an HFS
|
|
. S PSUHFSNM=$P(PSU("IOPAR"),":"),PSUHFSNM=$TR(PSUHFSNM,"()""")
|
|
. S PSUHFSMD=$P(PSU("IOPAR"),":",2),PSUHFSMD=$TR(PSUHFSMD,"()""")
|
|
. S %ZIS("HFSNAME")=PSUHFSNM,%ZIS("HFSMODE")=PSUHFSMD
|
|
. ;this code drops through
|
|
; PSU*3*5 - IHS/ADC/GTH 10-31-97 end block
|
|
ZIS ;
|
|
KILL IO("Q")
|
|
I $G(PSURC)]"",$G(PSURP)="" G ZISQ
|
|
S %ZIS="PQM"
|
|
D ^%ZIS ; get parameters without an open
|
|
I POP W !,"REPORTING-ABORTED",*7 G END1
|
|
S PSU("IO")=IO,PSU("IOP")=ION_";"_IOST_";"_IOM_";"_IOSL,PSU("IOPAR")=$G(IOPAR),PSU("CPU")=$G(IOCPU),PSU("ION")=ION
|
|
ZISQ ;
|
|
I '$D(IO("Q")),'$G(PSUFQ) D
|
|
. I $D(ZTQUEUED) S PSUFQ=1 Q
|
|
. I IO=IO(0),$G(PSURP)]"" Q
|
|
. KILL DIR
|
|
. S DIR(0)="Y",DIR("B")="Y",DIR("A")="Won't you queue this "
|
|
. D ^DIR
|
|
. KILL DIR
|
|
. I X["^" S PSUQUIT=1
|
|
. S:Y=1 IO("Q")=1
|
|
. Q
|
|
;
|
|
KILL PSU("ZTSK")
|
|
I $D(ZTQUEUED),$G(ZTSK) S PSU("ZTSK")=ZTSK
|
|
KILL ZTSK
|
|
; quit if user says so
|
|
I $G(PSUQUIT) KILL DIR S DIR(0)="E",DIR("A")="Report Aborted .. <CR> to continue" D ^DIR KILL DIR G END1
|
|
;
|
|
QUE1 ;
|
|
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 ;--->
|
|
. ;I '$D(ZTQUEUED),IO=IO(0),$G(PSURP)]"" W !,"Queing to slave printer not allowed ... Report Aborting" Q ;---^
|
|
. I $D(PSU("TITLE")) S ZTDESC=PSU("TITLE")_" compute"
|
|
. E S ZTDESC="Double Que COMPUTing "_PSURC_" "_$G(PSURP)
|
|
. S ZTIO="",ZTRTN="DEQUE1^PSUDBQUE"
|
|
. S:$D(PSUDTH) ZTDTH=PSUDTH
|
|
. S:$G(PSU("CPU"))]"" ZTCPU=PSU("CPU")
|
|
. S PSUNSX=""
|
|
. F S PSUNSX=$O(PSU("NS",PSUNSX)) Q:PSUNSX="" S ZTSAVE(PSUNSX)=""
|
|
. KILL PSURC,PSURP,PSURX,PSUNS,PSUFQ,PSUDTH,PSUIOP,PSUPAR,PSUDTH,PSUNSX,PSUI
|
|
. S ZTIO="" ; insure no device loaded
|
|
. D ^%ZTLOAD
|
|
. Q ; these do .s branch to END1
|
|
; (((if queued the above code branched to END)))
|
|
;
|
|
DEQUE1 ;> 1st deque
|
|
;
|
|
KILL PSURC,PSURP,PSURX,PSUNS,PSUFQ,PSUDTH,PSUIOP,PSUPAR,PSUDTH
|
|
KILL PSU("ZTSK")
|
|
I $D(ZTQUEUED),$G(ZTSK) S PSU("ZTSK")=ZTSK
|
|
;
|
|
COMPUTE ;>do computing | routine
|
|
;
|
|
D @(PSU("RC")) ; >>>PERFORM THE COMPUTE ROUTINE<<< ;stuffed if not provided with NORC^PSUDBQUE
|
|
;
|
|
QUE2 ;
|
|
;
|
|
I $D(ZTQUEUED) D G ENDC ;===> automatically requeue if queued
|
|
. Q:PSU("RP")=""
|
|
. I $D(PSU("TITLE")) S ZTDESC=PSU("TITLE")_" print"
|
|
. E S ZTDESC="Double Que PRINT "_PSU("RC")_" "_PSU("RP")
|
|
. S ZTIO=PSU("IO"),ZTDTH=$H,ZTRTN="DEQUE2^PSUDBQUE"
|
|
. S PSUNSX=""
|
|
. F S PSUNSX=$O(PSU("NS",PSUNSX)) Q:PSUNSX="" S ZTSAVE(PSUNSX)=""
|
|
. D SETIOPN K ZTIO
|
|
. D ^%ZTLOAD
|
|
. I '$D(ZTSK) S PSUERR="SECOND QUE FAILED" D @^%ZOSF("ERRTN") Q
|
|
. S PSUDBQUE=1
|
|
. Q ; ======> this branches to ENDC
|
|
;
|
|
; device opened from the first que ask
|
|
DEQUE2 ;>EP 2nd Deque | printing
|
|
KILL PSU("ZTSK")
|
|
I $D(ZTQUEUED),$G(ZTSK) S PSU("ZTSK")=ZTSK
|
|
;open printer device for printing with all selected parameters
|
|
G:(PSU("RP")="") END ;---> exit if no print
|
|
;
|
|
U IO
|
|
D @(PSU("RP")) ; >>>PERFORM PRINTING ROUTINE
|
|
;
|
|
;--------
|
|
END ;>End | cleanup
|
|
;
|
|
I $G(PSU("RX"))'="" D @(PSU("RX")) ; >>>PERFORM CLEANUP ROUTINE<<<
|
|
;
|
|
END0 ;EP - from compute cycle when PSU("RP") EXISTS
|
|
I $D(PSU("ZTSK")) S PSUTZTSK=$G(ZTSK),ZTSK=PSU("ZTSK") D KILL^%ZTLOAD K ZTSK S:$G(PSUTZTSK) ZTSK=PSUTZTSK KILL PSUTZTSK
|
|
END1 ;EP clean out PSU as passed in
|
|
D:'$D(ZTQUEUED) ^%ZISC
|
|
S IOP=PSU("IOP1") ; restore original IO parameters
|
|
D:'$D(ZTQUEUED) ^%ZIS
|
|
K IOPAR,IOUPAR,IOP
|
|
KILL PSU,PSURC,PSURP,PSURX,PSUNS,PSUFQ,PSUDTH,PSUIOP,PSUPAR,PSUDTH,PSUERR,PSUI,PSUNSX,PSUQUIT,PSUDBQUE
|
|
;
|
|
Q
|
|
ENDC ;EP - end computing cycle
|
|
I $G(PSU("RP"))="" G END
|
|
G END0
|
|
;
|
|
;----------------
|
|
;----------------
|
|
SUB ;>Subroutines
|
|
;----------
|
|
NORC ;used if no PSURC identified
|
|
Q
|
|
;
|
|
SETIOPN ;EP Set IOP parameters with (N)o open
|
|
Q:'$D(PSU("IOP"))
|
|
S IOP=PSU("IOP")
|
|
; PSU*3*5 - IHS/ADC/GTH 10-31-97 start block
|
|
I $G(PSU("IOPAR"))]"" S %ZIS("IOPAR")=PSU("IOPAR") D
|
|
. I PSU("IOPAR")'?1"(""".E1""":""".E1""")" Q ; skip HFS if not an HFS
|
|
. S PSUHFSNM=$P(PSU("IOPAR"),":"),PSUHFSNM=$TR(PSUHFSNM,"()""")
|
|
. S PSUHFSMD=$P(PSU("IOPAR"),":",2),PSUHFSMD=$TR(PSUHFSMD,"()""")
|
|
. S %ZIS("HFSNAME")=PSUHFSNM,%ZIS("HFSMODE")=PSUHFSMD
|
|
. Q
|
|
; PSU*3*5 - IHS/ADC/GTH 10-31-97 end block
|
|
S %ZIS="N"
|
|
S %H=299
|
|
D ^%ZIS
|
|
Q
|
|
PGMNOTE ;
|
|
;----------------------
|
|
;NOTES FOR PROGRAMMERS|
|
|
;----------------------
|
|
; VARIABLES NEEDED FROM CALLING PROGRAM
|
|
;
|
|
;MANDATORY
|
|
; Either PSURC=Compute Routine or PSURP=Print Routine.
|
|
;
|
|
;OPTIONAL
|
|
; PSURC= [label]^routine for code that will collect/compute data
|
|
; PSURP= [label]^routine for code that will perform output
|
|
; PSURX= [label]^routine for exit processing (clean up variables, etc.) HIGHLY RECOMMENDED.
|
|
; PSUNS= namespace(s) of variables to be auto-loaded into ZTSAVE("namespace*")=""
|
|
; ="DG;AUPN;PS;..." ; (will add '*'if missing).
|
|
; or="DG,AUPN,PS,..." ; (may be semi-colon or comma delimited)
|
|
; PSUNS("xxx")="" - ZTSAVE variable arrays where xxx is as described for ZTSAVE("xxxx")="".
|
|
; PSUFQ= 1 Force Queueing, =0 Prompt for Queueing
|
|
; PSUDTH= Tasking date.time in FM format.
|
|
; PSUIOP= pre-selected print device constructed with ION ; IOST ; IOSL ; IOM
|
|
; (mandatory if the calling routine is a queued routine).
|
|
; PSUPAR= %ZIS("IOPAR") values for host file with PSUIOP if needed.
|
|
;
|
|
;ACTIONS
|
|
; %ZIS with "PQM" is called by PSUDBQUE if '$D(PSUIOP).
|
|
;
|
|
; The user will be asked to queue if queuing has not been
|
|
; selected.
|
|
;
|
|
; IO variables for printing as necessary are automatically stored.
|
|
;
|
|
; PSUxx input variables are killed after loading into a PSU array.
|
|
;
|
|
; PSUDBQUE can be nested.
|
|
;
|
|
; The compute and print phases can call PSUDBQUE individually
|
|
; (PSUIOP is required).
|
|
;
|
|
; The appropriate %ZTSK node is killed.
|
|
;
|
|
;EX:
|
|
; S PSURC="C^AGTEST",PSURP="P^AGTEST",PSURX="END^AGTEST",PSUNS="AG"
|
|
; D ^PSUDBQUE ;handles foreground and tasking
|
|
; Q
|