source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOREJP2.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 7.9 KB
Line 
1PSOREJP2 ;BIRM/MFR - Third Party Rejects View/Process ;04/28/05
2 ;;7.0;OUTPATIENT PHARMACY;**148,247,260**;DEC 1997;Build 84
3 ;Reference to ^PSSLOCK supported by IA #2789
4 ;
5 N PSORJSRT,PSOPTFLT,PSODRFLT,PSORXFLT,PSOBYFLD,PSOSTFLT,DIR,DIRUT,DUOUT,DTOUT
6 N PSOINFLT,PSODTRNG,PSOINGRP
7 S PSORJASC=1,PSOINGRP=0
8 ;
9 ; - Division/Site selection
10 D SEL^PSOREJU1("DIVISION","^PS(59,",.PSOREJST,$$GET1^DIQ(59,+$G(PSOSITE),.01)) I $G(PSOREJST)="^" G EXIT
11 ;
12 ; - Date range selection
13 W ! S PSODTRNG=$$DTRNG("T-90","T") I PSODTRNG="^" G EXIT
14 ;
15SEL ; - Field Selection (Patient/Drug/Rx)
16 S DIR(0)="S^P:PATIENT;D:DRUG;R:Rx;I:INSURANCE",DIR("B")="P"
17 S DIR("A")="By (P)atient, (D)rug, (R)x or (I)nsurance" D ^DIR I $D(DIRUT) G EXIT
18 S PSOBYFLD=Y,DIR("B")=""
19 ;
20 I PSOBYFLD="P" D I $G(PSOPTFLT)="^" G SEL
21 . S (PSODRFLT,PSORXFLT,PSOINFLT)="ALL",PSORJSRT="DR"
22 . D SEL^PSOREJU1("PATIENT","^DPT(",.PSOPTFLT)
23 ;
24 I PSOBYFLD="D" D I $G(PSODRFLT)="^" G SEL
25 . S (PSOPTFLT,PSORXFLT,PSOINFLT)="ALL",PSORJSRT="PA"
26 . D SEL^PSOREJU1("DRUG","^PSDRUG(",.PSODRFLT)
27 ;
28 I PSOBYFLD="R" D I $D(DUOUT)!$D(DTOUT)!'$G(PSORXFLT) G SEL
29 . S (PSOPTFLT,PSODRFLT,PSOINFLT)="ALL",PSORJSRT="PA"
30 . N DIC,Y,X,OK K PSOSTFLT,PSORXFLT
31 . S DIC=52,DIC(0)="QEZA",DIC("A")="PRESCRIPTION: "
32 . F W ! D ^DIC D Q:$G(OK)
33 . . I $D(DUOUT)!$D(DTOUT)!(X="") S OK=1 Q
34 . . I '$O(^PSRX(+Y,"REJ",0)) D Q
35 . . . W !?40,"Prescription does not have rejects!",$C(7)
36 . . S PSORXFLT=+Y,OK=1
37 ;
38 I PSOBYFLD="I" D I $O(PSOINFLT(""))="" G SEL
39 . S (PSOPTFLT,PSODRFLT,PSORXFLT)="ALL",PSORJSRT="PA"
40 . N DIR,Y,X,OK K PSOINFLT W !
41 . S DIR("A",1)="Enter the whole or part of the Insurance Company"
42 . S DIR("A",2)="name for which you want to view/process REJECTS."
43 . S DIR("A",3)=""
44 . S DIR(0)="FO^3:30",DIR("A")=" INSURANCE"
45 . F D ^DIR D Q:$G(OK)
46 . . I $D(DIRUT)!(X="") S OK=1 Q
47 . . S PSOINFLT(X)="" K DIR("A") S DIR("A")="ANOTHER ONE"
48 ;
49 ; - Status Selection (UNRESOLVED or RESOLVED)
50 I $G(PSOSTFLT)="" D I $D(DIRUT) G EXIT
51 . S DIR(0)="S^U:UNRESOLVED;R:RESOLVED;B:BOTH",DIR("B")="B"
52 . S DIR("A")="(U)NRESOLVED, (R)RESOLVED or (B)OTH REJECT statuses" D ^DIR
53 . S PSOSTFLT=Y
54 ;
55 D LST^PSOREJP0("VP")
56 ;
57EXIT Q
58 ;
59CLO ; - Ignore a REJECT hidden action
60 I $$CLOSED^PSOREJP1(RX,REJ) D Q
61 . S VALMSG="This Reject is marked resolved!",VALMBCK="R"
62 N DIR,COM
63 D FULL^VALM1
64 I '$$SIG^PSOREJU1() S VALMBCK="R" Q
65 W !
66 S COM=$$COM^PSOREJU1() I COM="^" S VALMBCK="R" Q
67 W !
68 S DIR(0)="Y",DIR("A")=" Confirm? ",DIR("B")="NO"
69 S DIR("A",1)=" When you confirm this REJECT will be marked RESOLVED."
70 S DIR("A",2)=" "
71 D ^DIR I $G(Y)=0!$D(DIRUT) S VALMBCK="R" Q
72 W ?40,"[Closing..." D CLOSE^PSOREJUT(RX,FILL,REJ,DUZ,6,COM) W "OK]",!,$C(7) H 1
73 I $D(PSOSTFLT),PSOSTFLT'="B" S CHANGE=1
74 ;
75 I $$PTLBL(RX,FILL) D PRINT^PSOREJP1(RX,FILL)
76 ;
77 Q
78 ;
79OPN ; - Re-open a Closed/Resolved Reject
80 I '$$CLOSED^PSOREJP1(RX,REJ) D Q
81 . S VALMSG="This Reject is NOT marked resolved!",VALMBCK="R"
82 N DIR,COM,REJDATA,NEWDATA,X
83 D FULL^VALM1
84 I '$$SIG^PSOREJU1() S VALMBCK="R" Q
85 W !
86 S DIR(0)="Y",DIR("A")=" Confirm",DIR("B")="NO"
87 S DIR("A",1)=" When you confirm this REJECT will be marked UNRESOLVED."
88 S DIR("A",2)=" "
89 D ^DIR I $G(Y)=0!$D(DIRUT) S VALMBCK="R" Q
90 ;
91 W ?40,"[Re-opening..."
92 K REJDATA D GET^PSOREJU2(RX,FILL,.REJDATA,REJ,1) D SETOPN^PSOREJU2(RX,REJ)
93 K NEWDATA M NEWDATA=REJDATA(REJ) S NEWDATA("PHARMACIST")=DUZ
94 D SAVE^PSOREJUT(RX,FILL,.NEWDATA)
95 I $G(NEWDATA("REJECT IEN")),$D(REJDATA(REJ,"COMMENTS")) D
96 . S COM=0 F S COM=$O(REJDATA(REJ,"COMMENTS",COM)) Q:'COM D
97 . . S X(1)=REJDATA(REJ,"COMMENTS",COM,"COMMENTS")
98 . . S X(2)=REJDATA(REJ,"COMMENTS",COM,"DATE/TIME")
99 . . S X(3)=REJDATA(REJ,"COMMENTS",COM,"USER")
100 . . D SAVECOM^PSOREJP3(RX,NEWDATA("REJECT IEN"),X(1),X(2),X(3))
101 D RETRXF^PSOREJU2(RX,FILL,0)
102 W "OK]",!,$C(7) H 1
103 S CHANGE=1
104 Q
105 ;
106CHG ; - Change Suspense Date action
107 I $$CLOSED^PSOREJP1(RX,REJ) D Q
108 . S VALMSG="This Reject is marked resolved!",VALMBCK="R" W $C(7)
109 ;
110 N SUSDT,PSOMSG,Y,SUSRX,%DT,DA,DIE,DR,ISSDT,EXPDT,PSOMSG
111 ;
112 S RFL=+$$GET1^DIQ(52.25,REJ_","_RX,5),SUSDT=$$RXSUDT^PSOBPSUT(RX,RFL)
113 I SUSDT="" S VALMSG="Prescription is not suspended!",VALMBCK="R" W $C(7) Q
114 I $$RXRLDT^PSOBPSUT(RX,RFL) S VALMSG="Prescription has been released already!",VALMBCK="R" W $C(7) Q
115 D PSOL^PSSLOCK(RX) I '$G(PSOMSG) S VALMSG=$P(PSOMSG,"^",2),VALMBCK="R" W $C(7) Q
116 ;
117 S ISSDT=$$GET1^DIQ(52,RX,1,"I"),EXPDT=$$GET1^DIQ(52,RX,26,"I")
118 S SUSRX=$O(^PS(52.5,"B",RX,0))
119 ;
120SUDT ; Asks for the new Suspense Date
121 D FULL^VALM1 S %DT("B")=$$FMTE^XLFDT(SUSDT),%DT="EA",%DT("A")="SUSPENSE DATE: "
122 W ! D ^%DT I Y<0!($D(DTOUT)) D PSOUL^PSSLOCK(RX) S VALMBCK="R" Q
123 I Y<ISSDT D G SUDT
124 . W !!?5,"Suspense Date cannot be before Issue Date: ",$$FMTE^XLFDT(ISSDT),$C(7)
125 I Y>EXPDT D G SUDT
126 . W !!?5,"Suspense Date cannot be after Expiration Date: ",$$FMTE^XLFDT(EXPDT),$C(7)
127 S SUSDT=Y
128 ;
129 N DIR,DIRUT W !
130 S DIR("A",1)=" When you confirm, this REJECT will be marked resolved. A"
131 S DIR("A",2)=" new claim will be re-submitted to the 3rd party payer"
132 I $$GET1^DIQ(52.5,SUSRX,3)="" D
133 . I SUSDT>DT D
134 . . S DIR("A",3)=" when the prescription label for this fill is printed"
135 . . S DIR("A",4)=" from suspense on "_$$FMTE^XLFDT(SUSDT)_"."
136 . . S DIR("A",5)=" "
137 . . S DIR("A",6)=" Note: THE LABEL FOR THIS PRESCRIPTION FILL WILL NOT BE"
138 . . S DIR("A",7)=" PRINTED LOCAL FROM SUSPENSE BEFORE "_$$FMTE^XLFDT(SUSDT)_"."
139 . E D
140 . . S DIR("A",3)=" the next time local labels are printed from suspense."
141 E D
142 . I SUSDT>DT D
143 . . S DIR("A",3)=" when the prescription is transmitted to CMOP on "
144 . . S DIR("A",4)=" "_$$FMTE^XLFDT(SUSDT)_"."
145 . . S DIR("A",5)=" "
146 . . S DIR("A",6)=" Note: THIS PRESCRIPTION FILL WILL NOT BE TRANSMITTED TO"
147 . . S DIR("A",7)=" CMOP BEFORE "_$$FMTE^XLFDT(SUSDT)_"."
148 . E D
149 . . S DIR("A",3)=" when this prescription fill is transmitted to CMOP on"
150 . . S DIR("A",4)=" the next CMOP transmission."
151 ;
152 S DIR("A",$O(DIR("A",""),-1)+1)=" "
153 S DIR(0)="Y",DIR("A")=" Confirm? ",DIR("B")="YES"
154 D ^DIR I $G(Y)=0!$D(DIRUT) S VALMBCK="R" D PSOUL^PSSLOCK(RX) Q
155 ;
156 ; - Suspense/Fill Date updates
157 I SUSDT'=$$RXSUDT^PSOBPSUT(RX,RFL) D
158 . N DA,DIE,DR,PSOX,SFN,INDT,DEAD
159 . S DA=SUSRX,DIE="^PS(52.5,",DR=".02///"_SUSDT D ^DIE
160 . S SFN=SUSRX,DEAD=0,INDT=SUSDT D CHANGE^PSOSUCH1(RX,RFL)
161 ;
162 ; - Flagging the prescription to be re-submitted to ECME on the next CMOP/Print from Suspense
163 D RETRXF^PSOREJU2(RX,RFL,1)
164 W ?40,"[Closing..."
165 D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,8,"Fill Date changed to "_$$FMTE^XLFDT(SUSDT)_". A new claim will be re-submitted on this date.")
166 W "OK]",!,$C(7) H 1 I $D(PSOSTFLT),PSOSTFLT'="B" S CHANGE=1
167 D PSOUL^PSSLOCK(RX)
168 Q
169 ;
170PTLBL(RX,RFL) ; Returns whether the user should be prompted for 'Print Label?' or not
171 N PTLBL,CMP,LBL
172 I $$FIND^PSOREJUT(RX,RFL) Q 0 ; Has OPEN/UNRESOLVED 3rd pary payer reject
173 I $$GET1^DIQ(52,RX,100,"I") Q 0 ; Rx status not ACTIVE
174 I $$RXRLDT^PSOBPSUT(RX,RFL) Q 0 ; Rx Released
175 ; - CMOP Rx fill?
176 S PTLBL=1,CMP=0
177 F S CMP=$O(^PSRX(RX,4,CMP)) Q:'CMP D Q:'PTLBL
178 . I +$$GET1^DIQ(52.01,CMP_","_RX,2,"I")=RFL S PTLBL=0
179 I 'PTLBL Q 0
180 ; - Label already printed for Rx fill?
181 S LBL=0
182 F S LBL=$O(^PSRX(RX,"L",LBL)) Q:'LBL D Q:'PTLBL
183 . I +$$GET1^DIQ(52.032,LBL_","_RX,1,"I")'=RFL Q
184 . I $$GET1^DIQ(52.032,LBL_","_RX,4,"I") Q
185 . I $$GET1^DIQ(52.032,LBL_","_RX,2)["INTERACTION" Q
186 . S PTLBL=0
187 ;
188 I PTLBL D
189 . N DIR,DIRUT,Y
190 . W ! S DIR(0)="Y",DIR("A")="Print Label? ",DIR("B")="YES"
191 . D ^DIR I $G(Y)=0!$D(DIRUT) S PTLBL=0 Q
192 ;
193 Q PTLBL
194 ;
195DTRNG(BGN,END) ; Date Range Selection
196 ;Input: (o) BGN - Default Begin Date
197 ; (o) END - Default End Date
198 ;
199 N %DT,DTOUT,DUOUT,DTRNG,X,Y
200 S DTRNG=""
201 S %DT="AEST",%DT("A")="BEGIN REJECT DATE: ",%DT("B")=$G(BGN) K:$G(BGN)="" %DT("B") D ^%DT
202 I $G(DUOUT)!$G(DTOUT)!($G(Y)=-1) Q "^"
203 S $P(DTRNG,U)=Y
204 ;
205 W ! K %DT
206 S %DT="AEST",%DT("A")="END REJECT DATE: ",%DT("B")=$G(END),%DT(0)=Y K:$G(END)="" %DT("B") D ^%DT
207 I $G(DUOUT)!$G(DTOUT)!($G(Y)=-1) Q "^"
208 ;
209 ;Define Entry
210 S $P(DTRNG,U,2)=Y
211 ;
212 Q DTRNG
Note: See TracBrowser for help on using the repository browser.