- PSOMGMRP ;BHAM ISC/JMB - MONTHLY MANAGEMENT REPORT ; 3/30/93
- ;;7.0;OUTPATIENT PHARMACY;**72**;DEC 1997
- ;External reference ^PS(50.8 supported by DBIA 296
- ;
- BEG G:'$D(RUN) END S SDT=0,SDT=$O(^PS(59.12,"B",SDT)) G:$G(SDT)=""!($L(SDT)'=7) IV
- G:$G(SDT)="" IV S Y=SDT D DD^%DT S PSDT=Y
- IV S OK=$O(^PS(50.8,0)) I '$D(OK)!(OK="") G DISP
- S IVS=0 F IEN=0:0 S IEN=$O(^PS(50.8,IEN)) Q:'IEN!($L(IVS)=7) F IVS=0:0 S IVS=$O(^PS(50.8,IEN,2,IVS)) S:$L(IVS)=7 IVSDT=IVS Q:$L(IVS)=7!('IVS)
- G:$G(IVSDT)="" DISP S Y=IVSDT D DD^%DT S PIVSDT=Y
- DISP K OK W:$G(SDT)'=""&(RUN'=4) !!!!?5,"**Prescription data available to print starts with "_PSDT_".**"
- I ('$D(SDT)!($G(SDT)=""))&(RUN'=4) W !!?13,$C(7),$C(7),"**There is no prescription data available to print.**",!?8,"Use the Date Range Compile data option to make the data available." K EDT,SDT
- W:$D(IVSDT) !!?10,"**IV data available to print starts with "_PIVSDT_".**"
- I '$D(IVSDT) W !!?18,$C(7),$C(7),"**There is no IV data available to print.**" K IVSDT,IVEDT G:RUN=4 END
- I '$D(IVSDT)&('$D(SDT)) W !!,"There is no prescription and IV data available to print." G END
- S DVCNT=0 F DIV=0:0 S DIV=$O(^PS(59,DIV)) Q:'DIV S DVCNT=DVCNT+1,DV=DIV
- I RUN=4 S ANS="A" G PAP
- PRTDV S:DVCNT=1 ANS="S",DIV=DV I DVCNT>1 W !! S DIR("A")="Print data for all or a specific division",DIR(0)="SBO^A:ALL;S:SPECIFIC",DIR("?")="Answer 'A' for all if you want to print all divisions' report." D
- .S DIR("??")="Answer 'S' for specific if you want to print one division's report." D ^DIR K OUT S:$D(DIRUT) OUT=1 K DIR S ANS=Y
- G:$G(OUT) END I ANS="S",DVCNT>1 W ! S DIC("A")="Division: ",DIC=59,DIC(0)="AEMQZ" D ^DIC K DIC G:$D(DTOUT)!($D(DUOUT))!(Y<0) PRTDV S DIV=+Y
- PAP W !!?12,"*** PLEASE PRINT ON WIDE PAPER, I.E., 132 COLUMNS. ***",!
- K BDT,EDT,%DT W !!,"**** Date Range Selection ****" S LATE=$E(DT,1,5)_"00"
- SDT W ! S %DT="APEM",%DT("A")="Beginning MONTH/YEAR : " D ^%DT G:"^"[X!(Y<0) END G:Y'<LATE SDT G:(+$E(Y,6,7)'=0)!(+$E(Y,4,5)=0) SDT
- ;S Y=$E(Y,1,5)_"01" I RUN'=4&(Y<$G(SDT)) W !!,$C(7),"Data available to print starts with "_PSDT_".",! G SDT
- ;I RUN=4&(Y<$G(IVSDT)) W !!,$C(7),"Data available to print starts with "_PIVSDT_".",! G SDT
- S SDT=Y
- EDT S %DT(0)=SDT W ! S %DT="APEM",%DT("A")=" Ending MONTH/YEAR : " D ^%DT K %DT G:"^"[X END G:+$E(Y,6,7)'=0!(+$E(Y,4,5)=0) EDT G:Y<0 END I Y'<LATE W $C(7)," End of month cannot be in the future" G EDT
- W ! S EDT=$E(Y,1,5)_$P("31^29^31^30^31^30^31^31^30^31^30^31","^",$E(Y,4,5))
- S FND=$O(^PS(59.12,SDT)) I RUN'=4,(FND>EDT!(+FND=0)) S Y=$E(SDT,1,5)_"01" X ^DD("DD") S SDATE=Y,Y=EDT X ^DD("DD") S EDATE=Y D G END
- .W !!,?5,$C(7),"There is no prescription data between "_SDATE_" and "_EDATE_".**",!?7,"Use the Date Range Compile option to make the data available.",!,?5,"For IV data, use the Intravenous Admixture option."
- S (QTR,Q1,Q2)=0,SMN=$E(SDT,4,5),EMN=$E(EDT,4,5)
- I SMN=10!(SMN="01")!(SMN="04")!(SMN="07") S EMN=$P("3^^^6^^^9^^^12^","^",SMN),EQTR=$E(SDT,1,3)_EMN_$P("31^29^31^30^31^30^31^31^30^31^30^31","^",EMN) S:EDT'<EQTR QTR=$P("2^^^3^^^4^^^1^","^",SMN)
- S:QTR=1 Q1=10,Q2=12 S:QTR=2 Q1=1,Q2=3 S:QTR=3 Q1=4,Q2=6 S:QTR=4 Q1=7,Q2=9
- QUE K %DT,%ZIS,IOP,ZTSK S PSOION=ION,%ZIS("B")="",%ZIS="QM" D ^%ZIS
- I POP S IOP=PSOION D ^%ZIS U IO K DVCNT,IOP,PSOION W !,$C(7),$C(7),"Report not Queued!" G END
- K DVCNT I $D(IO("Q")) S ZTRTN=$S(RUN="A":"ENQ^PSOMGMN1",RUN=1:"EN^PSOMGMN1",RUN=2:"EN^PSOMGMN2",RUN=3:"EN^PSOMGMN3",1:"EN^PSOMGMN4"),ZTDESC="Outpatient Management Report" F G="SDT","EDT","DIV","ANS","QTR","Q1","Q2","RUN" S:$D(@G) ZTSAVE(G)=""
- I K IO("Q") D ^%ZTLOAD W:$D(ZTSK) !,"Report Queued !" K G,Y,X,%DT G END
- D:RUN="A" ENQ^PSOMGMN1 D:RUN=1 EN^PSOMGMN1 D:RUN=2 EN^PSOMGMN2 D:RUN=3 EN^PSOMGMN3 D:RUN=4 EN^PSOMGMN4
- END D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
- K %,%DT,ANS,BEG,CNT,DIR,DIRUT,DIV,DV,DVMN,DTOUT,DUOUT,EDT,EMN,END,EQTR,G,K,I,IEN,IVE,IVS,LATE,M1,M2,M3,MM,MN,OUT,PG,POP,PRT,PRV,PDATE,PSDT,PIVSDT,PSOION
- K Q1,Q2,QCST,QMREQ,QTCST,QTMREQ,QTR,RUN,SDT,S1,S2,S3,SMN,SUBS,T1,T2,T3,X,Y,ZTDESC,ZTRTN,ZTSAVE,ZTSK
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOMGMRP 4043 printed Feb 18, 2025@23:57:33 Page 2
- PSOMGMRP ;BHAM ISC/JMB - MONTHLY MANAGEMENT REPORT ; 3/30/93
- +1 ;;7.0;OUTPATIENT PHARMACY;**72**;DEC 1997
- +2 ;External reference ^PS(50.8 supported by DBIA 296
- +3 ;
- BEG if '$DATA(RUN)
- GOTO END
- SET SDT=0
- SET SDT=$ORDER(^PS(59.12,"B",SDT))
- if $GET(SDT)=""!($LENGTH(SDT)'=7)
- GOTO IV
- +1 if $GET(SDT)=""
- GOTO IV
- SET Y=SDT
- DO DD^%DT
- SET PSDT=Y
- IV SET OK=$ORDER(^PS(50.8,0))
- IF '$DATA(OK)!(OK="")
- GOTO DISP
- +1 SET IVS=0
- FOR IEN=0:0
- SET IEN=$ORDER(^PS(50.8,IEN))
- if 'IEN!($LENGTH(IVS)=7)
- QUIT
- FOR IVS=0:0
- SET IVS=$ORDER(^PS(50.8,IEN,2,IVS))
- if $LENGTH(IVS)=7
- SET IVSDT=IVS
- if $LENGTH(IVS)=7!('IVS)
- QUIT
- +2 if $GET(IVSDT)=""
- GOTO DISP
- SET Y=IVSDT
- DO DD^%DT
- SET PIVSDT=Y
- DISP KILL OK
- if $GET(SDT)'=""&(RUN'=4)
- WRITE !!!!?5,"**Prescription data available to print starts with "_PSDT_".**"
- +1 IF ('$DATA(SDT)!($GET(SDT)=""))&(RUN'=4)
- WRITE !!?13,$CHAR(7),$CHAR(7),"**There is no prescription data available to print.**",!?8,"Use the Date Range Compile data option to make the data available."
- KILL EDT,SDT
- +2 if $DATA(IVSDT)
- WRITE !!?10,"**IV data available to print starts with "_PIVSDT_".**"
- +3 IF '$DATA(IVSDT)
- WRITE !!?18,$CHAR(7),$CHAR(7),"**There is no IV data available to print.**"
- KILL IVSDT,IVEDT
- if RUN=4
- GOTO END
- +4 IF '$DATA(IVSDT)&('$DATA(SDT))
- WRITE !!,"There is no prescription and IV data available to print."
- GOTO END
- +5 SET DVCNT=0
- FOR DIV=0:0
- SET DIV=$ORDER(^PS(59,DIV))
- if 'DIV
- QUIT
- SET DVCNT=DVCNT+1
- SET DV=DIV
- +6 IF RUN=4
- SET ANS="A"
- GOTO PAP
- PRTDV if DVCNT=1
- SET ANS="S"
- SET DIV=DV
- IF DVCNT>1
- WRITE !!
- SET DIR("A")="Print data for all or a specific division"
- SET DIR(0)="SBO^A:ALL;S:SPECIFIC"
- SET DIR("?")="Answer 'A' for all if you want to print all divisions' report."
- Begin DoDot:1
- +1 SET DIR("??")="Answer 'S' for specific if you want to print one division's report."
- DO ^DIR
- KILL OUT
- if $DATA(DIRUT)
- SET OUT=1
- KILL DIR
- SET ANS=Y
- End DoDot:1
- +2 if $GET(OUT)
- GOTO END
- IF ANS="S"
- IF DVCNT>1
- WRITE !
- SET DIC("A")="Division: "
- SET DIC=59
- SET DIC(0)="AEMQZ"
- DO ^DIC
- KILL DIC
- if $DATA(DTOUT)!($DATA(DUOUT))!(Y<0)
- GOTO PRTDV
- SET DIV=+Y
- PAP WRITE !!?12,"*** PLEASE PRINT ON WIDE PAPER, I.E., 132 COLUMNS. ***",!
- +1 KILL BDT,EDT,%DT
- WRITE !!,"**** Date Range Selection ****"
- SET LATE=$EXTRACT(DT,1,5)_"00"
- SDT WRITE !
- SET %DT="APEM"
- SET %DT("A")="Beginning MONTH/YEAR : "
- DO ^%DT
- if "^"[X!(Y<0)
- GOTO END
- if Y'<LATE
- GOTO SDT
- if (+$EXTRACT(Y,6,7)'=0)!(+$EXTRACT(Y,4,5)=0)
- GOTO SDT
- +1 ;S Y=$E(Y,1,5)_"01" I RUN'=4&(Y<$G(SDT)) W !!,$C(7),"Data available to print starts with "_PSDT_".",! G SDT
- +2 ;I RUN=4&(Y<$G(IVSDT)) W !!,$C(7),"Data available to print starts with "_PIVSDT_".",! G SDT
- +3 SET SDT=Y
- EDT SET %DT(0)=SDT
- WRITE !
- SET %DT="APEM"
- SET %DT("A")=" Ending MONTH/YEAR : "
- DO ^%DT
- KILL %DT
- if "^"[X
- GOTO END
- if +$EXTRACT(Y,6,7)'=0!(+$EXTRACT(Y,4,5)=0)
- GOTO EDT
- if Y<0
- GOTO END
- IF Y'<LATE
- WRITE $CHAR(7)," End of month cannot be in the future"
- GOTO EDT
- +1 WRITE !
- SET EDT=$EXTRACT(Y,1,5)_$PIECE("31^29^31^30^31^30^31^31^30^31^30^31","^",$EXTRACT(Y,4,5))
- +2 SET FND=$ORDER(^PS(59.12,SDT))
- IF RUN'=4
- IF (FND>EDT!(+FND=0))
- SET Y=$EXTRACT(SDT,1,5)_"01"
- XECUTE ^DD("DD")
- SET SDATE=Y
- SET Y=EDT
- XECUTE ^DD("DD")
- SET EDATE=Y
- Begin DoDot:1
- +3 WRITE !!,?5,$CHAR(7),"There is no prescription data between "_SDATE_" and "_EDATE_".**",!?7,"Use the Date Range Compile option to make the data available.",!,?5,"For IV data, use the Intravenous Admixture option."
- End DoDot:1
- GOTO END
- +4 SET (QTR,Q1,Q2)=0
- SET SMN=$EXTRACT(SDT,4,5)
- SET EMN=$EXTRACT(EDT,4,5)
- +5 IF SMN=10!(SMN="01")!(SMN="04")!(SMN="07")
- SET EMN=$PIECE("3^^^6^^^9^^^12^","^",SMN)
- SET EQTR=$EXTRACT(SDT,1,3)_EMN_$PIECE("31^29^31^30^31^30^31^31^30^31^30^31","^",EMN)
- if EDT'<EQTR
- SET QTR=$PIECE("2^^^3^^^4^^^1^","^",SMN)
- +6 if QTR=1
- SET Q1=10
- SET Q2=12
- if QTR=2
- SET Q1=1
- SET Q2=3
- if QTR=3
- SET Q1=4
- SET Q2=6
- if QTR=4
- SET Q1=7
- SET Q2=9
- QUE KILL %DT,%ZIS,IOP,ZTSK
- SET PSOION=ION
- SET %ZIS("B")=""
- SET %ZIS="QM"
- DO ^%ZIS
- +1 IF POP
- SET IOP=PSOION
- DO ^%ZIS
- USE IO
- KILL DVCNT,IOP,PSOION
- WRITE !,$CHAR(7),$CHAR(7),"Report not Queued!"
- GOTO END
- +2 KILL DVCNT
- IF $DATA(IO("Q"))
- SET ZTRTN=$SELECT(RUN="A":"ENQ^PSOMGMN1",RUN=1:"EN^PSOMGMN1",RUN=2:"EN^PSOMGMN2",RUN=3:"EN^PSOMGMN3",1:"EN^PSOMGMN4")
- SET ZTDESC="Outpatient Management Report"
- FOR G="SDT","EDT","DIV","ANS","QTR","Q1","Q2","RUN"
- if $DATA(@G)
- SET ZTSAVE(G)=""
- +3 IF $TEST
- KILL IO("Q")
- DO ^%ZTLOAD
- if $DATA(ZTSK)
- WRITE !,"Report Queued !"
- KILL G,Y,X,%DT
- GOTO END
- +4 if RUN="A"
- DO ENQ^PSOMGMN1
- if RUN=1
- DO EN^PSOMGMN1
- if RUN=2
- DO EN^PSOMGMN2
- if RUN=3
- DO EN^PSOMGMN3
- if RUN=4
- DO EN^PSOMGMN4
- END DO ^%ZISC
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +1 KILL %,%DT,ANS,BEG,CNT,DIR,DIRUT,DIV,DV,DVMN,DTOUT,DUOUT,EDT,EMN,END,EQTR,G,K,I,IEN,IVE,IVS,LATE,M1,M2,M3,MM,MN,OUT,PG,POP,PRT,PRV,PDATE,PSDT,PIVSDT,PSOION
- +2 KILL Q1,Q2,QCST,QMREQ,QTCST,QTMREQ,QTR,RUN,SDT,S1,S2,S3,SMN,SUBS,T1,T2,T3,X,Y,ZTDESC,ZTRTN,ZTSAVE,ZTSK
- +3 QUIT