PSOCMOPR ;BHAM ISC/PDW - CMOP CONTROLLED SUBSTANCE RX DISPENSE REPORT ; 05 Nov 1999 9:39 AM
;;7.0;OUTPATIENT PHARMACY;**33,52**;DEC 1997
; External reference to file #550.2 granted by DBIA 2231
; External reference to file #50 granted by DBIA 221
Q
;
S ;ENTRY
I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"A Pharmacy Division Must Be Selected!",! G EXIT
; check for multi divisions
;
S X=0,I=0 F S I=$O(^PS(59,I)) Q:'I S X=X+1
I X<2 S QDIV="A" G CNT1
K DIR S DIR(0)="SA^A:All divisions;S:Single division"
S DIR("A")="Print for (A)ll or a (S)ingle division? (A/S) "
S DIR("B")="S"
D ^DIR K DIR
G:$D(DIRUT) EXIT
S QDIV=Y
; select division if QDIV="S"
I QDIV="S" D G:Y'>0 S
. K DIC
. S DIC(0)="AEQM",DIC=59 D ^DIC
. S:+Y QDIV=+Y
. K DIC
CNT1 ;Continue point 1
K DIR S DIR(0)="S^1:Sort by Release Date;2:Sort by Drug"
S DIR("A")="Select one of the following: "
S DIR("B")=1
D ^DIR K DIR
G:$D(DIRUT) EXIT
S QSORT=Y
DATE ; ask date range
K %DT
S %DT(0)="-NOW",%DT("A")="Enter Start date: ",%DT="AEPX" D ^%DT
G:"^"[$E(X) EXIT
S (%DT(0),SCANBDT)=Y
S Y=DT X ^DD("DD") S END=Y S %DT("A")="Ending date: ",%DT("B")=END D ^%DT K %DT
G:"^"[$E(X) EXIT
S SCANEDT=Y D DD^%DT S EDATE=Y
S Y=SCANBDT D DD^%DT S BDATE=Y
;
W !!,"This report is designed for a 132-column format.",!
W !,"It is recommended that this report be queued.",!!
;***
K IO("Q"),%ZIS,IOP,ZTSK S %ZIS="Q"
D ^%ZIS I POP S IOP=PSOION D ^%ZIS K IOP,PSOION G EXIT
K PSOION
; set subscript for ^XTMP storage
S PSOJOB=$J_"_"_$P($H,",",2)
S PSOSUB="PSO_CMOP_CS"_PSOJOB
; setup queing
I $D(IO("Q")) D G EXIT
. F X="BDATE","EDATE","QDIV","QSORT","SCANBDT","SCANEDT","PSOSUB" S ZTSAVE(X)=""
. S ZTRTN="DEQUEUE^PSOCMOPR",ZTDESC="Report of CMOP CS RX Dispenses"
. D ^%ZTLOAD W:$D(ZTSK) !,"Report Queued to Print !!",! K ZTSK,IO("Q")
;
DEQUEUE ; TASKING RE-ENTRY POINT AND PROCESSING
D COMPUTE,PRINT
G EXIT
Q
COMPUTE ; Deque point for computing
; store in ^XTMP(PSOSUB, for printing queue
K ^XTMP(PSOSUB),PSOQUIT
S X1=DT,X2=2 D C^%DTC
S ^XTMP(PSOSUB,0)=X_U_DT_"^ Storage for CMOP-CS-RX STATUS DIVISION REPORT"
S SCANDT=SCANBDT\1-.1
; Set status catagories
;
F S SCANDT=$O(^PSRX("AD",SCANDT)) Q:SCANDT>SCANEDT Q:SCANDT'>0 D
. S RX=0 F S RX=$O(^PSRX("AD",SCANDT,RX)) Q:RX'>0 D
.. S FILL="" F S FILL=$O(^PSRX("AD",SCANDT,RX,FILL)) Q:FILL="" D RX
Q
RX ; check & gather RX,Fills data
;
I '$D(^PSRX(RX,4)) Q ;no CMOP events
I '$O(^PSRX(RX,4,0)) Q ; no CMOP events
D CMOP ; get CMOP ST - FAC
Q:'TRANDA ; no CMOP event for FILL
;
; test for CS category 3,4,5 & C
S DRUGDA=$$GET1^DIQ(52,RX,6,"I")
S DEA=$$GET1^DIQ(50,DRUGDA,3)
I DEA'[3,DEA'[4,DEA'[5 Q
;
; get qty & div & reldt per original or refil
I FILL=0 S QTY=$$GET1^DIQ(52,RX,7),DIV=$$GET1^DIQ(52,RX,20),DIVDA=$$GET1^DIQ(52,RX,20,"I") S RELDT=$$GET1^DIQ(52,RX,31,"I") I 1
E D
. S RXF=^PSRX(RX,1,FILL,0)
. S QTY=$P(RXF,U,4),DIVDA=$P(RXF,U,9)
. S RELDT=$P(RXF,U,18)
. S DIV=$$GET1^DIQ(59,DIVDA,.01)
; test div if QDIV
I +QDIV,DIVDA'=QDIV Q
;
S:RELDT="" RELDT="Not Released"
S DRUG=$$GET1^DIQ(50,DRUGDA,.01) ; get DRG;
S PAT=$$GET1^DIQ(52,RX,2) ; get PAT
S PATDA=$$GET1^DIQ(52,RX,2,"I")
S SSN=$$GET1^DIQ(2,PATDA,.09),SSN="("_$E(SSN,6,9)_")"
;
; store according to sort
I QSORT=2 S ^XTMP(PSOSUB,DIV,DRUG,RELDT,TRANDA)=PAT_U_SSN_U_QTY_U_ST_U_FAC_U_RX_U_FILL_U_DRUG
E S ^XTMP(PSOSUB,DIV,RELDT,TRANDA)=PAT_U_SSN_U_QTY_U_ST_U_FAC_U_RX_U_FILL_U_DRUG
;
Q
;
CMOP ;loop CMOP event for fill, status, and facility
; sets TRANDA for XTMP subscript
S EVTRDA=0,TRANDA=0
S (ST,FAC)=""
; loop events : EVTRDA will be the last event for the FILL in question
S EVDA=0
F S EVDA=$O(^PSRX(RX,4,EVDA)) Q:EVDA'>0 S:FILL=$P(^(EVDA,0),U,3) EVTRDA=EVDA
Q:'EVTRDA
S EVENT=^PSRX(RX,4,EVTRDA,0)
S ST=$P(EVENT,U,4)
S ST=$S(ST=0:"T",ST=1:"D",ST=2:"RT",ST=3:"ND",1:"")
S TRANDA=$P(EVENT,U,1)
S FAC=$$GET1^DIQ(550.2,TRANDA,3)
K EVDA,EVTRDA
Q
PRINT ; print entry point
K PSOQUIT,PSOPG,DIV
S PSOQUIT=0
D COLUMN ; set column spacing
D PGHDR
I $O(^XTMP(PSOSUB,0))="" D G EXIT
. W !!,?5,"No Data To Report",!!
D:QSORT=1 BYDATE
D:QSORT=2 BYDRUG
K ^XTMP(PSOSUB)
Q
BYDATE ; print report by release date
;^XTMP(PSOSUB,DIV,SCANDT,TRANDA)=PAT_U_SSN_U_QTY_U_ST_U_FAC_U_RX_U_FILL_U_DRUG
S DIV=0 F S DIV=$O(^XTMP(PSOSUB,DIV)) Q:DIV="" Q:$G(PSOQUIT) D
. D DIVHDR
. S SCANDT=0 F S SCANDT=$O(^XTMP(PSOSUB,DIV,SCANDT)) Q:SCANDT="" Q:$G(PSOQUIT) D
.. S TRANDA=0 F S TRANDA=$O(^XTMP(PSOSUB,DIV,SCANDT,TRANDA)) Q:TRANDA'>0 Q:$G(PSOQUIT) D PRTDATE
Q
PRTDATE ; print by date output
;^XTMP(PSOSUB,DIV,SCANDT,TRANDA)=PAT_U_SSN_U_QTY_U_ST_U_FAC_U_RX_U_FILL_U_DRUG
S X=^XTMP(PSOSUB,DIV,SCANDT,TRANDA)
S PAT=$P(X,U,1),SSN=$P(X,U,2),QTY=$P(X,U,3),ST=$P(X,U,4)
S FAC=$P(X,U,5),RX=$P(X,U,6),FILL=$P(X,U,7),DRUG=$P(X,U,8)
S (DATE,Y)=SCANDT I +Y D DD^%DT S DATE=Y
S PAT=PAT_" "_SSN
S RX=$$GET1^DIQ(52,RX,.01)
;
D PG Q:$G(PSOQUIT)
W !,DATE,?C1,RX_" ("_FILL_")",?C2,PAT,?C3,ST,?C4,FAC,!,DRUG,?C5,"QTY: ",QTY,!
Q
BYDRUG ; pull in & print byDrug
;^XTMP(PSOSUB,DIV,DRUG,SCANDT,TRANDA)=PAT_U_SSN_U_QTY_U_ST_U_FAC_U_RX_U_FILL_U_DRUG
S DIV=0 F S DIV=$O(^XTMP(PSOSUB,DIV)) Q:DIV="" Q:$G(PSOQUIT) D
. D DIVHDR
. S DRUG="" F S DRUG=$O(^XTMP(PSOSUB,DIV,DRUG)) Q:DRUG="" Q:$G(PSOQUIT) D
.. W !!,?3,DRUG
.. S SCANDT=0 F S SCANDT=$O(^XTMP(PSOSUB,DIV,DRUG,SCANDT)) Q:SCANDT="" Q:$G(PSOQUIT) D
... S TRANDA=0 F S TRANDA=$O(^XTMP(PSOSUB,DIV,DRUG,SCANDT,TRANDA)) Q:TRANDA'>0 Q:$G(PSOQUIT) D PRTDRUG
Q
PRTDRUG ; print by Drug
;^XTMP(PSOSUB,DIV,DRUG,SCANDT,TRANDA)=PAT_U_SSN_U_QTY_U_ST_U_FAC_U_RX_U_FILL_U_DRUG
S X=^XTMP(PSOSUB,DIV,DRUG,SCANDT,TRANDA)
S PAT=$P(X,U,1),SSN=$P(X,U,2),QTY=$P(X,U,3),ST=$P(X,U,4)
S FAC=$P(X,U,5),RX=$P(X,U,6),FILL=$P(X,U,7)
S (DATE,Y)=SCANDT I +Y D DD^%DT S DATE=Y
S PAT=PAT_" "_SSN,RX=$$GET1^DIQ(52,RX,.01),RX=RX_" ("_FILL_")"
D PG Q:$G(PSOQUIT)
;"Release Date",?D1,"Rx#",?D2,"QTY",?D3,"Patient",?D4,"CMOP",?D5,"CMOP
W !,DATE,?D1,RX,?D2,QTY,?D3,PAT,?D4,ST,?D5,FAC
Q
EXIT ;EXIT
K BDATE,C1,C2,C3,C4,C5,C6,CMOP,D1,D2,D3,D4,D5,DATE,DEA,DIV,DIVDA,DRUG
K DRUGDA,EDATE,END,FAC,FIL,FLD,PAT,PATDA,PSOPG,PSOSUB,EVENT,RXF
K QDIV,QSORT,QTY,RX,SCANDT,SCANBDT,SCANEDT,SSN,ST,TRANDA,PSOQUIT
K FILL,EVDA,PSOJOB,PSOPAR,PSUIOP,PSUFQ,PSURC,PSURP,PSURX,PSUNS,X1,X2
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
PG ;EP Page controller
;S PSOQUIT=0
Q:$G(PSOQUIT)
I $Y<(IOSL-4) Q
I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR I $D(DIRUT) S PSOQUIT=1 Q
;
PGHDR ; Write Page Header
U IO W @IOF
S PSOPG("PG")=$G(PSOPG("PG"))+1
W !,"CMOP Controlled Substance Prescription Dispensing Report",?(IOM-12),"Page: ",PSOPG("PG")
W !,BDATE," through ",EDATE
D:$D(DIV) DIVHDR
Q
;
DIVHDR ; write division header
S X=DIV_" Division"
W !!,?((IOM-$L(X))\2),X,!!
I QSORT=1 D
. W !,"Release Date",?C1,"Rx#",?C2,"Patient",?C3,"CMOP",?C4,"CMOP"
. W !,?C3,"STATUS",?C4,"Facility",! ; RX at C5 QTY AT C6
. F X=1:1:IOM-2 W "-"
I QSORT=2 D
. W !,"Release Date",?D1,"Rx#",?D2,"QTY",?D3,"Patient",?D4,"CMOP",?D5,"CMOP"
. W !,?D4,"STATUS",?D5,"Facility",!
. F X=1:1:IOM-2 W "-"
. I PSOPG("PG")>1,$L($G(DRUG)) W !,?3,DRUG
Q
COLUMN ; setup column spacing
C1 ; setup column spacing for byDate
S C1=23,C2=39,C3=77,C4=85,C5=42
;W !,DATE,?C1,RX_" ("_FILL_")",?C2,PAT,?C3,ST,?C4,FAC,!,DRUG,?C5,"QT: ",QTY
D1 ; setup column spacing for byDrug
;"Release Date",?D1,"Rx#",?D2,"QTY",?D3,"Patient",?D4,"CMOP",?D5,"CMOP
S D1=23,D2=39,D3=53,D4=91,D5=99
Q
CLEAR ; clear ^XTMP
S X="PSO_CMOP_",Y=X
F S X=$O(^XTMP(X)) Q:X'[Y K ^XTMP(X)
Q
PSOCMOPR ;BHAM ISC/PDW - CMOP CONTROLLED SUBSTANCE RX DISPENSE REPORT ; 05 Nov 1999 9:39 AM
+1 ;;7.0;OUTPATIENT PHARMACY;**33,52**;DEC 1997
+2 ; External reference to file #550.2 granted by DBIA 2231
+3 ; External reference to file #50 granted by DBIA 221
+4 QUIT
+5 ;
S ;ENTRY
+1 IF '$DATA(PSOPAR)
DO ^PSOLSET
IF '$DATA(PSOPAR)
WRITE $CHAR(7),!!,"A Pharmacy Division Must Be Selected!",!
GOTO EXIT
+2 ; check for multi divisions
+3 ;
+4 SET X=0
SET I=0
FOR
SET I=$ORDER(^PS(59,I))
IF 'I
QUIT
SET X=X+1
+5 IF X<2
SET QDIV="A"
GOTO CNT1
+6 KILL DIR
SET DIR(0)="SA^A:All divisions;S:Single division"
+7 SET DIR("A")="Print for (A)ll or a (S)ingle division? (A/S) "
+8 SET DIR("B")="S"
+9 DO ^DIR
KILL DIR
+10 IF $DATA(DIRUT)
GOTO EXIT
+11 SET QDIV=Y
+12 ; select division if QDIV="S"
+13 IF QDIV="S"
Begin DoDot:1
+14 KILL DIC
+15 SET DIC(0)="AEQM"
SET DIC=59
DO ^DIC
+16 IF +Y
SET QDIV=+Y
+17 KILL DIC
End DoDot:1
IF Y'>0
GOTO S
CNT1 ;Continue point 1
+1 KILL DIR
SET DIR(0)="S^1:Sort by Release Date;2:Sort by Drug"
+2 SET DIR("A")="Select one of the following: "
+3 SET DIR("B")=1
+4 DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
GOTO EXIT
+6 SET QSORT=Y
DATE ; ask date range
+1 KILL %DT
+2 SET %DT(0)="-NOW"
SET %DT("A")="Enter Start date: "
SET %DT="AEPX"
DO ^%DT
+3 IF "^"[$EXTRACT(X)
GOTO EXIT
+4 SET (%DT(0),SCANBDT)=Y
+5 SET Y=DT
XECUTE ^DD("DD")
SET END=Y
SET %DT("A")="Ending date: "
SET %DT("B")=END
DO ^%DT
KILL %DT
+6 IF "^"[$EXTRACT(X)
GOTO EXIT
+7 SET SCANEDT=Y
DO DD^%DT
SET EDATE=Y
+8 SET Y=SCANBDT
DO DD^%DT
SET BDATE=Y
+9 ;
+10 WRITE !!,"This report is designed for a 132-column format.",!
+11 WRITE !,"It is recommended that this report be queued.",!!
+12 ;***
+13 KILL IO("Q"),%ZIS,IOP,ZTSK
SET %ZIS="Q"
+14 DO ^%ZIS
IF POP
SET IOP=PSOION
DO ^%ZIS
KILL IOP,PSOION
GOTO EXIT
+15 KILL PSOION
+16 ; set subscript for ^XTMP storage
+17 SET PSOJOB=$JOB_"_"_$PIECE($HOROLOG,",",2)
+18 SET PSOSUB="PSO_CMOP_CS"_PSOJOB
+19 ; setup queing
+20 IF $DATA(IO("Q"))
Begin DoDot:1
+21 FOR X="BDATE","EDATE","QDIV","QSORT","SCANBDT","SCANEDT","PSOSUB"
SET ZTSAVE(X)=""
+22 SET ZTRTN="DEQUEUE^PSOCMOPR"
SET ZTDESC="Report of CMOP CS RX Dispenses"
+23 DO ^%ZTLOAD
IF $DATA(ZTSK)
WRITE !,"Report Queued to Print !!",!
KILL ZTSK,IO("Q")
End DoDot:1
GOTO EXIT
+24 ;
DEQUEUE ; TASKING RE-ENTRY POINT AND PROCESSING
+1 DO COMPUTE
DO PRINT
+2 GOTO EXIT
+3 QUIT
COMPUTE ; Deque point for computing
+1 ; store in ^XTMP(PSOSUB, for printing queue
+2 KILL ^XTMP(PSOSUB),PSOQUIT
+3 SET X1=DT
SET X2=2
DO C^%DTC
+4 SET ^XTMP(PSOSUB,0)=X_U_DT_"^ Storage for CMOP-CS-RX STATUS DIVISION REPORT"
+5 SET SCANDT=SCANBDT\1-.1
+6 ; Set status catagories
+7 ;
+8 FOR
SET SCANDT=$ORDER(^PSRX("AD",SCANDT))
IF SCANDT>SCANEDT
QUIT
IF SCANDT'>0
QUIT
Begin DoDot:1
+9 SET RX=0
FOR
SET RX=$ORDER(^PSRX("AD",SCANDT,RX))
IF RX'>0
QUIT
Begin DoDot:2
+10 SET FILL=""
FOR
SET FILL=$ORDER(^PSRX("AD",SCANDT,RX,FILL))
IF FILL=""
QUIT
DO RX
End DoDot:2
End DoDot:1
+11 QUIT
RX ; check & gather RX,Fills data
+1 ;
+2 ;no CMOP events
IF '$DATA(^PSRX(RX,4))
QUIT
+3 ; no CMOP events
IF '$ORDER(^PSRX(RX,4,0))
QUIT
+4 ; get CMOP ST - FAC
DO CMOP
+5 ; no CMOP event for FILL
IF 'TRANDA
QUIT
+6 ;
+7 ; test for CS category 3,4,5 & C
+8 SET DRUGDA=$$GET1^DIQ(52,RX,6,"I")
+9 SET DEA=$$GET1^DIQ(50,DRUGDA,3)
+10 IF DEA'[3
IF DEA'[4
IF DEA'[5
QUIT
+11 ;
+12 ; get qty & div & reldt per original or refil
+13 IF FILL=0
SET QTY=$$GET1^DIQ(52,RX,7)
SET DIV=$$GET1^DIQ(52,RX,20)
SET DIVDA=$$GET1^DIQ(52,RX,20,"I")
SET RELDT=$$GET1^DIQ(52,RX,31,"I")
IF 1
+14 IF '$TEST
Begin DoDot:1
+15 SET RXF=^PSRX(RX,1,FILL,0)
+16 SET QTY=$PIECE(RXF,U,4)
SET DIVDA=$PIECE(RXF,U,9)
+17 SET RELDT=$PIECE(RXF,U,18)
+18 SET DIV=$$GET1^DIQ(59,DIVDA,.01)
End DoDot:1
+19 ; test div if QDIV
+20 IF +QDIV
IF DIVDA'=QDIV
QUIT
+21 ;
+22 IF RELDT=""
SET RELDT="Not Released"
+23 ; get DRG;
SET DRUG=$$GET1^DIQ(50,DRUGDA,.01)
+24 ; get PAT
SET PAT=$$GET1^DIQ(52,RX,2)
+25 SET PATDA=$$GET1^DIQ(52,RX,2,"I")
+26 SET SSN=$$GET1^DIQ(2,PATDA,.09)
SET SSN="("_$EXTRACT(SSN,6,9)_")"
+27 ;
+28 ; store according to sort
+29 IF QSORT=2
SET ^XTMP(PSOSUB,DIV,DRUG,RELDT,TRANDA)=PAT_U_SSN_U_QTY_U_ST_U_FAC_U_RX_U_FILL_U_DRUG
+30 IF '$TEST
SET ^XTMP(PSOSUB,DIV,RELDT,TRANDA)=PAT_U_SSN_U_QTY_U_ST_U_FAC_U_RX_U_FILL_U_DRUG
+31 ;
+32 QUIT
+33 ;
CMOP ;loop CMOP event for fill, status, and facility
+1 ; sets TRANDA for XTMP subscript
+2 SET EVTRDA=0
SET TRANDA=0
+3 SET (ST,FAC)=""
+4 ; loop events : EVTRDA will be the last event for the FILL in question
+5 SET EVDA=0
+6 FOR
SET EVDA=$ORDER(^PSRX(RX,4,EVDA))
IF EVDA'>0
QUIT
IF FILL=$PIECE(^(EVDA,0),U,3)
SET EVTRDA=EVDA
+7 IF 'EVTRDA
QUIT
+8 SET EVENT=^PSRX(RX,4,EVTRDA,0)
+9 SET ST=$PIECE(EVENT,U,4)
+10 SET ST=$SELECT(ST=0:"T",ST=1:"D",ST=2:"RT",ST=3:"ND",1:"")
+11 SET TRANDA=$PIECE(EVENT,U,1)
+12 SET FAC=$$GET1^DIQ(550.2,TRANDA,3)
+13 KILL EVDA,EVTRDA
+14 QUIT
PRINT ; print entry point
+1 KILL PSOQUIT,PSOPG,DIV
+2 SET PSOQUIT=0
+3 ; set column spacing
DO COLUMN
+4 DO PGHDR
+5 IF $ORDER(^XTMP(PSOSUB,0))=""
Begin DoDot:1
+6 WRITE !!,?5,"No Data To Report",!!
End DoDot:1
GOTO EXIT
+7 IF QSORT=1
DO BYDATE
+8 IF QSORT=2
DO BYDRUG
+9 KILL ^XTMP(PSOSUB)
+10 QUIT
BYDATE ; print report by release date
+1 ;^XTMP(PSOSUB,DIV,SCANDT,TRANDA)=PAT_U_SSN_U_QTY_U_ST_U_FAC_U_RX_U_FILL_U_DRUG
+2 SET DIV=0
FOR
SET DIV=$ORDER(^XTMP(PSOSUB,DIV))
IF DIV=""
QUIT
IF $GET(PSOQUIT)
QUIT
Begin DoDot:1
+3 DO DIVHDR
+4 SET SCANDT=0
FOR
SET SCANDT=$ORDER(^XTMP(PSOSUB,DIV,SCANDT))
IF SCANDT=""
QUIT
IF $GET(PSOQUIT)
QUIT
Begin DoDot:2
+5 SET TRANDA=0
FOR
SET TRANDA=$ORDER(^XTMP(PSOSUB,DIV,SCANDT,TRANDA))
IF TRANDA'>0
QUIT
IF $GET(PSOQUIT)
QUIT
DO PRTDATE
End DoDot:2
End DoDot:1
+6 QUIT
PRTDATE ; print by date output
+1 ;^XTMP(PSOSUB,DIV,SCANDT,TRANDA)=PAT_U_SSN_U_QTY_U_ST_U_FAC_U_RX_U_FILL_U_DRUG
+2 SET X=^XTMP(PSOSUB,DIV,SCANDT,TRANDA)
+3 SET PAT=$PIECE(X,U,1)
SET SSN=$PIECE(X,U,2)
SET QTY=$PIECE(X,U,3)
SET ST=$PIECE(X,U,4)
+4 SET FAC=$PIECE(X,U,5)
SET RX=$PIECE(X,U,6)
SET FILL=$PIECE(X,U,7)
SET DRUG=$PIECE(X,U,8)
+5 SET (DATE,Y)=SCANDT
IF +Y
DO DD^%DT
SET DATE=Y
+6 SET PAT=PAT_" "_SSN
+7 SET RX=$$GET1^DIQ(52,RX,.01)
+8 ;
+9 DO PG
IF $GET(PSOQUIT)
QUIT
+10 WRITE !,DATE,?C1,RX_" ("_FILL_")",?C2,PAT,?C3,ST,?C4,FAC,!,DRUG,?C5,"QTY: ",QTY,!
+11 QUIT
BYDRUG ; pull in & print byDrug
+1 ;^XTMP(PSOSUB,DIV,DRUG,SCANDT,TRANDA)=PAT_U_SSN_U_QTY_U_ST_U_FAC_U_RX_U_FILL_U_DRUG
+2 SET DIV=0
FOR
SET DIV=$ORDER(^XTMP(PSOSUB,DIV))
IF DIV=""
QUIT
IF $GET(PSOQUIT)
QUIT
Begin DoDot:1
+3 DO DIVHDR
+4 SET DRUG=""
FOR
SET DRUG=$ORDER(^XTMP(PSOSUB,DIV,DRUG))
IF DRUG=""
QUIT
IF $GET(PSOQUIT)
QUIT
Begin DoDot:2
+5 WRITE !!,?3,DRUG
+6 SET SCANDT=0
FOR
SET SCANDT=$ORDER(^XTMP(PSOSUB,DIV,DRUG,SCANDT))
IF SCANDT=""
QUIT
IF $GET(PSOQUIT)
QUIT
Begin DoDot:3
+7 SET TRANDA=0
FOR
SET TRANDA=$ORDER(^XTMP(PSOSUB,DIV,DRUG,SCANDT,TRANDA))
IF TRANDA'>0
QUIT
IF $GET(PSOQUIT)
QUIT
DO PRTDRUG
End DoDot:3
End DoDot:2
End DoDot:1
+8 QUIT
PRTDRUG ; print by Drug
+1 ;^XTMP(PSOSUB,DIV,DRUG,SCANDT,TRANDA)=PAT_U_SSN_U_QTY_U_ST_U_FAC_U_RX_U_FILL_U_DRUG
+2 SET X=^XTMP(PSOSUB,DIV,DRUG,SCANDT,TRANDA)
+3 SET PAT=$PIECE(X,U,1)
SET SSN=$PIECE(X,U,2)
SET QTY=$PIECE(X,U,3)
SET ST=$PIECE(X,U,4)
+4 SET FAC=$PIECE(X,U,5)
SET RX=$PIECE(X,U,6)
SET FILL=$PIECE(X,U,7)
+5 SET (DATE,Y)=SCANDT
IF +Y
DO DD^%DT
SET DATE=Y
+6 SET PAT=PAT_" "_SSN
SET RX=$$GET1^DIQ(52,RX,.01)
SET RX=RX_" ("_FILL_")"
+7 DO PG
IF $GET(PSOQUIT)
QUIT
+8 ;"Release Date",?D1,"Rx#",?D2,"QTY",?D3,"Patient",?D4,"CMOP",?D5,"CMOP
+9 WRITE !,DATE,?D1,RX,?D2,QTY,?D3,PAT,?D4,ST,?D5,FAC
+10 QUIT
EXIT ;EXIT
+1 KILL BDATE,C1,C2,C3,C4,C5,C6,CMOP,D1,D2,D3,D4,D5,DATE,DEA,DIV,DIVDA,DRUG
+2 KILL DRUGDA,EDATE,END,FAC,FIL,FLD,PAT,PATDA,PSOPG,PSOSUB,EVENT,RXF
+3 KILL QDIV,QSORT,QTY,RX,SCANDT,SCANBDT,SCANEDT,SSN,ST,TRANDA,PSOQUIT
+4 KILL FILL,EVDA,PSOJOB,PSOPAR,PSUIOP,PSUFQ,PSURC,PSURP,PSURX,PSUNS,X1,X2
+5 DO ^%ZISC
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+6 QUIT
PG ;EP Page controller
+1 ;S PSOQUIT=0
+2 IF $GET(PSOQUIT)
QUIT
+3 IF $Y<(IOSL-4)
QUIT
+4 IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
IF $DATA(DIRUT)
SET PSOQUIT=1
QUIT
+5 ;
PGHDR ; Write Page Header
+1 USE IO
WRITE @IOF
+2 SET PSOPG("PG")=$GET(PSOPG("PG"))+1
+3 WRITE !,"CMOP Controlled Substance Prescription Dispensing Report",?(IOM-12),"Page: ",PSOPG("PG")
+4 WRITE !,BDATE," through ",EDATE
+5 IF $DATA(DIV)
DO DIVHDR
+6 QUIT
+7 ;
DIVHDR ; write division header
+1 SET X=DIV_" Division"
+2 WRITE !!,?((IOM-$LENGTH(X))\2),X,!!
+3 IF QSORT=1
Begin DoDot:1
+4 WRITE !,"Release Date",?C1,"Rx#",?C2,"Patient",?C3,"CMOP",?C4,"CMOP"
+5 ; RX at C5 QTY AT C6
WRITE !,?C3,"STATUS",?C4,"Facility",!
+6 FOR X=1:1:IOM-2
WRITE "-"
End DoDot:1
+7 IF QSORT=2
Begin DoDot:1
+8 WRITE !,"Release Date",?D1,"Rx#",?D2,"QTY",?D3,"Patient",?D4,"CMOP",?D5,"CMOP"
+9 WRITE !,?D4,"STATUS",?D5,"Facility",!
+10 FOR X=1:1:IOM-2
WRITE "-"
+11 IF PSOPG("PG")>1
IF $LENGTH($GET(DRUG))
WRITE !,?3,DRUG
End DoDot:1
+12 QUIT
COLUMN ; setup column spacing
C1 ; setup column spacing for byDate
+1 SET C1=23
SET C2=39
SET C3=77
SET C4=85
SET C5=42
+2 ;W !,DATE,?C1,RX_" ("_FILL_")",?C2,PAT,?C3,ST,?C4,FAC,!,DRUG,?C5,"QT: ",QTY
D1 ; setup column spacing for byDrug
+1 ;"Release Date",?D1,"Rx#",?D2,"QTY",?D3,"Patient",?D4,"CMOP",?D5,"CMOP
+2 SET D1=23
SET D2=39
SET D3=53
SET D4=91
SET D5=99
+3 QUIT
CLEAR ; clear ^XTMP
+1 SET X="PSO_CMOP_"
SET Y=X
+2 FOR
SET X=$ORDER(^XTMP(X))
IF X'[Y
QUIT
KILL ^XTMP(X)
+3 QUIT
