PSOATRD ;BIR/SJA - INTERNET REFILL BY DATE ;05/29/07 12:36pm
;;7.0;OUTPATIENT PHARMACY;**264**;DEC 1997;Build 19
;
K IOP,%ZIS,POP S PSOION=ION,%ZIS="MQ" D ^%ZIS I POP S IOP=PSOION D ^%ZIS K PSOION S PSOQUIT=1 G END
I $D(IO("Q")) D K PSOION,ZTSK S PSOQUIT=1 G END
. N VAR K IO("Q"),ZTIO,ZTSAVE,ZTDTH,ZTSK S ZTRTN="START^PSOATRD",ZTDESC="INTERNET REFILL REPORT BY DATE"
. F VAR="PSODS","PSOED","PSOEDX","PSOREP","PSORMZ","PSOSD","PSOSDX","RDATE" S:$D(@VAR) ZTSAVE(VAR)=""
. S ZTSAVE("PSODIV*")=""
. D ^%ZTLOAD W:$D(ZTSK) !,"Report is Queued to print !!"
START U IO
N DFN,DIV,EOFLAG,LINE,PAGE,PNODE,PSA,PSAB,PSO,PSOAB,PSOAFLAG,PSOD,PSODFN,PSOERR
N PSON,PSOP6,PSOQUIT,PSORXDV,PSORXIN,PSOSD1,PSOT,X,Y
K ^TMP($J,"PSOINT") S PAGE=1,PSOQUIT=0,$P(LINE,"-",$S($G(PSORMZ):130,1:79))=""
S (PSOERR,PSOAFLAG)=0
S PSOD=0 F S PSOD=$O(PSODIV(PSOD)) Q:'PSOD S ^TMP($J,"PSOINT",PSOD)=""
S (PSA,PSOD)=0 F S PSOD=$O(PSODIV(PSOD)) Q:'PSOD D Q:$G(PSODIV)="ALL"
.S ^TMP($J,"PSOINT",PSOD)=""
.S PSOSD1=PSOSD-1 F S PSOSD1=$O(^PS(52.43,"AD",PSOSD1)) Q:'PSOSD1 I PSOSD1'<PSOSD,PSOSD1'>PSOED D
..S PSA=0 F S PSA=$O(^PS(52.43,"AD",PSOSD1,PSA)) Q:'PSA S PSAB=$G(^PS(52.43,PSA,0)) D:$P(PSAB,"^",6)>0
...S PSORXIN=$P(PSAB,"^",8),PSODFN=$P($G(^PSRX(PSORXIN,0)),"^",2),PSORXDV=$P($G(^PSRX(PSORXIN,2)),"^",9)
...I $G(PSODIV)="ALL"!($$DIV^PSOATRP(PSORXIN,PSORXDV)) D SET
I PSODS="S" D SUMM G END ;print summary report only
S DIV=0 F S DIV=$O(^TMP($J,"PSOINT",DIV)) Q:'DIV!(PSOQUIT) D D FO W:$E(IOST)="P" @IOF
.S (PSOT(1),PSOT(2),PSO(1),PSO(2),PSOT(10),PSOT(20))=0
.S PAGE=1 D HD I $D(^TMP($J,"PSOINT",DIV))'=11 W !!,"NO DATA FOUND TO PRINT FOR THIS RANGE.",! D:$E(IOST)="C" S PSOERR=1 W:$E(IOST)="P" @IOF
..K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR W @IOF
.S PSOSD=0 F S PSOSD=$O(^TMP($J,"PSOINT",DIV,PSOSD)) Q:'PSOSD!(PSOQUIT) D PRTD S (PSOT(1),PSOT(2),PSOT(10),PSOT(20),PSODFN)=0 D D FO1
..F S PSODFN=$O(^TMP($J,"PSOINT",DIV,PSOSD,PSODFN)) Q:'PSODFN!(PSOQUIT) S (PSON,PSORXIN)=0 D
...F S PSORXIN=$O(^TMP($J,"PSOINT",DIV,PSOSD,PSODFN,PSORXIN)) Q:'PSORXIN!(PSOQUIT) D SET1 D PRT
END D:$E(IOST)="C"&('$G(PSOQUIT))&('$G(PSOERR)) K ^TMP($J,"PSOINT") W:$E(IOST)="P" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" Q
.W !!,"** END OF REPORT **"
.W !! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
;
HD ;PRINT PAGE HEADING
W:$G(PAGE)'=1!($E(IOST)="C") @IOF W !,"INTERNET REFILL BY DATE - "_$S(PSODS="D":" Detail",1:"Summary")
W ?41,$P(RDATE,":",1,2) W ?$S($G(PSORMZ):120,1:68),"PAGE: "_PAGE
W !,$S(PSODS="D":"Not Filled - ",1:"")_"For date range "_$G(PSOSDX)_" through "_$G(PSOEDX)_" for "_$P(^PS(59,DIV,0),"^")
I PSODS="S" W !!,"Date Processed",?35,"Filled",?48,"Not Filled",?63,"Total"
E W !!,"Patient",?30,"Rx #" W:'$G(PSORMZ) ! W ?$S($G(PSORMZ):56,1:20),"Reason"
W !,LINE S PAGE=PAGE+1
Q
PRT ;PRINT REPORT
S EOFLAG=0 I ($Y+5)>IOSL D Q:PSOQUIT
.I $E(IOST)="C" W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue,'^' to exit" D ^DIR K DIR S:'Y PSOQUIT=1 I 'PSOQUIT S EOFLAG=1 D HD
.I $E(IOST)'="C" S EOFLAG=1 D HD
S PNODE=$G(^PS(52.43,$P(PSOAB,"^"),0)),PSOP6=$P(PNODE,"^",6)
I PSODS="S" W ?35,PSO(1),?48,PSO(2),?63,(PSO(1)+PSO(2))
E W !,$S(PSON=1:$P(PSOAB,"^",2)_" ("_$P(PSOAB,"^",3)_")",1:""),?30,$P(PNODE,"^",3) W:'$G(PSORMZ) ! W ?$S($G(PSORMZ):56,1:20),$P(PNODE,"^",10)
Q
PRTD S Y=PSOSD D DD^%DT W !,Y
Q
FO I PSODS="S",$D(^TMP($J,"PSOINT",DIV))=11 W !!,"COUNT: ",?35,PSOT(1),?48,PSOT(2),?63,(PSOT(1)+PSOT(2)) G T1
Q:$D(^TMP($J,"PSOINT",DIV))'=11 D:PSODS="D"
.W !!,"Total transactions for date range "_$G(PSOSDX)_" through "_$G(PSOEDX)_" = "_(PSOT(10)+PSOT(20))
T1 I $E(IOST)="C" W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
Q
FO1 ;
S PSOT(10)=PSOT(10)+PSO(1),PSOT(20)=PSOT(20)+PSO(2)
I $D(^TMP($J,"PSOINT",DIV))=11 W !,"Count: ",PSOT(2),!
Q
SET I PSODS="D",($P(PSAB,"^",6)=1) Q
S DFN=PSODFN D DEM^VADPT
S ^TMP($J,"PSOINT",PSORXDV,PSOSD1,PSODFN,PSORXIN)=PSA_"^"_VADM(1)_"^"_VA("BID")
Q
SET1 K PSPC
S PSOAB=$G(^TMP($J,"PSOINT",DIV,PSOSD,PSODFN,PSORXIN)),PNODE=$G(^PS(52.43,$P(PSOAB,"^"),0))
S PSPC=$P(PNODE,"^",6),PSO(PSPC)=PSO(PSPC)+1,PSOT(PSPC)=PSOT(PSPC)+1,PSON=PSON+1
Q
SUMM ;
S DIV=0 F S DIV=$O(^TMP($J,"PSOINT",DIV)) Q:'DIV!(PSOQUIT) D D FO W:$E(IOST)="P" @IOF
.S (PSOT(1),PSOT(2),PSO(1),PSO(2),PSOT(10),PSOT(20))=0
.S PAGE=1 D HD I $D(^TMP($J,"PSOINT",DIV))'=11 W !!,"NO DATA FOUND TO PRINT FOR THIS RANGE.",! D:$E(IOST)="C" S PSOERR=1
..K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR W @IOF
.S PSOSD=0 F S PSOSD=$O(^TMP($J,"PSOINT",DIV,PSOSD)) Q:'PSOSD!(PSOQUIT) D PRTD S (PSO(1),PSO(2),PSOT(10),PSOT(20),PSODFN)=0 D D PRT
..F S PSODFN=$O(^TMP($J,"PSOINT",DIV,PSOSD,PSODFN)) Q:'PSODFN!(PSOQUIT) S (PSON,PSORXIN)=0 D
...F S PSORXIN=$O(^TMP($J,"PSOINT",DIV,PSOSD,PSODFN,PSORXIN)) Q:'PSORXIN!(PSOQUIT) D SET1 S PSOT(10)=PSOT(1),PSOT(20)=PSOT(2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOATRD 4984 printed Sep 23, 2025@20:00:45 Page 2
PSOATRD ;BIR/SJA - INTERNET REFILL BY DATE ;05/29/07 12:36pm
+1 ;;7.0;OUTPATIENT PHARMACY;**264**;DEC 1997;Build 19
+2 ;
+3 KILL IOP,%ZIS,POP
SET PSOION=ION
SET %ZIS="MQ"
DO ^%ZIS
IF POP
SET IOP=PSOION
DO ^%ZIS
KILL PSOION
SET PSOQUIT=1
GOTO END
+4 IF $DATA(IO("Q"))
Begin DoDot:1
+5 NEW VAR
KILL IO("Q"),ZTIO,ZTSAVE,ZTDTH,ZTSK
SET ZTRTN="START^PSOATRD"
SET ZTDESC="INTERNET REFILL REPORT BY DATE"
+6 FOR VAR="PSODS","PSOED","PSOEDX","PSOREP","PSORMZ","PSOSD","PSOSDX","RDATE"
if $DATA(@VAR)
SET ZTSAVE(VAR)=""
+7 SET ZTSAVE("PSODIV*")=""
+8 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Report is Queued to print !!"
End DoDot:1
KILL PSOION,ZTSK
SET PSOQUIT=1
GOTO END
START USE IO
+1 NEW DFN,DIV,EOFLAG,LINE,PAGE,PNODE,PSA,PSAB,PSO,PSOAB,PSOAFLAG,PSOD,PSODFN,PSOERR
+2 NEW PSON,PSOP6,PSOQUIT,PSORXDV,PSORXIN,PSOSD1,PSOT,X,Y
+3 KILL ^TMP($JOB,"PSOINT")
SET PAGE=1
SET PSOQUIT=0
SET $PIECE(LINE,"-",$SELECT($GET(PSORMZ):130,1:79))=""
+4 SET (PSOERR,PSOAFLAG)=0
+5 SET PSOD=0
FOR
SET PSOD=$ORDER(PSODIV(PSOD))
if 'PSOD
QUIT
SET ^TMP($JOB,"PSOINT",PSOD)=""
+6 SET (PSA,PSOD)=0
FOR
SET PSOD=$ORDER(PSODIV(PSOD))
if 'PSOD
QUIT
Begin DoDot:1
+7 SET ^TMP($JOB,"PSOINT",PSOD)=""
+8 SET PSOSD1=PSOSD-1
FOR
SET PSOSD1=$ORDER(^PS(52.43,"AD",PSOSD1))
if 'PSOSD1
QUIT
IF PSOSD1'<PSOSD
IF PSOSD1'>PSOED
Begin DoDot:2
+9 SET PSA=0
FOR
SET PSA=$ORDER(^PS(52.43,"AD",PSOSD1,PSA))
if 'PSA
QUIT
SET PSAB=$GET(^PS(52.43,PSA,0))
if $PIECE(PSAB,"^",6)>0
Begin DoDot:3
+10 SET PSORXIN=$PIECE(PSAB,"^",8)
SET PSODFN=$PIECE($GET(^PSRX(PSORXIN,0)),"^",2)
SET PSORXDV=$PIECE($GET(^PSRX(PSORXIN,2)),"^",9)
+11 IF $GET(PSODIV)="ALL"!($$DIV^PSOATRP(PSORXIN,PSORXDV))
DO SET
End DoDot:3
End DoDot:2
End DoDot:1
if $GET(PSODIV)="ALL"
QUIT
+12 ;print summary report only
IF PSODS="S"
DO SUMM
GOTO END
+13 SET DIV=0
FOR
SET DIV=$ORDER(^TMP($JOB,"PSOINT",DIV))
if 'DIV!(PSOQUIT)
QUIT
Begin DoDot:1
+14 SET (PSOT(1),PSOT(2),PSO(1),PSO(2),PSOT(10),PSOT(20))=0
+15 SET PAGE=1
DO HD
IF $DATA(^TMP($JOB,"PSOINT",DIV))'=11
WRITE !!,"NO DATA FOUND TO PRINT FOR THIS RANGE.",!
if $EXTRACT(IOST)="C"
Begin DoDot:2
+16 KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
WRITE @IOF
End DoDot:2
SET PSOERR=1
if $EXTRACT(IOST)="P"
WRITE @IOF
+17 SET PSOSD=0
FOR
SET PSOSD=$ORDER(^TMP($JOB,"PSOINT",DIV,PSOSD))
if 'PSOSD!(PSOQUIT)
QUIT
DO PRTD
SET (PSOT(1),PSOT(2),PSOT(10),PSOT(20),PSODFN)=0
Begin DoDot:2
+18 FOR
SET PSODFN=$ORDER(^TMP($JOB,"PSOINT",DIV,PSOSD,PSODFN))
if 'PSODFN!(PSOQUIT)
QUIT
SET (PSON,PSORXIN)=0
Begin DoDot:3
+19 FOR
SET PSORXIN=$ORDER(^TMP($JOB,"PSOINT",DIV,PSOSD,PSODFN,PSORXIN))
if 'PSORXIN!(PSOQUIT)
QUIT
DO SET1
DO PRT
End DoDot:3
End DoDot:2
DO FO1
End DoDot:1
DO FO
if $EXTRACT(IOST)="P"
WRITE @IOF
END if $EXTRACT(IOST)="C"&('$GET(PSOQUIT))&('$GET(PSOERR))
Begin DoDot:1
+1 WRITE !!,"** END OF REPORT **"
+2 WRITE !!
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
End DoDot:1
KILL ^TMP($JOB,"PSOINT")
if $EXTRACT(IOST)="P"
WRITE @IOF
DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+3 ;
HD ;PRINT PAGE HEADING
+1 if $GET(PAGE)'=1!($EXTRACT(IOST)="C")
WRITE @IOF
WRITE !,"INTERNET REFILL BY DATE - "_$SELECT(PSODS="D":" Detail",1:"Summary")
+2 WRITE ?41,$PIECE(RDATE,":",1,2)
WRITE ?$SELECT($GET(PSORMZ):120,1:68),"PAGE: "_PAGE
+3 WRITE !,$SELECT(PSODS="D":"Not Filled - ",1:"")_"For date range "_$GET(PSOSDX)_" through "_$GET(PSOEDX)_" for "_$PIECE(^PS(59,DIV,0),"^")
+4 IF PSODS="S"
WRITE !!,"Date Processed",?35,"Filled",?48,"Not Filled",?63,"Total"
+5 IF '$TEST
WRITE !!,"Patient",?30,"Rx #"
if '$GET(PSORMZ)
WRITE !
WRITE ?$SELECT($GET(PSORMZ):56,1:20),"Reason"
+6 WRITE !,LINE
SET PAGE=PAGE+1
+7 QUIT
PRT ;PRINT REPORT
+1 SET EOFLAG=0
IF ($Y+5)>IOSL
Begin DoDot:1
+2 IF $EXTRACT(IOST)="C"
WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue,'^' to exit"
DO ^DIR
KILL DIR
if 'Y
SET PSOQUIT=1
IF 'PSOQUIT
SET EOFLAG=1
DO HD
+3 IF $EXTRACT(IOST)'="C"
SET EOFLAG=1
DO HD
End DoDot:1
if PSOQUIT
QUIT
+4 SET PNODE=$GET(^PS(52.43,$PIECE(PSOAB,"^"),0))
SET PSOP6=$PIECE(PNODE,"^",6)
+5 IF PSODS="S"
WRITE ?35,PSO(1),?48,PSO(2),?63,(PSO(1)+PSO(2))
+6 IF '$TEST
WRITE !,$SELECT(PSON=1:$PIECE(PSOAB,"^",2)_" ("_$PIECE(PSOAB,"^",3)_")",1:""),?30,$PIECE(PNODE,"^",3)
if '$GET(PSORMZ)
WRITE !
WRITE ?$SELECT($GET(PSORMZ):56,1:20),$PIECE(PNODE,"^",10)
+7 QUIT
PRTD SET Y=PSOSD
DO DD^%DT
WRITE !,Y
+1 QUIT
FO IF PSODS="S"
IF $DATA(^TMP($JOB,"PSOINT",DIV))=11
WRITE !!,"COUNT: ",?35,PSOT(1),?48,PSOT(2),?63,(PSOT(1)+PSOT(2))
GOTO T1
+1 if $DATA(^TMP($JOB,"PSOINT",DIV))'=11
QUIT
if PSODS="D"
Begin DoDot:1
+2 WRITE !!,"Total transactions for date range "_$GET(PSOSDX)_" through "_$GET(PSOEDX)_" = "_(PSOT(10)+PSOT(20))
End DoDot:1
T1 IF $EXTRACT(IOST)="C"
WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
+1 QUIT
FO1 ;
+1 SET PSOT(10)=PSOT(10)+PSO(1)
SET PSOT(20)=PSOT(20)+PSO(2)
+2 IF $DATA(^TMP($JOB,"PSOINT",DIV))=11
WRITE !,"Count: ",PSOT(2),!
+3 QUIT
SET IF PSODS="D"
IF ($PIECE(PSAB,"^",6)=1)
QUIT
+1 SET DFN=PSODFN
DO DEM^VADPT
+2 SET ^TMP($JOB,"PSOINT",PSORXDV,PSOSD1,PSODFN,PSORXIN)=PSA_"^"_VADM(1)_"^"_VA("BID")
+3 QUIT
SET1 KILL PSPC
+1 SET PSOAB=$GET(^TMP($JOB,"PSOINT",DIV,PSOSD,PSODFN,PSORXIN))
SET PNODE=$GET(^PS(52.43,$PIECE(PSOAB,"^"),0))
+2 SET PSPC=$PIECE(PNODE,"^",6)
SET PSO(PSPC)=PSO(PSPC)+1
SET PSOT(PSPC)=PSOT(PSPC)+1
SET PSON=PSON+1
+3 QUIT
SUMM ;
+1 SET DIV=0
FOR
SET DIV=$ORDER(^TMP($JOB,"PSOINT",DIV))
if 'DIV!(PSOQUIT)
QUIT
Begin DoDot:1
+2 SET (PSOT(1),PSOT(2),PSO(1),PSO(2),PSOT(10),PSOT(20))=0
+3 SET PAGE=1
DO HD
IF $DATA(^TMP($JOB,"PSOINT",DIV))'=11
WRITE !!,"NO DATA FOUND TO PRINT FOR THIS RANGE.",!
if $EXTRACT(IOST)="C"
Begin DoDot:2
+4 KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
WRITE @IOF
End DoDot:2
SET PSOERR=1
+5 SET PSOSD=0
FOR
SET PSOSD=$ORDER(^TMP($JOB,"PSOINT",DIV,PSOSD))
if 'PSOSD!(PSOQUIT)
QUIT
DO PRTD
SET (PSO(1),PSO(2),PSOT(10),PSOT(20),PSODFN)=0
Begin DoDot:2
+6 FOR
SET PSODFN=$ORDER(^TMP($JOB,"PSOINT",DIV,PSOSD,PSODFN))
if 'PSODFN!(PSOQUIT)
QUIT
SET (PSON,PSORXIN)=0
Begin DoDot:3
+7 FOR
SET PSORXIN=$ORDER(^TMP($JOB,"PSOINT",DIV,PSOSD,PSODFN,PSORXIN))
if 'PSORXIN!(PSOQUIT)
QUIT
DO SET1
SET PSOT(10)=PSOT(1)
SET PSOT(20)=PSOT(2)
End DoDot:3
End DoDot:2
DO PRT
End DoDot:1
DO FO
if $EXTRACT(IOST)="P"
WRITE @IOF
+8 QUIT
