PSOATRPP ;BIR/SJA - INTERNET REFILL REPORT SORTED BY PATIENT ;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^PSOATRPP",ZTDESC="INTERNET REFILL REPORT SORTED BY PATIENT"
. 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,PSDD,PSO,PSOAB,PSOAFLAG,PSODFN,PSOERR,PSON,PSONAM
N PSOP6,PSOPAT,PSOP5,PSORXDV,PSORXIN,PSOSD1,PSOT,PSOQUIT,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
..K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
.S PSONAM="" F S PSONAM=$O(^TMP($J,"PSOINT",DIV,PSONAM)) Q:PSONAM=""!(PSOQUIT) S PSOPAT=0 D D FO1
..S (PSON,PSORXIN)=0 F S PSORXIN=$O(^TMP($J,"PSOINT",DIV,PSONAM,PSORXIN)) Q:'PSORXIN!(PSOQUIT) S PSDD=0 F S PSDD=$O(^TMP($J,"PSOINT",DIV,PSONAM,PSORXIN,PSDD)) Q:'PSDD!(PSOQUIT) D
...S PSOPAT=PSOPAT+1,PSO("TOT")=PSO("TOT")+1,PSON=PSON+1,PSOAB=$G(^TMP($J,"PSOINT",DIV,PSONAM,PSORXIN,PSDD)) 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 PATIENT - "_$S(PSODS="D":"Detail",1:"Summary")
W ?45,$TR(RDATE,"@"," ") 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 !!,"Patient",?35,"Filled",?48,"Not Filled",?63,"Total"
E W !!,"Patient",?28,"Rx #",?42,"Date" W:'$G(PSORMZ) ! W ?$S($G(PSORMZ):56,1:20),"Reason"
W !,LINE S PAGE=PAGE+1
Q
PRT ;PRINT REPORT
I PSODS="S" S PSOT(1)=PSOT(1)+PSO(1),PSOT(2)=PSOT(2)+PSO(2)
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
I PSODS="S" W !,$P(PSOAB,"^",2)_" ("_$P(PSOAB,"^",3)_")",?35,PSO(1),?48,PSO(2),?63,(PSO(1)+PSO(2)) Q
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:$E($P(PSOAB,"^",2),1,17)_" ("_$P(PSOAB,"^",3)_")",1:""),?28,$P(PNODE,"^",3),?42,PSOP5 W:'$G(PSORMZ) ! W ?$S($G(PSORMZ):56,1:20),$P(PNODE,"^",10)
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)_" = "_PSO("TOT")
T1 I $E(IOST)="C" W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
Q
FO1 I $D(^TMP($J,"PSOINT",DIV))=11 W !," Total transactions for patient = ",PSOPAT
Q
SET I PSODS="D",($P(PSAB,"^",6)=1) Q
S DFN=PSODFN D DEM^VADPT
S ^TMP($J,"PSOINT",PSORXDV,VADM(1),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(1),PSO(2),PSOT(1),PSOT(2))=0 D D 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 W @IOF
.S PSONAM="" F S PSONAM=$O(^TMP($J,"PSOINT",DIV,PSONAM)) Q:PSONAM=""!(PSOQUIT) S (PSO(1),PSO(2))=0 D D PRT
..S PSORXIN=0 F S PSORXIN=$O(^TMP($J,"PSOINT",DIV,PSONAM,PSORXIN)) Q:'PSORXIN!(PSOQUIT) S PSDD=0 F S PSDD=$O(^TMP($J,"PSOINT",DIV,PSONAM,PSORXIN,PSDD)) Q:'PSDD!(PSOQUIT) D
...S PSOAB=$G(^TMP($J,"PSOINT",DIV,PSONAM,PSORXIN,PSDD))
...S PNODE=$G(^PS(52.43,$P(PSOAB,"^"),0)),PSOP6=$P(PNODE,"^",6),PSO(PSOP6)=PSO(PSOP6)+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOATRPP 5066 printed Apr 09, 2024@21:30:23 Page 2
PSOATRPP ;BIR/SJA - INTERNET REFILL REPORT SORTED BY PATIENT ;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^PSOATRPP"
SET ZTDESC="INTERNET REFILL REPORT SORTED BY PATIENT"
+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,PSDD,PSO,PSOAB,PSOAFLAG,PSODFN,PSOERR,PSON,PSONAM
+2 NEW PSOP6,PSOPAT,PSOP5,PSORXDV,PSORXIN,PSOSD1,PSOT,PSOQUIT,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
+17 SET PSONAM=""
FOR
SET PSONAM=$ORDER(^TMP($JOB,"PSOINT",DIV,PSONAM))
if PSONAM=""!(PSOQUIT)
QUIT
SET PSOPAT=0
Begin DoDot:2
+18 SET (PSON,PSORXIN)=0
FOR
SET PSORXIN=$ORDER(^TMP($JOB,"PSOINT",DIV,PSONAM,PSORXIN))
if 'PSORXIN!(PSOQUIT)
QUIT
SET PSDD=0
FOR
SET PSDD=$ORDER(^TMP($JOB,"PSOINT",DIV,PSONAM,PSORXIN,PSDD))
if 'PSDD!(PSOQUIT)
QUIT
Begin DoDot:3
+19 SET PSOPAT=PSOPAT+1
SET PSO("TOT")=PSO("TOT")+1
SET PSON=PSON+1
SET PSOAB=$GET(^TMP($JOB,"PSOINT",DIV,PSONAM,PSORXIN,PSDD))
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 REPORT BY PATIENT - "_$SELECT(PSODS="D":"Detail",1:"Summary")
+2 WRITE ?45,$TRANSLATE(RDATE,"@"," ")
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 !!,"Patient",?35,"Filled",?48,"Not Filled",?63,"Total"
+5 IF '$TEST
WRITE !!,"Patient",?28,"Rx #",?42,"Date"
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 IF PSODS="S"
SET PSOT(1)=PSOT(1)+PSO(1)
SET PSOT(2)=PSOT(2)+PSO(2)
+2 SET EOFLAG=0
IF ($Y+5)>IOSL
Begin DoDot:1
+3 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
+4 IF $EXTRACT(IOST)'="C"
SET EOFLAG=1
DO HD
End DoDot:1
if PSOQUIT
QUIT
+5 IF PSODS="S"
WRITE !,$PIECE(PSOAB,"^",2)_" ("_$PIECE(PSOAB,"^",3)_")",?35,PSO(1),?48,PSO(2),?63,(PSO(1)+PSO(2))
QUIT
+6 SET PNODE=$GET(^PS(52.43,$PIECE(PSOAB,"^"),0))
+7 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
+8 WRITE !,$SELECT(PSON=1:$EXTRACT($PIECE(PSOAB,"^",2),1,17)_" ("_$PIECE(PSOAB,"^",3)_")",1:""),?28,$PIECE(PNODE,"^",3),?42,PSOP5
if '$GET(PSORMZ)
WRITE !
WRITE ?$SELECT($GET(PSORMZ):56,1:20),$PIECE(PNODE,"^",10)
+9 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)_" = "_PSO("TOT")
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 IF $DATA(^TMP($JOB,"PSOINT",DIV))=11
WRITE !," Total transactions for patient = ",PSOPAT
+1 QUIT
SET IF PSODS="D"
IF ($PIECE(PSAB,"^",6)=1)
QUIT
+1 SET DFN=PSODFN
DO DEM^VADPT
+2 SET ^TMP($JOB,"PSOINT",PSORXDV,VADM(1),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(1),PSO(2),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
WRITE @IOF
End DoDot:2
SET PSOERR=1
+4 SET PSONAM=""
FOR
SET PSONAM=$ORDER(^TMP($JOB,"PSOINT",DIV,PSONAM))
if PSONAM=""!(PSOQUIT)
QUIT
SET (PSO(1),PSO(2))=0
Begin DoDot:2
+5 SET PSORXIN=0
FOR
SET PSORXIN=$ORDER(^TMP($JOB,"PSOINT",DIV,PSONAM,PSORXIN))
if 'PSORXIN!(PSOQUIT)
QUIT
SET PSDD=0
FOR
SET PSDD=$ORDER(^TMP($JOB,"PSOINT",DIV,PSONAM,PSORXIN,PSDD))
if 'PSDD!(PSOQUIT)
QUIT
Begin DoDot:3
+6 SET PSOAB=$GET(^TMP($JOB,"PSOINT",DIV,PSONAM,PSORXIN,PSDD))
+7 SET PNODE=$GET(^PS(52.43,$PIECE(PSOAB,"^"),0))
SET PSOP6=$PIECE(PNODE,"^",6)
SET PSO(PSOP6)=PSO(PSOP6)+1
End DoDot:3
End DoDot:2
DO PRT
End DoDot:1
DO FO
if $EXTRACT(IOST)="P"
WRITE @IOF
+8 QUIT
