PSOAMIS ;BHAM ISC/SAB,BHW - pharmacy amis report ; 04/05/93 12:44
;;7.0;OUTPATIENT PHARMACY;**158**;DEC 1997
;
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)
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
DEV W $C(7),!!,"PRINTOUT MUST BE SENT TO A 132 COLUMNS PRINTER !!",!!
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
K PSOION
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)=""
I K IO("Q") D ^%ZTLOAD W:$D(ZTSK) !,"Report Queued !" K G,ZTSAVE,ZTSK,Y,X,%DT G END
ENQ ;START COMPUTATIONS
K ^TMP("PSOAMIS",$J),X
D COM
S PSDATE=SDT-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
. S X=^PS(59.1,PSDATE,1,I,0)
. 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)
. 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)
. Q
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
. S DAT=^TMP("PSOAMIS",$J,DIV,PSDATE) I ($Y+4)>IOSL,$E(IOST)'="C" D RPT
. I ($Y+4)>IOSL,$E(IOST)="C" D DIR Q:$D(DIRUT)
. W !,$E(PSDATE,4,5)_"-"_$E(PSDATE,6,8)_"-"_$E(PSDATE,2,3) D S GR=1,ST=DIV
. . F K=1:1:14 W $J(+$P(DAT,"^",K),8)
. . Q
. Q
G:$G(DIRUT) END D SUB,GR I $Y+4>IOSL,$E(IOST)="C" D DIR Q:$D(DIRUT)
;
END W ! W:$E(IOST)'["C" @IOF D ^%ZISC
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="@"
Q
RPT ; HEADER
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),"^")
W !!,"DATE "
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)
W ! F K=1:1:132 W "-"
Q
COM ;COMPILE SUB-TOTALS AND GRAND TOTALS
F DIV=0:0 S DIV=$O(^PS(59,DIV)) Q:'DIV F G=1:1:14 S (DAT(DIV,G),GT(G))=0
Q
SUB ;PRINT SUB TOTALS
W:$Y+4>IOSL&($E(IOST)'["C") @IOF W !?8 F K=1:1:14 W $J("-------",8)
W !,"SUB-TOTALS",!,?8 F K=1:1:14 W:$D(ST) $J(DAT(ST,K),8)
D:$E(IOST)["C"&(DIV) DIR
Q
GR ;PRINT GRAND TOTALS
W:$Y+4>IOSL @IOF W !?8 F K=1:1:14 W $J("-------",8)
W !,"GRAND TOTALS",!,?8 F K=1:1:14 W $J(GT(K),8)
W ! Q
DIR K DIR,DUOUT,DTOUT,DIRUT S DIR(0)="E" D ^DIR K DIR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOAMIS 2746 printed Nov 22, 2024@17:34:05 Page 2
PSOAMIS ;BHAM ISC/SAB,BHW - pharmacy amis report ; 04/05/93 12:44
+1 ;;7.0;OUTPATIENT PHARMACY;**158**;DEC 1997
+2 ;
+3 WRITE !
SET %DT(0)=-DT
SET %DT("A")="PRINT AMIS STATS STARTING: "
SET %DT="EPXA"
DO ^%DT
if "^"[X
GOTO END
if Y<0
GOTO PSOAMIS
SET SDT=Y
KILL %DT(0)
EDT WRITE !
SET %DT(0)=SDT
SET %DT("A")="ENDING STATS DATE: "
DO ^%DT
if "^"[X
GOTO END
SET EDT=Y
IF Y<0
GOTO EDT
KILL %DT
DEV WRITE $CHAR(7),!!,"PRINTOUT MUST BE SENT TO A 132 COLUMNS PRINTER !!",!!
+1 KILL %ZIS,IOP,ZTSK
SET %ZIS("B")=""
SET PSOION=ION
SET %ZIS="QM"
DO ^%ZIS
IF POP
SET IOP=PSOION
DO ^%ZIS
KILL IOP,PSOION
GOTO END
+2 KILL PSOION
+3 IF $DATA(IO("Q"))
SET ZTDESC="Option to print the Outpatient AMIS report"
SET ZTRTN="ENQ^PSOAMIS"
FOR G="SDT","EDT"
if $DATA(@G)
SET ZTSAVE(G)=""
+4 IF $TEST
KILL IO("Q")
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Report Queued !"
KILL G,ZTSAVE,ZTSK,Y,X,%DT
GOTO END
ENQ ;START COMPUTATIONS
+1 KILL ^TMP("PSOAMIS",$JOB),X
+2 DO COM
+3 SET PSDATE=SDT-1
+4 FOR G=0:0
SET PSDATE=$ORDER(^PS(59.1,PSDATE))
if 'PSDATE!(PSDATE>EDT)
QUIT
FOR I=0:0
SET I=$ORDER(^PS(59.1,PSDATE,1,I))
if 'I
QUIT
Begin DoDot:1
+5 SET X=^PS(59.1,PSDATE,1,I,0)
+6 SET ^TMP("PSOAMIS",$JOB,I,PSDATE)=$PIECE(X,"^",2,3)_"^"_$PIECE(X,"^",5)_"^"_$PIECE(X,"^",7)_"^"_$PIECE(X,"^",18)_"^"_$PIECE(X,"^",8,12)_"^"_$PIECE(X,"^",14,17)
+7 FOR G=1:1:14
SET DAT(I,G)=$PIECE(^TMP("PSOAMIS",$JOB,I,PSDATE),"^",G)+DAT(I,G)
SET GT(G)=$PIECE(^TMP("PSOAMIS",$JOB,I,PSDATE),"^",G)+GT(G)
+8 QUIT
End DoDot:1
+9 SET GR=0
FOR DIV=0:0
SET DIV=$ORDER(^PS(59,DIV))
if 'DIV!($DATA(DIRUT))
QUIT
if GR
DO SUB
if '$DATA(DIRUT)
DO RPT
FOR PSDATE=0:0
SET PSDATE=$ORDER(^TMP("PSOAMIS",$JOB,DIV,PSDATE))
if 'PSDATE!($DATA(DIRUT))
QUIT
Begin DoDot:1
+10 SET DAT=^TMP("PSOAMIS",$JOB,DIV,PSDATE)
IF ($Y+4)>IOSL
IF $EXTRACT(IOST)'="C"
DO RPT
+11 IF ($Y+4)>IOSL
IF $EXTRACT(IOST)="C"
DO DIR
if $DATA(DIRUT)
QUIT
+12 WRITE !,$EXTRACT(PSDATE,4,5)_"-"_$EXTRACT(PSDATE,6,8)_"-"_$EXTRACT(PSDATE,2,3)
Begin DoDot:2
+13 FOR K=1:1:14
WRITE $JUSTIFY(+$PIECE(DAT,"^",K),8)
+14 QUIT
End DoDot:2
SET GR=1
SET ST=DIV
+15 QUIT
End DoDot:1
+16 if $GET(DIRUT)
GOTO END
DO SUB
DO GR
IF $Y+4>IOSL
IF $EXTRACT(IOST)="C"
DO DIR
if $DATA(DIRUT)
QUIT
+17 ;
END WRITE !
if $EXTRACT(IOST)'["C"
WRITE @IOF
DO ^%ZISC
+1 KILL DTOUT,DUOUT,DIRUT,GR,ST,%DT,G,SDT,EDT,X,Y,POP,^TMP("PSOAMIS",$JOB),K,PSDATE,I,DAT,G,GT,DIV
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 QUIT
RPT ; HEADER
+1 USE IO
WRITE @IOF,!?55,"A M I S R E P O R T",!!?40,"FROM "_$EXTRACT(SDT,4,5)_"-"_$EXTRACT(SDT,6,7)_"-"_$EXTRACT(SDT,2,3),?60,"TO "_$EXTRACT(EDT,4,5)_"-"_$EXTRACT(EDT,6,7)_"-"_$EXTRACT(EDT,2,3)_" DIVISION: "_$PIECE(^PS(59,DIV,0),"^")
+2 WRITE !!,"DATE "
+3 FOR K=1:1:14
WRITE $JUSTIFY($PIECE("INPAT^SC^A&A^OTHER^NVA^CNTLD^METHA^PAT REQ^FEE^STAFF^NEW^REFILL^WINDOW^MAIL","^",K),8)
+4 WRITE !
FOR K=1:1:132
WRITE "-"
+5 QUIT
COM ;COMPILE SUB-TOTALS AND GRAND TOTALS
+1 FOR DIV=0:0
SET DIV=$ORDER(^PS(59,DIV))
if 'DIV
QUIT
FOR G=1:1:14
SET (DAT(DIV,G),GT(G))=0
+2 QUIT
SUB ;PRINT SUB TOTALS
+1 if $Y+4>IOSL&($EXTRACT(IOST)'["C")
WRITE @IOF
WRITE !?8
FOR K=1:1:14
WRITE $JUSTIFY("-------",8)
+2 WRITE !,"SUB-TOTALS",!,?8
FOR K=1:1:14
if $DATA(ST)
WRITE $JUSTIFY(DAT(ST,K),8)
+3 if $EXTRACT(IOST)["C"&(DIV)
DO DIR
+4 QUIT
GR ;PRINT GRAND TOTALS
+1 if $Y+4>IOSL
WRITE @IOF
WRITE !?8
FOR K=1:1:14
WRITE $JUSTIFY("-------",8)
+2 WRITE !,"GRAND TOTALS",!,?8
FOR K=1:1:14
WRITE $JUSTIFY(GT(K),8)
+3 WRITE !
QUIT
DIR KILL DIR,DUOUT,DTOUT,DIRUT
SET DIR(0)="E"
DO ^DIR
KILL DIR
+1 QUIT
