source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCMOPR.m@ 632

Last change on this file since 632 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 7.4 KB
Line 
1PSOCMOPR ;BHAM ISC/PDW - CMOP CONTROLLED SUBSTANCE RX DISPENSE REPORT ; 05 Nov 1999 9:39 AM
2 ;;7.0;OUTPATIENT PHARMACY;**33,52**;DEC 1997
3 ; External reference to file #550.2 granted by DBIA 2231
4 ; External reference to file #50 granted by DBIA 221
5 Q
6 ;
7S ;ENTRY
8 I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"A Pharmacy Division Must Be Selected!",! G EXIT
9 ; check for multi divisions
10 ;
11 S X=0,I=0 F S I=$O(^PS(59,I)) Q:'I S X=X+1
12 I X<2 S QDIV="A" G CNT1
13 K DIR S DIR(0)="SA^A:All divisions;S:Single division"
14 S DIR("A")="Print for (A)ll or a (S)ingle division? (A/S) "
15 S DIR("B")="S"
16 D ^DIR K DIR
17 G:$D(DIRUT) EXIT
18 S QDIV=Y
19 ; select division if QDIV="S"
20 I QDIV="S" D G:Y'>0 S
21 . K DIC
22 . S DIC(0)="AEQM",DIC=59 D ^DIC
23 . S:+Y QDIV=+Y
24 . K DIC
25CNT1 ;Continue point 1
26 K DIR S DIR(0)="S^1:Sort by Release Date;2:Sort by Drug"
27 S DIR("A")="Select one of the following: "
28 S DIR("B")=1
29 D ^DIR K DIR
30 G:$D(DIRUT) EXIT
31 S QSORT=Y
32DATE ; ask date range
33 K %DT
34 S %DT(0)="-NOW",%DT("A")="Enter Start date: ",%DT="AEPX" D ^%DT
35 G:"^"[$E(X) EXIT
36 S (%DT(0),SCANBDT)=Y
37 S Y=DT X ^DD("DD") S END=Y S %DT("A")="Ending date: ",%DT("B")=END D ^%DT K %DT
38 G:"^"[$E(X) EXIT
39 S SCANEDT=Y D DD^%DT S EDATE=Y
40 S Y=SCANBDT D DD^%DT S BDATE=Y
41 ;
42 W !!,"This report is designed for a 132-column format.",!
43 W !,"It is recommended that this report be queued.",!!
44 ;***
45 K IO("Q"),%ZIS,IOP,ZTSK S %ZIS="Q"
46 D ^%ZIS I POP S IOP=PSOION D ^%ZIS K IOP,PSOION G EXIT
47 K PSOION
48 ; set subscript for ^XTMP storage
49 S PSOJOB=$J_"_"_$P($H,",",2)
50 S PSOSUB="PSO_CMOP_CS"_PSOJOB
51 ; setup queing
52 I $D(IO("Q")) D G EXIT
53 . F X="BDATE","EDATE","QDIV","QSORT","SCANBDT","SCANEDT","PSOSUB" S ZTSAVE(X)=""
54 . S ZTRTN="DEQUEUE^PSOCMOPR",ZTDESC="Report of CMOP CS RX Dispenses"
55 . D ^%ZTLOAD W:$D(ZTSK) !,"Report Queued to Print !!",! K ZTSK,IO("Q")
56 ;
57DEQUEUE ; TASKING RE-ENTRY POINT AND PROCESSING
58 D COMPUTE,PRINT
59 G EXIT
60 Q
61COMPUTE ; Deque point for computing
62 ; store in ^XTMP(PSOSUB, for printing queue
63 K ^XTMP(PSOSUB),PSOQUIT
64 S X1=DT,X2=2 D C^%DTC
65 S ^XTMP(PSOSUB,0)=X_U_DT_"^ Storage for CMOP-CS-RX STATUS DIVISION REPORT"
66 S SCANDT=SCANBDT\1-.1
67 ; Set status catagories
68 ;
69 F S SCANDT=$O(^PSRX("AD",SCANDT)) Q:SCANDT>SCANEDT Q:SCANDT'>0 D
70 . S RX=0 F S RX=$O(^PSRX("AD",SCANDT,RX)) Q:RX'>0 D
71 .. S FILL="" F S FILL=$O(^PSRX("AD",SCANDT,RX,FILL)) Q:FILL="" D RX
72 Q
73RX ; check & gather RX,Fills data
74 ;
75 I '$D(^PSRX(RX,4)) Q ;no CMOP events
76 I '$O(^PSRX(RX,4,0)) Q ; no CMOP events
77 D CMOP ; get CMOP ST - FAC
78 Q:'TRANDA ; no CMOP event for FILL
79 ;
80 ; test for CS category 3,4,5 & C
81 S DRUGDA=$$GET1^DIQ(52,RX,6,"I")
82 S DEA=$$GET1^DIQ(50,DRUGDA,3)
83 I DEA'[3,DEA'[4,DEA'[5 Q
84 ;
85 ; get qty & div & reldt per original or refil
86 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
87 E D
88 . S RXF=^PSRX(RX,1,FILL,0)
89 . S QTY=$P(RXF,U,4),DIVDA=$P(RXF,U,9)
90 . S RELDT=$P(RXF,U,18)
91 . S DIV=$$GET1^DIQ(59,DIVDA,.01)
92 ; test div if QDIV
93 I +QDIV,DIVDA'=QDIV Q
94 ;
95 S:RELDT="" RELDT="Not Released"
96 S DRUG=$$GET1^DIQ(50,DRUGDA,.01) ; get DRG;
97 S PAT=$$GET1^DIQ(52,RX,2) ; get PAT
98 S PATDA=$$GET1^DIQ(52,RX,2,"I")
99 S SSN=$$GET1^DIQ(2,PATDA,.09),SSN="("_$E(SSN,6,9)_")"
100 ;
101 ; store according to sort
102 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
103 E S ^XTMP(PSOSUB,DIV,RELDT,TRANDA)=PAT_U_SSN_U_QTY_U_ST_U_FAC_U_RX_U_FILL_U_DRUG
104 ;
105 Q
106 ;
107CMOP ;loop CMOP event for fill, status, and facility
108 ; sets TRANDA for XTMP subscript
109 S EVTRDA=0,TRANDA=0
110 S (ST,FAC)=""
111 ; loop events : EVTRDA will be the last event for the FILL in question
112 S EVDA=0
113 F S EVDA=$O(^PSRX(RX,4,EVDA)) Q:EVDA'>0 S:FILL=$P(^(EVDA,0),U,3) EVTRDA=EVDA
114 Q:'EVTRDA
115 S EVENT=^PSRX(RX,4,EVTRDA,0)
116 S ST=$P(EVENT,U,4)
117 S ST=$S(ST=0:"T",ST=1:"D",ST=2:"RT",ST=3:"ND",1:"")
118 S TRANDA=$P(EVENT,U,1)
119 S FAC=$$GET1^DIQ(550.2,TRANDA,3)
120 K EVDA,EVTRDA
121 Q
122PRINT ; print entry point
123 K PSOQUIT,PSOPG,DIV
124 S PSOQUIT=0
125 D COLUMN ; set column spacing
126 D PGHDR
127 I $O(^XTMP(PSOSUB,0))="" D G EXIT
128 . W !!,?5,"No Data To Report",!!
129 D:QSORT=1 BYDATE
130 D:QSORT=2 BYDRUG
131 K ^XTMP(PSOSUB)
132 Q
133BYDATE ; print report by release date
134 ;^XTMP(PSOSUB,DIV,SCANDT,TRANDA)=PAT_U_SSN_U_QTY_U_ST_U_FAC_U_RX_U_FILL_U_DRUG
135 S DIV=0 F S DIV=$O(^XTMP(PSOSUB,DIV)) Q:DIV="" Q:$G(PSOQUIT) D
136 . D DIVHDR
137 . S SCANDT=0 F S SCANDT=$O(^XTMP(PSOSUB,DIV,SCANDT)) Q:SCANDT="" Q:$G(PSOQUIT) D
138 .. S TRANDA=0 F S TRANDA=$O(^XTMP(PSOSUB,DIV,SCANDT,TRANDA)) Q:TRANDA'>0 Q:$G(PSOQUIT) D PRTDATE
139 Q
140PRTDATE ; print by date output
141 ;^XTMP(PSOSUB,DIV,SCANDT,TRANDA)=PAT_U_SSN_U_QTY_U_ST_U_FAC_U_RX_U_FILL_U_DRUG
142 S X=^XTMP(PSOSUB,DIV,SCANDT,TRANDA)
143 S PAT=$P(X,U,1),SSN=$P(X,U,2),QTY=$P(X,U,3),ST=$P(X,U,4)
144 S FAC=$P(X,U,5),RX=$P(X,U,6),FILL=$P(X,U,7),DRUG=$P(X,U,8)
145 S (DATE,Y)=SCANDT I +Y D DD^%DT S DATE=Y
146 S PAT=PAT_" "_SSN
147 S RX=$$GET1^DIQ(52,RX,.01)
148 ;
149 D PG Q:$G(PSOQUIT)
150 W !,DATE,?C1,RX_" ("_FILL_")",?C2,PAT,?C3,ST,?C4,FAC,!,DRUG,?C5,"QTY: ",QTY,!
151 Q
152BYDRUG ; pull in & print byDrug
153 ;^XTMP(PSOSUB,DIV,DRUG,SCANDT,TRANDA)=PAT_U_SSN_U_QTY_U_ST_U_FAC_U_RX_U_FILL_U_DRUG
154 S DIV=0 F S DIV=$O(^XTMP(PSOSUB,DIV)) Q:DIV="" Q:$G(PSOQUIT) D
155 . D DIVHDR
156 . S DRUG="" F S DRUG=$O(^XTMP(PSOSUB,DIV,DRUG)) Q:DRUG="" Q:$G(PSOQUIT) D
157 .. W !!,?3,DRUG
158 .. S SCANDT=0 F S SCANDT=$O(^XTMP(PSOSUB,DIV,DRUG,SCANDT)) Q:SCANDT="" Q:$G(PSOQUIT) D
159 ... S TRANDA=0 F S TRANDA=$O(^XTMP(PSOSUB,DIV,DRUG,SCANDT,TRANDA)) Q:TRANDA'>0 Q:$G(PSOQUIT) D PRTDRUG
160 Q
161PRTDRUG ; print by Drug
162 ;^XTMP(PSOSUB,DIV,DRUG,SCANDT,TRANDA)=PAT_U_SSN_U_QTY_U_ST_U_FAC_U_RX_U_FILL_U_DRUG
163 S X=^XTMP(PSOSUB,DIV,DRUG,SCANDT,TRANDA)
164 S PAT=$P(X,U,1),SSN=$P(X,U,2),QTY=$P(X,U,3),ST=$P(X,U,4)
165 S FAC=$P(X,U,5),RX=$P(X,U,6),FILL=$P(X,U,7)
166 S (DATE,Y)=SCANDT I +Y D DD^%DT S DATE=Y
167 S PAT=PAT_" "_SSN,RX=$$GET1^DIQ(52,RX,.01),RX=RX_" ("_FILL_")"
168 D PG Q:$G(PSOQUIT)
169 ;"Release Date",?D1,"Rx#",?D2,"QTY",?D3,"Patient",?D4,"CMOP",?D5,"CMOP
170 W !,DATE,?D1,RX,?D2,QTY,?D3,PAT,?D4,ST,?D5,FAC
171 Q
172EXIT ;EXIT
173 K BDATE,C1,C2,C3,C4,C5,C6,CMOP,D1,D2,D3,D4,D5,DATE,DEA,DIV,DIVDA,DRUG
174 K DRUGDA,EDATE,END,FAC,FIL,FLD,PAT,PATDA,PSOPG,PSOSUB,EVENT,RXF
175 K QDIV,QSORT,QTY,RX,SCANDT,SCANBDT,SCANEDT,SSN,ST,TRANDA,PSOQUIT
176 K FILL,EVDA,PSOJOB,PSOPAR,PSUIOP,PSUFQ,PSURC,PSURP,PSURX,PSUNS,X1,X2
177 D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
178 Q
179PG ;EP Page controller
180 ;S PSOQUIT=0
181 Q:$G(PSOQUIT)
182 I $Y<(IOSL-4) Q
183 I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR I $D(DIRUT) S PSOQUIT=1 Q
184 ;
185PGHDR ; Write Page Header
186 U IO W @IOF
187 S PSOPG("PG")=$G(PSOPG("PG"))+1
188 W !,"CMOP Controlled Substance Prescription Dispensing Report",?(IOM-12),"Page: ",PSOPG("PG")
189 W !,BDATE," through ",EDATE
190 D:$D(DIV) DIVHDR
191 Q
192 ;
193DIVHDR ; write division header
194 S X=DIV_" Division"
195 W !!,?((IOM-$L(X))\2),X,!!
196 I QSORT=1 D
197 . W !,"Release Date",?C1,"Rx#",?C2,"Patient",?C3,"CMOP",?C4,"CMOP"
198 . W !,?C3,"STATUS",?C4,"Facility",! ; RX at C5 QTY AT C6
199 . F X=1:1:IOM-2 W "-"
200 I QSORT=2 D
201 . W !,"Release Date",?D1,"Rx#",?D2,"QTY",?D3,"Patient",?D4,"CMOP",?D5,"CMOP"
202 . W !,?D4,"STATUS",?D5,"Facility",!
203 . F X=1:1:IOM-2 W "-"
204 . I PSOPG("PG")>1,$L($G(DRUG)) W !,?3,DRUG
205 Q
206COLUMN ; setup column spacing
207C1 ; setup column spacing for byDate
208 S C1=23,C2=39,C3=77,C4=85,C5=42
209 ;W !,DATE,?C1,RX_" ("_FILL_")",?C2,PAT,?C3,ST,?C4,FAC,!,DRUG,?C5,"QT: ",QTY
210D1 ; setup column spacing for byDrug
211 ;"Release Date",?D1,"Rx#",?D2,"QTY",?D3,"Patient",?D4,"CMOP",?D5,"CMOP
212 S D1=23,D2=39,D3=53,D4=91,D5=99
213 Q
214CLEAR ; clear ^XTMP
215 S X="PSO_CMOP_",Y=X
216 F S X=$O(^XTMP(X)) Q:X'[Y K ^XTMP(X)
217 Q
Note: See TracBrowser for help on using the repository browser.