source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOREJU1.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: 9.4 KB
Line 
1PSOREJU1 ;BIRM/MFR - BPS (ECME) - Clinical Rejects Utilities (1) ;10/15/04
2 ;;7.0;OUTPATIENT PHARMACY;**148,247,260**;DEC 1997;Build 84
3 ;Reference to File 9002313.21 - BPS NCPDP PROFESSIONAL SERVICE CODE supported by IA 4712
4 ;Reference to File 9002313.22 - BPS NCPDP RESULT OF SERVICE CODE supported by IA 4713
5 ;Reference to File 9002313.23 - BPS NCPDP REASON FOR SERVICE CODE supported by IA 4714
6 ;Reference to File 200 - NEW PERSON supported by IA 10060
7 ;Reference to SIG^XUSESIG supported by IA 10050
8 ;
9ACTION(RX,REJ,OPTS,DEF) ;
10 ; Input: (r) RX - Rx IEN (#52)
11 ; (r) REJ - REJECT ID (IEN)
12 ; (r) OPTS - Available options ("QIO" for QUIT/IGNORE/OVERRIDE)
13 ; (o) DEF - Default Option ("O", "I" or "Q")
14 ; Output: ACTION: "I^Comments" - Ignore Reject
15 ; "O^COD1^COD2^COD3" - Override with the Override codes COD1(Prof.),COD2(Reason) and COD3(Result)
16 ; "Q" - Quit
17 ; "^" - Up-arrow entered or timed out
18 ;
19 N ACTION,COM,OVR,X,DIR,DIRUT,Y
20 ;
21 I '$G(RX)!'$G(REJ) Q
22 I '$D(^PSRX(RX,"REJ",REJ)) Q
23 ;
24 ; - Display DUR/79 REJECT information
25 D DISPLAY(RX,REJ)
26 ;
27ASK K ACTION,DIR,DIRUT
28 S DIR(0)="SO^",DIR("A")=""
29 S:(OPTS["O") DIR(0)=DIR(0)_"O:(O)VERRIDE - RESUBMIT WITH OVERRIDE CODES;",DIR("A")=DIR("A")_"(O)verride,"
30 S:(OPTS["I") DIR(0)=DIR(0)_"I:(I)GNORE - FILL Rx WITHOUT CLAIM SUBMISSION;",DIR("A")=DIR("A")_"(I)gnore,"
31 S:(OPTS["Q") DIR(0)=DIR(0)_"Q:(Q)UIT - SEND TO WORKLIST (REQUIRES INTERVENTION);",DIR("A")=DIR("A")_"(Q)uit,"
32 S $E(DIR(0),$L(DIR(0)))="",$E(DIR("A"),$L(DIR("A")))="",DIR("??")="^D HELP^PSOREJU2("""_OPTS_""")"
33 S:$G(DEF)'="" DIR("B")=DEF D ^DIR I $D(DIRUT) W ! Q "Q"
34 ;
35 ; - STOP/QUIT Action
36 S ACTION=Y I ACTION="Q" Q ACTION
37 ;
38 ; - IGNORE Action
39 K DIR,DIRUT,X
40 I ACTION="I" S COM=$$COM() G ASK:COM="^" G ASK:'$$SIG() S ACTION=ACTION_"^"_COM
41 ;
42 ; - OVERRIDE Action
43 I ACTION="O" D G ASK:OVR="^"
44 . S OVR=$$OVR() S ACTION=ACTION_"^"_OVR
45 ;
46 Q ACTION
47 ;
48SIG() ; - Get electronic signature
49 N CODE,X,X1,Y
50 S CODE=$P($G(^VA(200,DUZ,20)),U,4),Y=0 I '$L(CODE) D Q Y
51 . W $C(7),!,"You do not have an electronic signature code."
52 . W !,"Please contact your IRM office." H 2
53 D SIG^XUSESIG S Y=(X1'="")
54 Q Y
55 ;
56COM() ; - Ask for CLOSE comments
57 K COM,DIR,DIRUT,X
58 W ! S DIR(0)="F^3:100" S DIR("A")="Comments" D ^DIR
59 S COM=X I $D(DIRUT) S COM="^"
60 Q COM
61 ;
62OVR() ; - Ask for OVERRIDE codes
63 N COD1,COD2,COD3,DIR,DIRUT W !
64 S COD1=$$OVRCOD(1,$$GET1^DIQ(52.25,REJ_","_RX,14)) I COD1="^" Q "^"
65 S COD2=$$OVRCOD(2) I COD2="^" Q "^"
66 S COD3=$$OVRCOD(3) I COD3="^" Q "^"
67 ;
68 D OVRDSP^PSOREJU1(COD1_"^"_COD2_"^"_COD3) W !
69 ;
70 S DIR(0)="Y",DIR("A")=" Confirm? ",DIR("B")="YES"
71 D ^DIR I $G(Y)=0!$D(DIRUT) Q "^"
72 ;
73 Q (COD2_"^"_COD1_"^"_COD3)
74 ;
75OVRDSP(LST) ; - Display the Override Codes
76 N I W !
77 F I=1:1:3 D
78 . W !?5,$S(I=1:"Reason for Service Code : ",I=2:"Professional Service Code: ",1:"Result of Service Code : ")
79 . W $E($$OVRX(I,$P(LST,"^",I)),1,48)
80 Q
81 ;
82CLA() ; - Ask for Clarification Code
83 N DIR,Y,DIRUT,DIROUT
84 S DIR(0)="52.25,24",DIR("A")="Clarification Code" D ^DIR
85 I $D(DIRUT)!$D(DIROUT) Q "^"
86 Q Y
87 ;
88DISPLAY(RX,REJ,KEY) ; - Displays REJECT information
89 ; Input: (r) RX - Rx IEN (#52)
90 ; (r) REJ - REJECT ID (IEN)
91 ; (o) KEY - Display "Press any KEY to continue..." (1-YES/0-NO) (Default: 0)
92 ;
93 I '$G(RX)!'$G(REJ) Q
94 I '$D(^PSRX(RX,"REJ",REJ)) Q
95 ;
96 N DATA,RFL,LINE,%
97 S RFL=+$$GET1^DIQ(52.25,REJ_","_RX,5)
98 D GET^PSOREJU2(RX,RFL,.DATA,REJ) I '$D(DATA(REJ)) Q
99 ;
100 W !!?16,"*** REJECT RECEIVED FROM THIRD PARTY PAYER ***"
101 S $P(LINE,"-",74)="" W !?3,LINE
102 W !?3,$$DVINFO^PSOREJU2(RX,RFL)
103 W !?3,$$PTINFO^PSOREJU2(RX)
104 W !?3,"Prescription : ",$$GET1^DIQ(52,RX,.01),"/",RFL," - ",$E($$GET1^DIQ(52,RX,6),1,20),?54,"ECME#: ",$E(RX+10000000,2,8)
105 W !?3,"Reject Type : ",DATA(REJ,"CODE")," - ",$S(DATA(REJ,"CODE")=79:"REFILL TOO SOON",1:"DUR REJECT")
106 W " received on "_$$FMTE^XLFDT($G(DATA(REJ,"DATE/TIME")))
107 I $G(DATA(REJ,"PAYER MESSAGE"))'="" W !?3,"Payer Message: " D PRT^PSOREJU2("PAYER MESSAGE",18,58)
108 I $G(DATA(REJ,"REASON"))'="" W !?3,"Reason : " D PRT^PSOREJU2("REASON",18,58)
109 I $G(DATA(REJ,"DUR TEXT"))'="" W !?3,"DUR Text : ",DATA(REJ,"DUR TEXT")
110 W !?3,"Insurance : ",DATA(REJ,"INSURANCE NAME"),?50,"Contact: ",DATA(REJ,"PLAN CONTACT")
111 W !?3,"Group Name : ",DATA(REJ,"GROUP NAME"),?45,"Group Number: ",DATA(REJ,"GROUP NUMBER")
112 I $G(DATA(REJ,"CARDHOLDER ID"))'="" W !?3,"Cardholder ID: ",DATA(REJ,"CARDHOLDER ID")
113 I DATA(REJ,"PLAN PREVIOUS FILL DATE")'="" D
114 . W !?3,"Last Fill Dt.: ",DATA(REJ,"PLAN PREVIOUS FILL DATE")
115 . W:DATA(REJ,"PLAN PREVIOUS FILL DATE")'="" " (from payer)"
116 W !?3,LINE,$C(7) I $G(KEY) W !?3,"Press <RETURN> to continue..." R %:DTIME W !
117 Q
118 ;
119HDLG(RX,RFL,CODES,FROM,OPTS,DEF) ; - REJECT Handling
120 ;Input: (r) RX - Rx IEN (#52)
121 ; (o) RFL - Refill # (Default: most recent)
122 ; (r) CODES - List of REJECT CODES to be handled separated by commas (e.g. "79,88")
123 ; (r) FROM - Same values as BWHERE param. in the EN^BPSNCPDP api
124 ; (r) OPTS - Available options ("IOQ" for IGNORE/OVERRIDE/QUIT)
125 ; (o) DEF - Default Option ("O", "I" or "Q")
126 ;Output: ACTION - "O"-Override, "I"-Ignore,"Q"-Quit,"^"-Up-arrow entered
127 ;
128 N REJDATA,NEWDATA,CODE,ACTION,REJ,RESP,REJCDI S CODE=""
129 I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
130 F REJCDI=1:1 S CODE=$P(CODES,",",REJCDI) Q:CODE="" D I ACTION="Q"!(ACTION="^") Q
131 . S ACTION=""
132 . I $$FIND^PSOREJUT(RX,RFL,.REJDATA,CODE) D
133 . . S REJ=$O(REJDATA(""))
134 . . S ACTION=$$ACTION(RX,REJ,OPTS,$G(DEF)) I ACTION="Q"!(ACTION="^") Q
135 . . I $P(ACTION,"^")="I" D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,6,$P(ACTION,"^",2)) Q
136 . . I $P(ACTION,"^")="O" D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,1,,$P(ACTION,"^",3),$P(ACTION,"^",2),$P(ACTION,"^",4))
137 . . D ECMESND^PSOBPSU1(RX,RFL,,FROM,$$GETNDC^PSONDCUT(RX,RFL),,,$P(ACTION,"^",2,4),,.RESP)
138 . . I $G(RESP) D Q
139 . . . W !!?10,"Claim could not be submitted. Please try again later!"
140 . . . W !,?10,"Reason: ",$S($P(RESP,"^",2)="":"UNKNOWN",1:$P(RESP,"^",2)),$C(7)
141 . . K NEWDATA I $$FIND^PSOREJUT(RX,RFL,.NEWDATA,CODE) D I ACTION="Q"!(ACTION="^") Q
142 . . . S ACTION=$$ACTION(RX,$O(NEWDATA("")),OPTS,$G(DEF)) I ACTION="Q"!(ACTION="^") Q
143 . . . I $P(ACTION,"^")="I" D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,6,$P(ACTION,"^",2))
144 . . . I $P(ACTION,"^")="O" D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,1,,$P(ACTION,"^",3),$P(ACTION,"^",2),$P(ACTION,"^",4))
145 Q ACTION
146 ;
147OVRX(TYPE,CODE) ; - Returns the extentend code/description of the NCPDP DUR override codes
148 ; Input: (r) TYPE - 1 (REASON FOR SERVICE), 2 (PROFESSIONAL SERVICE) or 3 (RESULT OF SERVICE)
149 ; (r) CODE - Table IEN
150 ; Output: "CODE - DESCRIPTION"
151 N FILE,DIC,X,Y
152 S FILE=9002313+$S(TYPE=1:.23,TYPE=2:.21,1:.22)
153 S DIC=FILE,X=CODE D ^DIC
154 I TYPE=1 Q CODE_" - "_$$GET1^DIQ(9002313.23,+Y,1)
155 I TYPE=2 Q CODE_" - "_$$GET1^DIQ(9002313.21,+Y,1)
156 I TYPE=3 Q CODE_" - "_$$GET1^DIQ(9002313.22,+Y,1)
157 Q ""
158 ;
159 ;
160OVRCOD(TYPE,VALUE) ; - Prompt for NCPDP Override Codes
161 N DIC,X,Y,FILE,PRPT
162 ;
163 I TYPE=1 S FILE=9002313.23,PRPT="Reason for Service Code : "
164 I TYPE=2 S FILE=9002313.21,PRPT="Professional Service Code: "
165 I TYPE=3 S FILE=9002313.22,PRPT="Result of Service Code : "
166 S DIC=FILE,DIC(0)="Z"
167 I $G(VALUE)'="" S X=VALUE D ^DIC I Y>0 W !,PRPT,VALUE," ",$P(Y(0),"^",2) Q VALUE
168 S DIC=FILE,DIC(0)="AQE",DIC("A")=PRPT
169 D ^DIC I $D(DTOUT)!$D(DUOUT)!(Y<0) Q "^"
170 Q $P(Y,"^",2)
171 ;
172SEL(FIELD,FILE,ARRAY,DEFAULT) ; - Provides field selection (one, multiple or ALL)
173 N DIC,DTOUT,DUOUT,QT,Y,X
174 W !!,"You may select a single or multiple "_FIELD_"S,"
175 W !,"or enter ^ALL to select all "_FIELD_"S.",!
176 K ARRAY S DIC=FILE,DIC(0)="QEZAM",DIC("A")=FIELD_": "
177 I $G(DEFAULT)'="" S DIC("B")=DEFAULT
178 F D ^DIC Q:X="" D Q:$G(QT)
179 . I $$UP^XLFSTR(X)="^ALL" K ARRAY S ARRAY="ALL",QT=1 Q
180 . I $D(DTOUT)!$D(DUOUT) K ARRAY S ARRAY="^",QT=1 Q
181 . W " ",$P(Y,"^",2),$S($D(ARRAY(+Y)):" (already selected)",1:"")
182 . W ! S ARRAY(+Y)="",DIC("A")="ANOTHER ONE: " K DIC("B")
183 I '$D(ARRAY) S ARRAY="^"
184 Q
185 ;
186LMREJ(RX,RFL,MSG,BCK) ; Used by ListManager hidden actions to detect unresolved 3rd Party Rejects
187 ;Input: (r) RX - Rx IEN (#52)
188 ; (o) RFL - Refill # (Default: most recent)
189 ;Output: (o) MSG - Usually this will be used to set VALMSG variable, which shoud be passed in by ref.
190 ; (o) BCK - This will be used to set VALMBCK variable, which shoud be passed in by ref.
191 ;
192 I '$D(^PSRX(+RX)) Q 0
193 I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
194 I $$FIND^PSOREJUT(RX,RFL) D Q 1
195 . S MSG="NOT ALLOWED! Rx has OPEN 3rd Party Payer Reject.",BCK="R" W $C(7),$C(7)
196 Q 0
197 ;
198DUP(RX,RSP) ; Checks if REJECT has already been logged in the PRESCRIPTION file
199 ; Input: (r) RX - Rx IEN (#52)
200 ; (o) RSP - Response IEN
201 ; Output: DUP - 1: Already logged (duplicate)
202 ; 0: Not yet logged on PRESCRIPTION file
203 N DUP,IDX S (DUP,IDX)=0
204 F S IDX=$O(^PSRX(RX,"REJ",IDX)) Q:'IDX D Q:DUP
205 . I +RSP=+$$GET1^DIQ(52.25,IDX_","_RX,16,"I") S DUP=1
206 Q DUP
207 ;
208OTH(CODE,LST) ; Removes the current Reject code from the list
209 ; Input: (r) CODE - Current Reject Code (79 or 88)
210 ; (o) LST - List of all Reject codes with response (comma separated)
211 ; Output: OTH - List of OTHER Reject codes (w/out 79 or 88)
212 ;
213 N I,OTH
214 F I=1:1:$L(LST,",") D
215 . I $P(LST,",",I),$P(LST,",",I)'=CODE S OTH=$G(OTH)_","_$P(LST,",",I)
216 S $E(OTH)=""
217 Q OTH
218 ;
219DAT(DAT) ; - External Date
220 S X=$$HL7TFM^XLFDT(DAT) I X<0 Q ""
221 Q X
222 ;
223CLEAN(STR) ; Remove blanks from the end of a string and replaces ";" with ","
224 N LEN F LEN=$L(STR):-1:1 Q:$E(STR,LEN)'=" "
225 S STR=$TR(STR,";",",")
226 Q $E(STR,1,LEN)
Note: See TracBrowser for help on using the repository browser.