- 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 Jan 18, 2025@03:25:14 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