PRPFQ ;ALTOONA/CTB-RSD/ID TKW/BOISE QUE PRINTOUTS ;5/10/02
V ;;3.0;PATIENT FUNDS;**6,10,13**;JUNE 1, 1989
;INPUT REQUIRED STANDARD ZT VARIABLES
;IF PRPFQ("FORCEQ") IS DEFINED ROUTINE WILL FORCE %ZTLOAD TO BE INVOKED
S XION=ION K IOP,ZTSK W:$D(PRPFQ("FORCEQ")) !,"QUEUE TO PRINT ON:" S %ZIS("B")="",%ZIS="NQ" D ^%ZIS I POP W " <No Device Selected>",*7,! S IOP=XION D ^%ZIS K XION R X:2 G EXIT
K XION S (PRIOP,IOP)=ION_";"_IOST_";"_IOM_";"_IOSL I IO=IO(0),'$D(PRPFQ("FORCEQ")) D ^%ZIS D @ZTRTN D CLOSE G EXIT
D DQTIME I '% W " <Nothing Queued>",*7 D CLOSE G EXIT
S (ZTSAVE("DUZ"),ZTSAVE("PRIOP"))="" D ^%ZTLOAD W " <Request Queued>",*7,!
EXIT K %ZIS,I,IOP,K,N,PRIOP,PRPFL,PRPFQ G ZTKILL
CLOSE X ^%ZIS("C") Q
MSG ;;PRINTS MESSAGE CONTAINED IN X. IF IT DOESNT FIT ON ONE LINE, X IS PRINTED ON THE NEXT LINE.
Q:$D(ZTQUEUED)
N X1,X2,ZX Q:'$D(X) I $S('$D(IOM):1,IOM="":1,1:0) W $P(X,"*") W:X["*" *7 R X:2 K X Q
I ($L($P(X,"*"))+4+$X)>IOM W !,?(IOM-($L($P(X,"*"))+4))
W:X["*" *7 F ZX=1:1 D BRK:($L(X)+6)>IOM W " ",$P(X,"*"),! Q:'$D(X1) S X=X1 K X1
Q
BRK N I
S X1=X F I=1:1 Q:$L($P(X," ",1,I))>(IOM-6)!($L(X)<(IOM-6)) S X1=$P(X," ",1,I)
S X2=$P(X," ",I,999),X=X1,X1=X2 K X2 Q
DQTIME S U="^",%=1 K ZTDTH R !,"Enter DATE & TIME to print: NOW// ",X:$S($D(DTIME):DTIME,1:30) I X[U!('$T) S %=0 K X Q
S:X="" X="NOW" S %DT="ER" D ^%DT S %=0 I Y<0 G DQTIME
S X=Y D H^%DTC S Y=Y_"000",ZTDTH=%H_","_($E(Y,9,10)*60+$E(Y,11,12)*60),%=1
K %DT,%H,%Y,X,Y Q
DRNG ;SELECT RANGE OF DATES
K %DT W ! S %DT="EAT",%DT("A")="Enter Beginning Date: " D ^%DT I Y<0 K %H,%I,%DT,TO,FR,X,Y S %=0 Q
S FR=+Y S %DT("A")=" Enter Ending Date: " D ^%DT I X["^" K %DT,%H,%I,FR,Y S %=0 Q
I Y<0 W "??",!,*7 K %DT,FR G DRNG
S TO=+Y I TO<FR W !,*7,"Illogical range of dates. Try again.",! G DRNG
S %=1 K %DT,%H,%I Q
RNG ; ALLOW ENTRY OF BEGINNING AND ENDING RANGE
S %=0,FR="",TO="z" S:'$D(DTIME) DTIME=120 W !!,"Start with "_M_": FIRST// " R FR:DTIME S:$T=0 FR="^" G:FR["^" RQ I FR["?",'$D(PRPFD) G RQ
S:FR="" FR="@" I FR'["@" I $D(PRPFD) S %DT="ET",X=FR D ^%DT G:Y<0 RNG S FR=Y
TO W !,"Go to "_M_": LAST// " R TO:DTIME S:$T=0 TO="^" G:TO["^" RQ G:TO["?"&('$D(PRPFD)) RNG S:TO="" TO="z" I TO="z" G RQ1
I TO'["@" I $D(PRPFD) S X=TO D ^%DT G:Y<0 TO S TO=Y
I (FR["@")!(TO["@") S %=1 Q
I (+FR=FR)&(+TO=TO) I FR>TO W *7,!,"INVALID RANGE" G RNG
I (+FR'=FR)!(+TO'=TO) I FR]TO W *7,!,"INVALID RANGE" G RNG
Q
RQ S %=0 K FR,TO,%DT,X,Y Q
RQ1 S %=1 K %DT,M,PRPFD,X,Y Q
PAUSE ; MAKES TERMINAL PAUSE WHEN DISPLAYING DATA ONLINE
Q:$E($G(IOST),1,2)'="C-"
W !!," ^ TO QUIT" R X:DTIME S:$T=0 X="^" S J=0
Q
ENCON I $E($G(IOST),1,2)="C-" W !," ** Press RETURN to Continue **" R X:DTIME K X
QUIT
DIKILL ; KILL STANDARD FILE MANAGER VARIABLES
K %,%DT,%X,%Y,BY,D,DA,DCC,DIC,DIE,DIJ,DIOEND,DIPT,DP,DR,D0,D1,D2,DQ,DHD,DLAYGO,F,FLDS,FR,I,IOX,IOY,J,K,L,O,P,POP,W,X,Y,Z,ZTSK Q
DIWKILL ; KILL FILE MANAGER WORD PROCESSING VARIABLES
K DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DWLW,X1 Q
ZTKILL ; KILL VARIABLES USED BY UNIVERSAL TASK MANAGER
K %ZIS,POP,ZTRTN,ZTUCI,ZTDTH,ZTSAVE,ZTDESC,ZTIO,ZTSK,ZTSKT,ZTDHD,ZTREQ Q
LOCK ;LOCK GLOBAL THAT IS BEING ACCESSED BY ANOTHER USER
L @(DIC_DA_"):30") S PRPFL=$T Q:PRPFL W !!,$C(7),"THIS ENTRY IS BEING EDITED BY ANOTHER USER. TRY LATER." Q
D ;CONVERTS FILEMAN INTERNAL DATE TO EXTERNAL FORMAT
S:Y Y=$S($E(Y,4,5):$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$E(Y,4,5))_" ",1:"")_$S($E(Y,6,7):+$E(Y,6,7)_",",1:"")_($E(Y,1,3)+1700)_$P("@"_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),"^",Y[".")
Q
CNVD ; CONVERTS DATE FROM INTERNAL (YYYMMDD) STORAGE FORMAT TO MM/DD/YY
S X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) Q
NOW S %H=$H
; PRPF*3*10 - Changed (Y2K issue) to call %DTC
D YX^%DTC S %X=Y
Q
SELRNG S PRPFRNG=""
S DIR(0)="SA^A:ALL;S:SINGLE",DIR("A")="Single Station List or All Station List: ",DIR("B")="ALL"
S DIR("?")="You may enter (A)LL or (S)ingle",DIR("?",1)="Selecting SINGLE will run this report for one Station only."
D ^DIR K DIR I $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) Q
A S PRPFRNG=""
S:Y="A" PRPFRNG="@"
I Y="S" S DIC(0)="AEQMZ",DIC=4 W !! D ^DIC K DIC I $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) Q
I PRPFRNG="" I $$GET1^DIQ(4,$P(Y,U),99)="" W !!,"You cannot select a STATION that does not have a STATION NUMBER assigned to it!" S Y="S" D A Q
S:PRPFRNG'="@" PRPFRNG=$$GET1^DIQ(4,$P(Y,U),99)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRPFQ 4392 printed Apr 09, 2024@21:04:48 Page 2
PRPFQ ;ALTOONA/CTB-RSD/ID TKW/BOISE QUE PRINTOUTS ;5/10/02
V ;;3.0;PATIENT FUNDS;**6,10,13**;JUNE 1, 1989
+1 ;INPUT REQUIRED STANDARD ZT VARIABLES
+2 ;IF PRPFQ("FORCEQ") IS DEFINED ROUTINE WILL FORCE %ZTLOAD TO BE INVOKED
+3 SET XION=ION
KILL IOP,ZTSK
if $DATA(PRPFQ("FORCEQ"))
WRITE !,"QUEUE TO PRINT ON:"
SET %ZIS("B")=""
SET %ZIS="NQ"
DO ^%ZIS
IF POP
WRITE " <No Device Selected>",*7,!
SET IOP=XION
DO ^%ZIS
KILL XION
READ X:2
GOTO EXIT
+4 KILL XION
SET (PRIOP,IOP)=ION_";"_IOST_";"_IOM_";"_IOSL
IF IO=IO(0)
IF '$DATA(PRPFQ("FORCEQ"))
DO ^%ZIS
DO @ZTRTN
DO CLOSE
GOTO EXIT
+5 DO DQTIME
IF '%
WRITE " <Nothing Queued>",*7
DO CLOSE
GOTO EXIT
+6 SET (ZTSAVE("DUZ"),ZTSAVE("PRIOP"))=""
DO ^%ZTLOAD
WRITE " <Request Queued>",*7,!
EXIT KILL %ZIS,I,IOP,K,N,PRIOP,PRPFL,PRPFQ
GOTO ZTKILL
CLOSE XECUTE ^%ZIS("C")
QUIT
MSG ;;PRINTS MESSAGE CONTAINED IN X. IF IT DOESNT FIT ON ONE LINE, X IS PRINTED ON THE NEXT LINE.
+1 if $DATA(ZTQUEUED)
QUIT
+2 NEW X1,X2,ZX
if '$DATA(X)
QUIT
IF $SELECT('$DATA(IOM):1,IOM="":1,1:0)
WRITE $PIECE(X,"*")
if X["*"
WRITE *7
READ X:2
KILL X
QUIT
+3 IF ($LENGTH($PIECE(X,"*"))+4+$X)>IOM
WRITE !,?(IOM-($LENGTH($PIECE(X,"*"))+4))
+4 if X["*"
WRITE *7
FOR ZX=1:1
if ($LENGTH(X)+6)>IOM
DO BRK
WRITE " ",$PIECE(X,"*"),!
if '$DATA(X1)
QUIT
SET X=X1
KILL X1
+5 QUIT
BRK NEW I
+1 SET X1=X
FOR I=1:1
if $LENGTH($PIECE(X," ",1,I))>(IOM-6)!($LENGTH(X)<(IOM-6))
QUIT
SET X1=$PIECE(X," ",1,I)
+2 SET X2=$PIECE(X," ",I,999)
SET X=X1
SET X1=X2
KILL X2
QUIT
DQTIME SET U="^"
SET %=1
KILL ZTDTH
READ !,"Enter DATE & TIME to print: NOW// ",X:$SELECT($DATA(DTIME):DTIME,1:30)
IF X[U!('$TEST)
SET %=0
KILL X
QUIT
+1 if X=""
SET X="NOW"
SET %DT="ER"
DO ^%DT
SET %=0
IF Y<0
GOTO DQTIME
+2 SET X=Y
DO H^%DTC
SET Y=Y_"000"
SET ZTDTH=%H_","_($EXTRACT(Y,9,10)*60+$EXTRACT(Y,11,12)*60)
SET %=1
+3 KILL %DT,%H,%Y,X,Y
QUIT
DRNG ;SELECT RANGE OF DATES
+1 KILL %DT
WRITE !
SET %DT="EAT"
SET %DT("A")="Enter Beginning Date: "
DO ^%DT
IF Y<0
KILL %H,%I,%DT,TO,FR,X,Y
SET %=0
QUIT
+2 SET FR=+Y
SET %DT("A")=" Enter Ending Date: "
DO ^%DT
IF X["^"
KILL %DT,%H,%I,FR,Y
SET %=0
QUIT
+3 IF Y<0
WRITE "??",!,*7
KILL %DT,FR
GOTO DRNG
+4 SET TO=+Y
IF TO<FR
WRITE !,*7,"Illogical range of dates. Try again.",!
GOTO DRNG
+5 SET %=1
KILL %DT,%H,%I
QUIT
RNG ; ALLOW ENTRY OF BEGINNING AND ENDING RANGE
+1 SET %=0
SET FR=""
SET TO="z"
if '$DATA(DTIME)
SET DTIME=120
WRITE !!,"Start with "_M_": FIRST// "
READ FR:DTIME
if $TEST=0
SET FR="^"
if FR["^"
GOTO RQ
IF FR["?"
IF '$DATA(PRPFD)
GOTO RQ
+2 if FR=""
SET FR="@"
IF FR'["@"
IF $DATA(PRPFD)
SET %DT="ET"
SET X=FR
DO ^%DT
if Y<0
GOTO RNG
SET FR=Y
TO WRITE !,"Go to "_M_": LAST// "
READ TO:DTIME
if $TEST=0
SET TO="^"
if TO["^"
GOTO RQ
if TO["?"&('$DATA(PRPFD))
GOTO RNG
if TO=""
SET TO="z"
IF TO="z"
GOTO RQ1
+1 IF TO'["@"
IF $DATA(PRPFD)
SET X=TO
DO ^%DT
if Y<0
GOTO TO
SET TO=Y
+2 IF (FR["@")!(TO["@")
SET %=1
QUIT
+3 IF (+FR=FR)&(+TO=TO)
IF FR>TO
WRITE *7,!,"INVALID RANGE"
GOTO RNG
+4 IF (+FR'=FR)!(+TO'=TO)
IF FR]TO
WRITE *7,!,"INVALID RANGE"
GOTO RNG
+5 QUIT
RQ SET %=0
KILL FR,TO,%DT,X,Y
QUIT
RQ1 SET %=1
KILL %DT,M,PRPFD,X,Y
QUIT
PAUSE ; MAKES TERMINAL PAUSE WHEN DISPLAYING DATA ONLINE
+1 if $EXTRACT($GET(IOST),1,2)'="C-"
QUIT
+2 WRITE !!," ^ TO QUIT"
READ X:DTIME
if $TEST=0
SET X="^"
SET J=0
+3 QUIT
ENCON IF $EXTRACT($GET(IOST),1,2)="C-"
WRITE !," ** Press RETURN to Continue **"
READ X:DTIME
KILL X
+1 QUIT
DIKILL ; KILL STANDARD FILE MANAGER VARIABLES
+1 KILL %,%DT,%X,%Y,BY,D,DA,DCC,DIC,DIE,DIJ,DIOEND,DIPT,DP,DR,D0,D1,D2,DQ,DHD,DLAYGO,F,FLDS,FR,I,IOX,IOY,J,K,L,O,P,POP,W,X,Y,Z,ZTSK
QUIT
DIWKILL ; KILL FILE MANAGER WORD PROCESSING VARIABLES
+1 KILL DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DWLW,X1
QUIT
ZTKILL ; KILL VARIABLES USED BY UNIVERSAL TASK MANAGER
+1 KILL %ZIS,POP,ZTRTN,ZTUCI,ZTDTH,ZTSAVE,ZTDESC,ZTIO,ZTSK,ZTSKT,ZTDHD,ZTREQ
QUIT
LOCK ;LOCK GLOBAL THAT IS BEING ACCESSED BY ANOTHER USER
+1 LOCK @(DIC_DA_"):30")
SET PRPFL=$TEST
if PRPFL
QUIT
WRITE !!,$CHAR(7),"THIS ENTRY IS BEING EDITED BY ANOTHER USER. TRY LATER."
QUIT
D ;CONVERTS FILEMAN INTERNAL DATE TO EXTERNAL FORMAT
+1 if Y
SET Y=$SELECT($EXTRACT(Y,4,5):$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$EXTRACT(Y,4,5))_" ",1:"")_$SELECT($EXTRACT(Y,6,7):+$EXTRACT(Y,6,7)_",",1:"")_($EXTRACT(Y,1,3)+1700)_$PIECE("@"_$EXTRACT(Y_0,9,10)_":"_...
... $EXTRACT(Y_"000",11,12),"^",Y[".")
+2 QUIT
CNVD ; CONVERTS DATE FROM INTERNAL (YYYMMDD) STORAGE FORMAT TO MM/DD/YY
+1 SET X=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
QUIT
NOW SET %H=$HOROLOG
+1 ; PRPF*3*10 - Changed (Y2K issue) to call %DTC
+2 DO YX^%DTC
SET %X=Y
+3 QUIT
SELRNG SET PRPFRNG=""
+1 SET DIR(0)="SA^A:ALL;S:SINGLE"
SET DIR("A")="Single Station List or All Station List: "
SET DIR("B")="ALL"
+2 SET DIR("?")="You may enter (A)LL or (S)ingle"
SET DIR("?",1)="Selecting SINGLE will run this report for one Station only."
+3 DO ^DIR
KILL DIR
IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))
QUIT
A SET PRPFRNG=""
+1 if Y="A"
SET PRPFRNG="@"
+2 IF Y="S"
SET DIC(0)="AEQMZ"
SET DIC=4
WRITE !!
DO ^DIC
KILL DIC
IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))
QUIT
+3 IF PRPFRNG=""
IF $$GET1^DIQ(4,$PIECE(Y,U),99)=""
WRITE !!,"You cannot select a STATION that does not have a STATION NUMBER assigned to it!"
SET Y="S"
DO A
QUIT
+4 if PRPFRNG'="@"
SET PRPFRNG=$$GET1^DIQ(4,$PIECE(Y,U),99)
+5 QUIT
