- 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 Jan 18, 2025@03:35:21 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