- 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 Jan 18, 2025@03:03:08 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