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

PSOAMIS.m

Go to the documentation of this file.
  1. PSOAMIS ;BHAM ISC/SAB,BHW - pharmacy amis report ; 04/05/93 12:44
  1. ;;7.0;OUTPATIENT PHARMACY;**158**;DEC 1997
  1. ;
  1. W ! S %DT(0)=-DT,%DT("A")="PRINT AMIS STATS STARTING: " S %DT="EPXA" D ^%DT G:"^"[X END G PSOAMIS:Y<0 S SDT=Y K %DT(0)
  1. EDT W ! S %DT(0)=SDT,%DT("A")="ENDING STATS DATE: " D ^%DT G:"^"[X END S EDT=Y I Y<0 G EDT K %DT
  1. DEV W $C(7),!!,"PRINTOUT MUST BE SENT TO A 132 COLUMNS PRINTER !!",!!
  1. K %ZIS,IOP,ZTSK S %ZIS("B")="",PSOION=ION,%ZIS="QM" D ^%ZIS I POP S IOP=PSOION D ^%ZIS K IOP,PSOION G END
  1. K PSOION
  1. I $D(IO("Q")) S ZTDESC="Option to print the Outpatient AMIS report",ZTRTN="ENQ^PSOAMIS" F G="SDT","EDT" S:$D(@G) ZTSAVE(G)=""
  1. I K IO("Q") D ^%ZTLOAD W:$D(ZTSK) !,"Report Queued !" K G,ZTSAVE,ZTSK,Y,X,%DT G END
  1. ENQ ;START COMPUTATIONS
  1. K ^TMP("PSOAMIS",$J),X
  1. D COM
  1. S PSDATE=SDT-1
  1. F G=0:0 S PSDATE=$O(^PS(59.1,PSDATE)) Q:'PSDATE!(PSDATE>EDT) F I=0:0 S I=$O(^PS(59.1,PSDATE,1,I)) Q:'I D
  1. . S X=^PS(59.1,PSDATE,1,I,0)
  1. . S ^TMP("PSOAMIS",$J,I,PSDATE)=$P(X,"^",2,3)_"^"_$P(X,"^",5)_"^"_$P(X,"^",7)_"^"_$P(X,"^",18)_"^"_$P(X,"^",8,12)_"^"_$P(X,"^",14,17)
  1. . F G=1:1:14 S DAT(I,G)=$P(^TMP("PSOAMIS",$J,I,PSDATE),"^",G)+DAT(I,G),GT(G)=$P(^TMP("PSOAMIS",$J,I,PSDATE),"^",G)+GT(G)
  1. . Q
  1. S GR=0 F DIV=0:0 S DIV=$O(^PS(59,DIV)) Q:'DIV!($D(DIRUT)) D:GR SUB D:'$D(DIRUT) RPT F PSDATE=0:0 S PSDATE=$O(^TMP("PSOAMIS",$J,DIV,PSDATE)) Q:'PSDATE!($D(DIRUT)) D
  1. . S DAT=^TMP("PSOAMIS",$J,DIV,PSDATE) I ($Y+4)>IOSL,$E(IOST)'="C" D RPT
  1. . I ($Y+4)>IOSL,$E(IOST)="C" D DIR Q:$D(DIRUT)
  1. . W !,$E(PSDATE,4,5)_"-"_$E(PSDATE,6,8)_"-"_$E(PSDATE,2,3) D S GR=1,ST=DIV
  1. . . F K=1:1:14 W $J(+$P(DAT,"^",K),8)
  1. . . Q
  1. . Q
  1. G:$G(DIRUT) END D SUB,GR I $Y+4>IOSL,$E(IOST)="C" D DIR Q:$D(DIRUT)
  1. ;
  1. END W ! W:$E(IOST)'["C" @IOF D ^%ZISC
  1. K DTOUT,DUOUT,DIRUT,GR,ST,%DT,G,SDT,EDT,X,Y,POP,^TMP("PSOAMIS",$J),K,PSDATE,I,DAT,G,GT,DIV S:$D(ZTQUEUED) ZTREQ="@"
  1. Q
  1. RPT ; HEADER
  1. U IO W @IOF,!?55,"A M I S R E P O R T",!!?40,"FROM "_$E(SDT,4,5)_"-"_$E(SDT,6,7)_"-"_$E(SDT,2,3),?60,"TO "_$E(EDT,4,5)_"-"_$E(EDT,6,7)_"-"_$E(EDT,2,3)_" DIVISION: "_$P(^PS(59,DIV,0),"^")
  1. W !!,"DATE "
  1. F K=1:1:14 W $J($P("INPAT^SC^A&A^OTHER^NVA^CNTLD^METHA^PAT REQ^FEE^STAFF^NEW^REFILL^WINDOW^MAIL","^",K),8)
  1. W ! F K=1:1:132 W "-"
  1. Q
  1. COM ;COMPILE SUB-TOTALS AND GRAND TOTALS
  1. F DIV=0:0 S DIV=$O(^PS(59,DIV)) Q:'DIV F G=1:1:14 S (DAT(DIV,G),GT(G))=0
  1. Q
  1. SUB ;PRINT SUB TOTALS
  1. W:$Y+4>IOSL&($E(IOST)'["C") @IOF W !?8 F K=1:1:14 W $J("-------",8)
  1. W !,"SUB-TOTALS",!,?8 F K=1:1:14 W:$D(ST) $J(DAT(ST,K),8)
  1. D:$E(IOST)["C"&(DIV) DIR
  1. Q
  1. GR ;PRINT GRAND TOTALS
  1. W:$Y+4>IOSL @IOF W !?8 F K=1:1:14 W $J("-------",8)
  1. W !,"GRAND TOTALS",!,?8 F K=1:1:14 W $J(GT(K),8)
  1. W ! Q
  1. DIR K DIR,DUOUT,DTOUT,DIRUT S DIR(0)="E" D ^DIR K DIR
  1. Q