Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSORPTS1

PSORPTS1.m

Go to the documentation of this file.
  1. PSORPTS1 ;BHAM ISC/SAB - MOST COMMONLY DISPENSED DRUGS REPORT ; 03/29/93 13:04
  1. ;;7.0;OUTPATIENT PHARMACY;**29,55**;DEC 1997
  1. ;External Ref. to ^PSDRUG is supp. by DBIA# 221
  1. SDT W ! S %DT("A")="STARTING DATE: ",%DT="EXAP" D ^%DT G:"^"[X END G:Y<0 SDT S (%DT(0),SDT)=Y
  1. EDT W ! S %DT("A")="ENDING DATE: ",%DT="EXAP" D ^%DT G:"^"[X END G:Y<0 EDT S EDT=Y K %DT
  1. P0 S DIR("A")="DO NOT PRINT DRUG IF COUNT IS LESS THAN ",DIR("B")=20,DIR(0)="N^1:100:0"
  1. D ^DIR S PSMIN=Y K DIR G:$D(DIRUT) END
  1. 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
  1. K PSOION I $D(IO("Q")) S ZTRTN="RPT^PSORPTS1" F G="SDT","EDT","PSMIN" S:$D(@G) ZTSAVE(G)=""
  1. 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
  1. RPT U IO K ^TMP($J) S PG=0,X="",PSDT=SDT-1,PFT=""
  1. 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
  1. .Q:'$D(^PSRX(IRN,0)) S Y=^PSRX(IRN,0),Y2=$G(^(2))
  1. .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)))
  1. 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
  1. .S Y=$S($D(^PSDRUG(I,0)):$E($P(^(0),"^"),1,30),1:I)
  1. .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
  1. I '$O(^TMP($J,0)) W !!?30,">>>>> NO DISPENSED DRUGS FOUND <<<<<" D HD G END
  1. S (DVH,DV)=0,II=""
  1. 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
  1. .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
  1. ..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
  1. 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="@"
  1. K PSDT,Y2 Q
  1. 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)
  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)
  1. Q
  1. HD I PG,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR Q:$D(DIRUT)
  1. 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)
  1. W !?15,"MINIMUM DRUG COUNT OF "_PSMIN,?70,"Pg: "_PG,!,"ENTRY",!,"NUMBER",?10,"DRUG",?55,"QUANTITY",?68,"FILLS",! F ZI=1:1:80 W "-"
  1. W:$G(DV) !,"Division: "_$P(^PS(59,DV,0),"^"),! Q