- 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
- 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
