PSORPTS1 ;BHAM ISC/SAB - MOST COMMONLY DISPENSED DRUGS REPORT ; 03/29/93 13:04
;;7.0;OUTPATIENT PHARMACY;**29,55**;DEC 1997
;External Ref. to ^PSDRUG is supp. by DBIA# 221
SDT W ! S %DT("A")="STARTING DATE: ",%DT="EXAP" D ^%DT G:"^"[X END G:Y<0 SDT S (%DT(0),SDT)=Y
EDT W ! S %DT("A")="ENDING DATE: ",%DT="EXAP" D ^%DT G:"^"[X END G:Y<0 EDT S EDT=Y K %DT
P0 S DIR("A")="DO NOT PRINT DRUG IF COUNT IS LESS THAN ",DIR("B")=20,DIR(0)="N^1:100:0"
D ^DIR S PSMIN=Y K DIR G:$D(DIRUT) END
K %ZIS,IOP,ZTSK,POP S PSOION=ION,%ZIS="QM" D ^%ZIS K %ZIS I POP S IOP=PSOION D ^%ZIS K IOP,PSOION G END
K PSOION I $D(IO("Q")) S ZTRTN="RPT^PSORPTS1" F G="SDT","EDT","PSMIN" S:$D(@G) ZTSAVE(G)=""
I K IO("Q") S ZTDESC="MOST COMMON DISPENSED DRUGS REPORT" D ^%ZTLOAD W:$D(ZTSK) !,"REPORT IS QUEUED TO PRINT",! K ZTSK G END
RPT U IO K ^TMP($J) S PG=0,X="",PSDT=SDT-1,PFT=""
F S PSDT=$O(^PSRX("AD",PSDT)) Q:'PSDT!(PSDT>EDT) F IRN=0:0 S IRN=$O(^PSRX("AD",PSDT,IRN)) Q:'IRN F S PFT=$O(^PSRX("AD",PSDT,IRN,PFT)) Q:PFT="" D
.Q:'$D(^PSRX(IRN,0)) S Y=^PSRX(IRN,0),Y2=$G(^(2))
.S DRG=+$P(Y,"^",6),Y=+$P(Y,"^",7),DV=$S($P(Y2,"^",9):$P(Y2,"^",9),1:$O(^PS(59,0))) D P1:DV&($D(^PSDRUG(DRG,0)))
F DV=0:0 S DV=$O(^TMP($J,DV)) Q:'DV F I=0:0 S I=$O(^TMP($J,DV,0,I)) Q:'I D
.S Y=$S($D(^PSDRUG(I,0)):$E($P(^(0),"^"),1,30),1:I)
.F II=0:0 S II=$O(^TMP($J,DV,0,I,II)) Q:'II I ^TMP($J,DV,0,I,II)'<PSMIN S ST=999999-^(II) F J=1:1 I '$D(^TMP($J,DV,1,ST,Y,J)) S ^(J)=I_"^"_II Q
I '$O(^TMP($J,0)) W !!?30,">>>>> NO DISPENSED DRUGS FOUND <<<<<" D HD G END
S (DVH,DV)=0,II=""
F S DV=$O(^TMP($J,DV)) Q:'DV!($D(DIRUT)) I $O(^TMP($J,+$G(DV),1,0)) D:DVH'=DV HD F ST=0:0 S ST=$O(^TMP($J,DV,1,ST)) Q:'ST!($D(DIRUT)) D
.F J=0:0 S II=$O(^TMP($J,DV,1,ST,II)) Q:II=""!($D(DIRUT)) F T=0:0 S T=$O(^TMP($J,DV,1,ST,II,T)) Q:'T!($D(DIRUT)) D
..S DRG=+^TMP($J,DV,1,ST,II,T),QTY=+$P(^(T),"^",2) D:$Y+4>IOSL HD Q:$D(DIRUT) W !,$J(DRG,5)," ",$S($D(^PSDRUG(DRG,0)):$P(^(0),"^"),1:"********"),?52,$J(QTY,12),?64,$J($P(^TMP($J,DV,0,DRG,QTY),"^"),7) S DVH=DV
END W ! D ^%ZISC K T,SDT,IRN,PFT,^TMP($J),DIROUT,DTOUT,DUOUT,DIRUT,SDT,ST,EDT,PSMIN,DAT,%DT,G,I,II,J,PSOION,X,Y,ZI,DRG,PG,DIR,DV,QTY S:$D(ZTQUEUED) ZTREQ="@"
K PSDT,Y2 Q
P1 I 'PFT,$S($P(Y2,"^",2):$P(Y2,"^",2),1:$P(Y,"^",13))'<SDT,$S($P(Y2,"^",2):$P(Y2,"^",2),1:$P(Y,"^",13))'>EDT S ^TMP($J,DV,0,DRG)=$S($D(^TMP($J,DV,0,DRG)):^(DRG)+1,1:1) S ^(Y)=$S($D(^(DRG,Y)):^(Y)+1,1:1)
I PFT,$D(^PSRX(IRN,1,PFT,0)),+^(0)'<SDT,+^(0)'>EDT S ^TMP($J,DV,0,DRG)=$S($D(^TMP($J,DV,0,DRG)):^(DRG)+1,1:1) S ^(Y)=$S($D(^(DRG,Y)):^(Y)+1,1:1)
Q
HD I PG,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR Q:$D(DIRUT)
S PG=PG+1 W @IOF,"MOST COMMONLY DISPENSED DRUGS FROM ",$E(SDT,4,5),"-",$E(SDT,6,7),"-",$E(SDT,2,3)," THRU ",$E(EDT,4,5),"-",$E(EDT,6,7),"-",$E(EDT,2,3),?70,$E(DT,4,5),"-",$E(DT,6,7),"-",$E(DT,2,3)
W !?15,"MINIMUM DRUG COUNT OF "_PSMIN,?70,"Pg: "_PG,!,"ENTRY",!,"NUMBER",?10,"DRUG",?55,"QUANTITY",?68,"FILLS",! F ZI=1:1:80 W "-"
W:$G(DV) !,"Division: "_$P(^PS(59,DV,0),"^"),! Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORPTS1 3018 printed Dec 13, 2024@02:34:13 Page 2
PSORPTS1 ;BHAM ISC/SAB - MOST COMMONLY DISPENSED DRUGS REPORT ; 03/29/93 13:04
+1 ;;7.0;OUTPATIENT PHARMACY;**29,55**;DEC 1997
+2 ;External Ref. to ^PSDRUG is supp. by DBIA# 221
SDT WRITE !
SET %DT("A")="STARTING DATE: "
SET %DT="EXAP"
DO ^%DT
if "^"[X
GOTO END
if Y<0
GOTO SDT
SET (%DT(0),SDT)=Y
EDT WRITE !
SET %DT("A")="ENDING DATE: "
SET %DT="EXAP"
DO ^%DT
if "^"[X
GOTO END
if Y<0
GOTO EDT
SET EDT=Y
KILL %DT
P0 SET DIR("A")="DO NOT PRINT DRUG IF COUNT IS LESS THAN "
SET DIR("B")=20
SET DIR(0)="N^1:100:0"
+1 DO ^DIR
SET PSMIN=Y
KILL DIR
if $DATA(DIRUT)
GOTO END
+2 KILL %ZIS,IOP,ZTSK,POP
SET PSOION=ION
SET %ZIS="QM"
DO ^%ZIS
KILL %ZIS
IF POP
SET IOP=PSOION
DO ^%ZIS
KILL IOP,PSOION
GOTO END
+3 KILL PSOION
IF $DATA(IO("Q"))
SET ZTRTN="RPT^PSORPTS1"
FOR G="SDT","EDT","PSMIN"
if $DATA(@G)
SET ZTSAVE(G)=""
+4 IF $TEST
KILL IO("Q")
SET ZTDESC="MOST COMMON DISPENSED DRUGS REPORT"
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"REPORT IS QUEUED TO PRINT",!
KILL ZTSK
GOTO END
RPT USE IO
KILL ^TMP($JOB)
SET PG=0
SET X=""
SET PSDT=SDT-1
SET PFT=""
+1 FOR
SET PSDT=$ORDER(^PSRX("AD",PSDT))
if 'PSDT!(PSDT>EDT)
QUIT
FOR IRN=0:0
SET IRN=$ORDER(^PSRX("AD",PSDT,IRN))
if 'IRN
QUIT
FOR
SET PFT=$ORDER(^PSRX("AD",PSDT,IRN,PFT))
if PFT=""
QUIT
Begin DoDot:1
+2 if '$DATA(^PSRX(IRN,0))
QUIT
SET Y=^PSRX(IRN,0)
SET Y2=$GET(^(2))
+3 SET DRG=+$PIECE(Y,"^",6)
SET Y=+$PIECE(Y,"^",7)
SET DV=$SELECT($PIECE(Y2,"^",9):$PIECE(Y2,"^",9),1:$ORDER(^PS(59,0)))
if DV&($DATA(^PSDRUG(DRG,0)))
DO P1
End DoDot:1
+4 FOR DV=0:0
SET DV=$ORDER(^TMP($JOB,DV))
if 'DV
QUIT
FOR I=0:0
SET I=$ORDER(^TMP($JOB,DV,0,I))
if 'I
QUIT
Begin DoDot:1
+5 SET Y=$SELECT($DATA(^PSDRUG(I,0)):$EXTRACT($PIECE(^(0),"^"),1,30),1:I)
+6 FOR II=0:0
SET II=$ORDER(^TMP($JOB,DV,0,I,II))
if 'II
QUIT
IF ^TMP($JOB,DV,0,I,II)'<PSMIN
SET ST=999999-^(II)
FOR J=1:1
IF '$DATA(^TMP($JOB,DV,1,ST,Y,J))
SET ^(J)=I_"^"_II
QUIT
End DoDot:1
+7 IF '$ORDER(^TMP($JOB,0))
WRITE !!?30,">>>>> NO DISPENSED DRUGS FOUND <<<<<"
DO HD
GOTO END
+8 SET (DVH,DV)=0
SET II=""
+9 FOR
SET DV=$ORDER(^TMP($JOB,DV))
if 'DV!($DATA(DIRUT))
QUIT
IF $ORDER(^TMP($JOB,+$GET(DV),1,0))
if DVH'=DV
DO HD
FOR ST=0:0
SET ST=$ORDER(^TMP($JOB,DV,1,ST))
if 'ST!($DATA(DIRUT))
QUIT
Begin DoDot:1
+10 FOR J=0:0
SET II=$ORDER(^TMP($JOB,DV,1,ST,II))
if II=""!($DATA(DIRUT))
QUIT
FOR T=0:0
SET T=$ORDER(^TMP($JOB,DV,1,ST,II,T))
if 'T!($DATA(DIRUT))
QUIT
Begin DoDot:2
+11 SET DRG=+^TMP($JOB,DV,1,ST,II,T)
SET QTY=+$PIECE(^(T),"^",2)
if $Y+4>IOSL
DO HD
if $DATA(DIRUT)
QUIT
WRITE !,$JUSTIFY(DRG,5)," ",$SELECT($DATA(^PSDRUG(DRG,0)):$PIECE(^(0),"^"),1:"********"),?52,$JUSTIFY(QTY,12),?64,$JUSTIFY($PIECE(^TMP($JOB,DV,0,DRG,QTY),"^"),7)
SET DVH=DV
End DoDot:2
End DoDot:1
END WRITE !
DO ^%ZISC
KILL T,SDT,IRN,PFT,^TMP($JOB),DIROUT,DTOUT,DUOUT,DIRUT,SDT,ST,EDT,PSMIN,DAT,%DT,G,I,II,J,PSOION,X,Y,ZI,DRG,PG,DIR,DV,QTY
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 KILL PSDT,Y2
QUIT
P1 IF 'PFT
IF $SELECT($PIECE(Y2,"^",2):$PIECE(Y2,"^",2),1:$PIECE(Y,"^",13))'<SDT
IF $SELECT($PIECE(Y2,"^",2):$PIECE(Y2,"^",2),1:$PIECE(Y,"^",13))'>EDT
SET ^TMP($JOB,DV,0,DRG)=$SELECT($DATA(^TMP($JOB,DV,0,DRG)):^(DRG)+1,1:1)
SET ^(Y)=$SELECT($DATA(^(DRG,Y)):^(Y)+1,1:1)
+1 IF PFT
IF $DATA(^PSRX(IRN,1,PFT,0))
IF +^(0)'<SDT
IF +^(0)'>EDT
SET ^TMP($JOB,DV,0,DRG)=$SELECT($DATA(^TMP($JOB,DV,0,DRG)):^(DRG)+1,1:1)
SET ^(Y)=$SELECT($DATA(^(DRG,Y)):^(Y)+1,1:1)
+2 QUIT
HD IF PG
IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
if $DATA(DIRUT)
QUIT
+1 SET PG=PG+1
WRITE @IOF,"MOST COMMONLY DISPENSED DRUGS FROM ",$EXTRACT(SDT,4,5),"-",$EXTRACT(SDT,6,7),"-",$EXTRACT(SDT,2,3)," THRU ",$EXTRACT(EDT,4,5),"-",$EXTRACT(EDT,6,7),"-",$EXTRACT(EDT,2,3),?70,$EXTRACT(DT,4,5),"-",$EXTRACT(DT,6,7),"-",$EXTRACT(DT,2,3)
+2 WRITE !?15,"MINIMUM DRUG COUNT OF "_PSMIN,?70,"Pg: "_PG,!,"ENTRY",!,"NUMBER",?10,"DRUG",?55,"QUANTITY",?68,"FILLS",!
FOR ZI=1:1:80
WRITE "-"
+3 if $GET(DV)
WRITE !,"Division: "_$PIECE(^PS(59,DV,0),"^"),!
QUIT
