PSOATRR ;BIR/SJA - INTERNET REFILL REPORT SORTED BY RESULT ;05/29/07 12:36pm
;;7.0;OUTPATIENT PHARMACY;**264,335**;DEC 1997;Build 1
;
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^PSOATRR",ZTDESC="INTERNET REFILL REPORT SORTED BY RESULT"
. 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,PSODFN,PSOERR,PSON,PSOP5,PSOP6,PSOPAT
N PSOQUIT,PSORXDV,PSORXIN,PSOSD1,PSOSD2,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 (PSO("TOT"),PSO(1),PSO(2))=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
.S PSODFN=0 F S PSODFN=$O(^TMP($J,"PSOINT",DIV,PSODFN)) Q:'PSODFN!(PSOQUIT) S PSOPAT=0 D
..S (PSON,PSORXIN)=0 F S PSORXIN=$O(^TMP($J,"PSOINT",DIV,PSODFN,PSORXIN)) Q:'PSORXIN!(PSOQUIT) D
...S PSOSD2=0 F S PSOSD2=$O(^TMP($J,"PSOINT",DIV,PSODFN,PSORXIN,PSOSD2)) Q:'PSOSD2!(PSOQUIT) D
....S PSOAB=$G(^TMP($J,"PSOINT",DIV,PSODFN,PSORXIN,PSOSD2)),PSOPAT=PSOPAT+1,PSO("TOT")=PSO("TOT")+1,PSON=PSON+1 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 REPORT BY RESULT"_" - "_$S(PSODS="D":"Detail",1:"Summary")
W ?45,$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 !!,"Result",?30,"Count"
E W !!,"Patient",?30,"Rx #",?44,"Date" W:'$G(PSORMZ) ! W ?$S($G(PSORMZ):58,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))
S Y=$P(PNODE,"^",5),PSOP5=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3),PSOP6=$P(PNODE,"^",6),PSO(PSOP6)=PSO(PSOP6)+1
W !,$S(PSON=1:$P(PSOAB,"^",2)_" ("_$P(PSOAB,"^",3)_")",1:""),?30,$P(PNODE,"^",3),?44,PSOP5 W:'$G(PSORMZ) ! W ?$S($G(PSORMZ):58,1:20),$P(PNODE,"^",10)
Q
FO I PSODS="S",$D(^TMP($J,"PSOINT",DIV))=11 W !!!,"Total: ",?30,(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)_" = "_PSO("TOT")
.I $G(PSORST)="B" W !,"Filled = "_PSO(1)," Not Filled = ",PSO(2)
T1 I $E(IOST)="C" W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
W:$E(IOST)="P" @IOF
Q
SET I PSODS="D",($P(PSAB,"^",6)=1) Q
S DFN=PSODFN D DEM^VADPT
S ^TMP($J,"PSOINT",PSORXDV,PSODFN,PSORXIN,PSOSD1)=PSA_"^"_VADM(1)_"^"_VA("BID")
Q
SUMM ;
S DIV=0 F S DIV=$O(^TMP($J,"PSOINT",DIV)) Q:'DIV!(PSOQUIT) S (PSO(2),PSO(1),PSOT(1),PSOT(2))=0 D D PRTS,FO W:$E(IOST)="P" @IOF
.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
.S PSODFN=0 F S PSODFN=$O(^TMP($J,"PSOINT",DIV,PSODFN)) Q:'PSODFN!(PSOQUIT) D
..S PSORXIN=0 F S PSORXIN=$O(^TMP($J,"PSOINT",DIV,PSODFN,PSORXIN)) Q:'PSORXIN!(PSOQUIT) D
...S PSOSD2=0 F S PSOSD2=$O(^TMP($J,"PSOINT",DIV,PSODFN,PSORXIN,PSOSD2)) Q:'PSOSD2!(PSOQUIT) D
....S PSOAB=$G(^TMP($J,"PSOINT",DIV,PSODFN,PSORXIN,PSOSD2)),PNODE=$G(^PS(52.43,$P(PSOAB,"^"),0))
....S PSOP6=$P(PNODE,"^",6) S PSO(PSOP6)=PSO(PSOP6)+1,PSOT(PSOP6)=PSOT(PSOP6)+1
Q
PRTS ;
W:$D(^TMP($J,"PSOINT",DIV))=11 !,"Filled",?30,PSO(1),!,"Not Filled",?30,PSO(2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOATRR 4967 printed Nov 22, 2024@17:34:36 Page 2
PSOATRR ;BIR/SJA - INTERNET REFILL REPORT SORTED BY RESULT ;05/29/07 12:36pm
+1 ;;7.0;OUTPATIENT PHARMACY;**264,335**;DEC 1997;Build 1
+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^PSOATRR"
SET ZTDESC="INTERNET REFILL REPORT SORTED BY RESULT"
+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,PSODFN,PSOERR,PSON,PSOP5,PSOP6,PSOPAT
+2 NEW PSOQUIT,PSORXDV,PSORXIN,PSOSD1,PSOSD2,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 (PSO("TOT"),PSO(1),PSO(2))=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
End DoDot:2
SET PSOERR=1
if $EXTRACT(IOST)="P"
WRITE @IOF
+17 SET PSODFN=0
FOR
SET PSODFN=$ORDER(^TMP($JOB,"PSOINT",DIV,PSODFN))
if 'PSODFN!(PSOQUIT)
QUIT
SET PSOPAT=0
Begin DoDot:2
+18 SET (PSON,PSORXIN)=0
FOR
SET PSORXIN=$ORDER(^TMP($JOB,"PSOINT",DIV,PSODFN,PSORXIN))
if 'PSORXIN!(PSOQUIT)
QUIT
Begin DoDot:3
+19 SET PSOSD2=0
FOR
SET PSOSD2=$ORDER(^TMP($JOB,"PSOINT",DIV,PSODFN,PSORXIN,PSOSD2))
if 'PSOSD2!(PSOQUIT)
QUIT
Begin DoDot:4
+20 SET PSOAB=$GET(^TMP($JOB,"PSOINT",DIV,PSODFN,PSORXIN,PSOSD2))
SET PSOPAT=PSOPAT+1
SET PSO("TOT")=PSO("TOT")+1
SET PSON=PSON+1
DO PRT
End DoDot:4
End DoDot:3
End DoDot:2
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 REPORT BY RESULT"_" - "_$SELECT(PSODS="D":"Detail",1:"Summary")
+2 WRITE ?45,$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 !!,"Result",?30,"Count"
+5 IF '$TEST
WRITE !!,"Patient",?30,"Rx #",?44,"Date"
if '$GET(PSORMZ)
WRITE !
WRITE ?$SELECT($GET(PSORMZ):58,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))
+5 SET Y=$PIECE(PNODE,"^",5)
SET PSOP5=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
SET PSOP6=$PIECE(PNODE,"^",6)
SET PSO(PSOP6)=PSO(PSOP6)+1
+6 WRITE !,$SELECT(PSON=1:$PIECE(PSOAB,"^",2)_" ("_$PIECE(PSOAB,"^",3)_")",1:""),?30,$PIECE(PNODE,"^",3),?44,PSOP5
if '$GET(PSORMZ)
WRITE !
WRITE ?$SELECT($GET(PSORMZ):58,1:20),$PIECE(PNODE,"^",10)
+7 QUIT
FO IF PSODS="S"
IF $DATA(^TMP($JOB,"PSOINT",DIV))=11
WRITE !!!,"Total: ",?30,(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)_" = "_PSO("TOT")
+3 IF $GET(PSORST)="B"
WRITE !,"Filled = "_PSO(1)," Not Filled = ",PSO(2)
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 if $EXTRACT(IOST)="P"
WRITE @IOF
+2 QUIT
SET IF PSODS="D"
IF ($PIECE(PSAB,"^",6)=1)
QUIT
+1 SET DFN=PSODFN
DO DEM^VADPT
+2 SET ^TMP($JOB,"PSOINT",PSORXDV,PSODFN,PSORXIN,PSOSD1)=PSA_"^"_VADM(1)_"^"_VA("BID")
+3 QUIT
SUMM ;
+1 SET DIV=0
FOR
SET DIV=$ORDER(^TMP($JOB,"PSOINT",DIV))
if 'DIV!(PSOQUIT)
QUIT
SET (PSO(2),PSO(1),PSOT(1),PSOT(2))=0
Begin DoDot:1
+2 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
+3 KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
End DoDot:2
SET PSOERR=1
+4 SET PSODFN=0
FOR
SET PSODFN=$ORDER(^TMP($JOB,"PSOINT",DIV,PSODFN))
if 'PSODFN!(PSOQUIT)
QUIT
Begin DoDot:2
+5 SET PSORXIN=0
FOR
SET PSORXIN=$ORDER(^TMP($JOB,"PSOINT",DIV,PSODFN,PSORXIN))
if 'PSORXIN!(PSOQUIT)
QUIT
Begin DoDot:3
+6 SET PSOSD2=0
FOR
SET PSOSD2=$ORDER(^TMP($JOB,"PSOINT",DIV,PSODFN,PSORXIN,PSOSD2))
if 'PSOSD2!(PSOQUIT)
QUIT
Begin DoDot:4
+7 SET PSOAB=$GET(^TMP($JOB,"PSOINT",DIV,PSODFN,PSORXIN,PSOSD2))
SET PNODE=$GET(^PS(52.43,$PIECE(PSOAB,"^"),0))
+8 SET PSOP6=$PIECE(PNODE,"^",6)
SET PSO(PSOP6)=PSO(PSOP6)+1
SET PSOT(PSOP6)=PSOT(PSOP6)+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
DO PRTS
DO FO
if $EXTRACT(IOST)="P"
WRITE @IOF
+9 QUIT
PRTS ;
+1 if $DATA(^TMP($JOB,"PSOINT",DIV))=11
WRITE !,"Filled",?30,PSO(1),!,"Not Filled",?30,PSO(2)
+2 QUIT
