PRPFU ;ALTOONA/CTB FATIENT FUNDS UTILITY PROGRAM ;11/27/96 3:42 PM
V ;;3.0;PATIENT FUNDS;**6**;JUNE 1,1989
UPDATE ;
W IORC D POS(XPOS+(PERCENT\2),YPOS) W CURSOR
QUIT
POS(DX,DY) I $E(IOST)'="C" W ! QUIT
I DX=""!(DY="") QUIT
X IOXY
QUIT
PERCENT ;
I $D(XPDIDTOT),'$D(PRPFPASS) D UPDATE^XPDID(XCOUNT) QUIT
S:'$D(ITEMS) ITEMS="items"
S PERCENT=XCOUNT/TREC*100\1 I PERCENT>99.99999 S PERCENT=100
I $E(IOST)="C" D UPDATE
D
. W !!!,$FN($S(PERCENT=100:TREC,XCOUNT<0:0,1:XCOUNT),",")," of ",$FN(TREC,",")," ",ITEMS," processed. ",PERCENT,"% complete "
. S TIME=$P($H,",",2)
. S:BTIME>TIME TIME=TIME+86400
. S TIME=TIME-BTIME
. S TTIME=TIME/$S((PERCENT>0):(PERCENT*.01),1:.01),RTIME=TTIME-TIME
. D TIME(TTIME,"required")
. D TIME(TIME,"elapsed")
. D TIME($P(RTIME,"."),"remaining")
. I $E(IOST)'="C" QUIT
. QUIT
QUIT
S(X) Q $S(X'=1:"s",1:"")
TIME(X,Y) ;
NEW HOURS,MIN,SEC
S HOURS=0,MIN=0,SEC=0
I X>3600 S HOURS=X\3600,X=X#3600
S MIN=X\60,SEC=$P(X#60,".")
I $E(IOST,1,2)="C-" W !
W:HOURS HOURS," Hour"_$$S(HOURS)_", "
W:MIN MIN_" Minute"_$$S(MIN)_", "
W SEC_" Second"_$$S(SEC)_" "_Y_". "
Q
BEGIN ;
I $D(XPDNM),'$D(PRPFPASS) S XPDIDTOT=TREC,LREC=$S($E(IOST)="C":TREC\200+1,1:TREC\20+1),DA=0,XCOUNT=-1 D BMES^XPDUTL(MESSAGE) QUIT
W:$G(IOF)'="" @IOF
I $E(IOST)="C",'$D(ZTQUEUED) S X="IORVON;IORVOFF;IORC;IOSC" D ENDR^%ZISS
I $D(IORVON),$D(IORVOFF) S CURSOR=IORVON_" "_IORVOFF
S LREC=$S($E(IOST)="C":TREC\200+1,1:TREC\20+1)
W !! S X=MESSAGE D MSG
S LINE=" |-------------------------+-------------------------|"
I $E(IOST)="C" W !,?25,"P E R C E N T C O M P L E T E",!!?18," 50 100",!,LINE,!?14,"|",?66,"|",!,LINE,!
S DA=0,LASTENT=0,XPOS=15,YPOS=$Y-2,BTIME=$P($H,",",2),XCOUNT=-1
D POS(XPOS,YPOS) W:$E(IOST)="C" IOSC
QUIT
END ;
I $G(XPDNM)]"",'$D(PRPFPASS) K XPDIDTOT QUIT
K X S $P(X," ",40)=""
W !,"100% complete."_X,!
D KILL^%ZISS
CLOSE ;CLOSE ALL OPEN DEVICES OTHER THAN THE HOME DEVICE
N N
S N=0 F S N=$O(IO(1,N)) Q:'N I N'=IO(0) S IO=N D ^%ZISC
QUIT
MSG ;;PRINTS MESSAGE CONTAINED IN X. IF IT DOESNT FIT ON ONE LINE, X IS PRINTED ON THE NEXT LINE.
N X1,X2,ZX Q:'$D(X) I $S('$D(IOM):1,IOM="":1,1:0) W $P(X,"*") R X:2 K X Q
I ($L($P(X,"*"))+4+$X)>IOM W !,?(IOM-($L($P(X,"*"))+4))
F ZX=1:1 D BRK:($L(X)+6)>IOM W " ",$P(X,"*"),! Q:'$D(X1) S X=X1 K X1
W:X["*" *7
QUIT
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
QUIT
DIR() ;SET VARIABLE STRING RETURNING FROM DIR
NEW X
S X=$D(DTOUT)_$D(DUOUT)_$D(DIRUT)_$D(DIROUT)
K DTOUT,DUOUT,DIRUT,DIROUT
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRPFU 2723 printed Dec 13, 2024@02:02:05 Page 2
PRPFU ;ALTOONA/CTB FATIENT FUNDS UTILITY PROGRAM ;11/27/96 3:42 PM
V ;;3.0;PATIENT FUNDS;**6**;JUNE 1,1989
UPDATE ;
+1 WRITE IORC
DO POS(XPOS+(PERCENT\2),YPOS)
WRITE CURSOR
+2 QUIT
POS(DX,DY) IF $EXTRACT(IOST)'="C"
WRITE !
QUIT
+1 IF DX=""!(DY="")
QUIT
+2 XECUTE IOXY
+3 QUIT
PERCENT ;
+1 IF $DATA(XPDIDTOT)
IF '$DATA(PRPFPASS)
DO UPDATE^XPDID(XCOUNT)
QUIT
+2 if '$DATA(ITEMS)
SET ITEMS="items"
+3 SET PERCENT=XCOUNT/TREC*100\1
IF PERCENT>99.99999
SET PERCENT=100
+4 IF $EXTRACT(IOST)="C"
DO UPDATE
+5 Begin DoDot:1
+6 WRITE !!!,$FNUMBER($SELECT(PERCENT=100:TREC,XCOUNT<0:0,1:XCOUNT),",")," of ",$FNUMBER(TREC,",")," ",ITEMS," processed. ",PERCENT,"% complete "
+7 SET TIME=$PIECE($HOROLOG,",",2)
+8 if BTIME>TIME
SET TIME=TIME+86400
+9 SET TIME=TIME-BTIME
+10 SET TTIME=TIME/$SELECT((PERCENT>0):(PERCENT*.01),1:.01)
SET RTIME=TTIME-TIME
+11 DO TIME(TTIME,"required")
+12 DO TIME(TIME,"elapsed")
+13 DO TIME($PIECE(RTIME,"."),"remaining")
+14 IF $EXTRACT(IOST)'="C"
QUIT
+15 QUIT
End DoDot:1
+16 QUIT
S(X) QUIT $SELECT(X'=1:"s",1:"")
TIME(X,Y) ;
+1 NEW HOURS,MIN,SEC
+2 SET HOURS=0
SET MIN=0
SET SEC=0
+3 IF X>3600
SET HOURS=X\3600
SET X=X#3600
+4 SET MIN=X\60
SET SEC=$PIECE(X#60,".")
+5 IF $EXTRACT(IOST,1,2)="C-"
WRITE !
+6 if HOURS
WRITE HOURS," Hour"_$$S(HOURS)_", "
+7 if MIN
WRITE MIN_" Minute"_$$S(MIN)_", "
+8 WRITE SEC_" Second"_$$S(SEC)_" "_Y_". "
+9 QUIT
BEGIN ;
+1 IF $DATA(XPDNM)
IF '$DATA(PRPFPASS)
SET XPDIDTOT=TREC
SET LREC=$SELECT($EXTRACT(IOST)="C":TREC\200+1,1:TREC\20+1)
SET DA=0
SET XCOUNT=-1
DO BMES^XPDUTL(MESSAGE)
QUIT
+2 if $GET(IOF)'=""
WRITE @IOF
+3 IF $EXTRACT(IOST)="C"
IF '$DATA(ZTQUEUED)
SET X="IORVON;IORVOFF;IORC;IOSC"
DO ENDR^%ZISS
+4 IF $DATA(IORVON)
IF $DATA(IORVOFF)
SET CURSOR=IORVON_" "_IORVOFF
+5 SET LREC=$SELECT($EXTRACT(IOST)="C":TREC\200+1,1:TREC\20+1)
+6 WRITE !!
SET X=MESSAGE
DO MSG
+7 SET LINE=" |-------------------------+-------------------------|"
+8 IF $EXTRACT(IOST)="C"
WRITE !,?25,"P E R C E N T C O M P L E T E",!!?18," 50 100",!,LINE,!?14,"|",?66,"|",!,LINE,!
+9 SET DA=0
SET LASTENT=0
SET XPOS=15
SET YPOS=$Y-2
SET BTIME=$PIECE($HOROLOG,",",2)
SET XCOUNT=-1
+10 DO POS(XPOS,YPOS)
if $EXTRACT(IOST)="C"
WRITE IOSC
+11 QUIT
END ;
+1 IF $GET(XPDNM)]""
IF '$DATA(PRPFPASS)
KILL XPDIDTOT
QUIT
+2 KILL X
SET $PIECE(X," ",40)=""
+3 WRITE !,"100% complete."_X,!
+4 DO KILL^%ZISS
CLOSE ;CLOSE ALL OPEN DEVICES OTHER THAN THE HOME DEVICE
+1 NEW N
+2 SET N=0
FOR
SET N=$ORDER(IO(1,N))
if 'N
QUIT
IF N'=IO(0)
SET IO=N
DO ^%ZISC
+3 QUIT
MSG ;;PRINTS MESSAGE CONTAINED IN X. IF IT DOESNT FIT ON ONE LINE, X IS PRINTED ON THE NEXT LINE.
+1 NEW X1,X2,ZX
if '$DATA(X)
QUIT
IF $SELECT('$DATA(IOM):1,IOM="":1,1:0)
WRITE $PIECE(X,"*")
READ X:2
KILL X
QUIT
+2 IF ($LENGTH($PIECE(X,"*"))+4+$X)>IOM
WRITE !,?(IOM-($LENGTH($PIECE(X,"*"))+4))
+3 FOR ZX=1:1
if ($LENGTH(X)+6)>IOM
DO BRK
WRITE " ",$PIECE(X,"*"),!
if '$DATA(X1)
QUIT
SET X=X1
KILL X1
+4 if X["*"
WRITE *7
+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
+3 QUIT
DIR() ;SET VARIABLE STRING RETURNING FROM DIR
+1 NEW X
+2 SET X=$DATA(DTOUT)_$DATA(DUOUT)_$DATA(DIRUT)_$DATA(DIROUT)
+3 KILL DTOUT,DUOUT,DIRUT,DIROUT
+4 QUIT X
