PSOREJU1 ;BIRM/MFR - BPS (ECME) - Clinical Rejects Utilities (1) ;10/15/04
;;7.0;OUTPATIENT PHARMACY;**148,247,260,287,289**;DEC 1997;Build 107
;Reference to File 9002313.21 - BPS NCPDP PROFESSIONAL SERVICE CODE supported by IA 4712
;Reference to File 9002313.22 - BPS NCPDP RESULT OF SERVICE CODE supported by IA 4713
;Reference to File 9002313.23 - BPS NCPDP REASON FOR SERVICE CODE supported by IA 4714
;Reference to File 200 - NEW PERSON supported by IA 10060
;Reference to SIG^XUSESIG supported by IA 10050
;
ACTION(RX,REJ,OPTS,DEF) ;
; Input: (r) RX - Rx IEN (#52)
; (r) REJ - REJECT ID (IEN)
; (r) OPTS - Available options ("QIO" for QUIT/IGNORE/OVERRIDE)
; (o) DEF - Default Option ("O", "I" or "Q")
; Output: ACTION: "I^Comments" - Ignore Reject
; "O^COD1^COD2^COD3" - Override with the Override codes COD1(Prof.),COD2(Reason) and COD3(Result)
; "Q" - Quit
; "^" - Up-arrow entered or timed out
;
N ACTION,COM,OVR,X,DIR,DIRUT,Y
;
I '$G(RX)!'$G(REJ) Q
I '$G(PSONBILL) Q:'$D(^PSRX(RX,"REJ",REJ))
;
; - Display DUR/79 REJECT information
D DISPLAY^PSOREJU3(RX,REJ)
;
ASK K ACTION,DIR,DIRUT
S DIR(0)="SO^",DIR("A")=""
S:(OPTS["O") DIR(0)=DIR(0)_"O:(O)VERRIDE - RESUBMIT WITH OVERRIDE CODES;",DIR("A")=DIR("A")_"(O)verride,"
S:(OPTS["I") DIR(0)=DIR(0)_"I:(I)GNORE - FILL Rx WITHOUT CLAIM SUBMISSION;",DIR("A")=DIR("A")_"(I)gnore,"
S:(OPTS["D") DIR(0)=DIR(0)_"D:(D)iscontinue - DO NOT FILL PRESCRIPTION;",DIR("A")=DIR("A")_"(D)iscontinue,"
S:(OPTS["Q") DIR(0)=DIR(0)_"Q:(Q)UIT - SEND TO WORKLIST (REQUIRES INTERVENTION);",DIR("A")=DIR("A")_"(Q)uit,"
S $E(DIR(0),$L(DIR(0)))="",$E(DIR("A"),$L(DIR("A")))="",DIR("??")="^D HELP^PSOREJU2("""_OPTS_""")"
S:$G(DEF)'="" DIR("B")=DEF D ^DIR I $D(DIRUT) W ! Q "Q"
;
; - STOP/QUIT Action
S ACTION=Y I ACTION="Q" Q ACTION
;
; - IGNORE Action
K DIR,DIRUT,X
I ACTION="I" S COM=$$COM() G ASK:COM="^" G ASK:'$$SIG() S ACTION=ACTION_"^"_COM
;
; - OVERRIDE Action
I ACTION="O" D G ASK:OVR="^"
. S OVR=$$OVR() S ACTION=ACTION_"^"_OVR
;
DC1 ;Discontinue
I ACTION="D" S ACTION=$$DC(RX,ACTION) I $D(DIRUT) S ACTION="D" D DISPLAY^PSOREJU3(RX,REJ) G ASK
;
Q ACTION
;
DC(RX,ACTION) ; - Discontinue inside and outside call
N RXN,MSG,REA,DA,PSCAN,RXNUM
S DA=RX,RXNUM=""
D NOOR^PSOCAN4 I $D(DIRUT) W $C(7)," ACTION NOT TAKEN!",! H 1 S PSORX("DFLG")=1,ACTION="Q" Q ACTION
D REQ^PSOCAN4 I $D(DIRUT) W $C(7)," ACTION NOT TAKEN!",! H 1 S PSORX("DFLG")=1,ACTION="Q" Q ACTION
S REA="C",RXNUM=$P(^PSRX(DA,0),"^")
S MSG="Discontinued "_$S($G(PSOFDR):" from Reject Processing Screen",1:"")
S PSCAN(RXNUM)=DA_"^C"
D CAN^PSOCAN
N PSOCKDC S PSOCKDC=1,PSOQFLAG=1,PSOLST(1)=52_"^"_DA_"^"_$$GET1^DIQ(52,RXNUM,100),ORN=1
D ECME^PSORXL1 I '$G(PPL) S PPL="" ;remove rx from label print
Q ACTION
;
SIG() ; - Get electronic signature
N CODE,X,X1,Y
S CODE=$P($G(^VA(200,DUZ,20)),U,4),Y=0 I '$L(CODE) D Q Y
. W $C(7),!,"You do not have an electronic signature code."
. W !,"Please contact your IRM office." H 2
D SIG^XUSESIG S Y=(X1'="")
Q Y
;
COM() ; - Ask for CLOSE comments
K COM,DIR,DIRUT,X
W ! S DIR(0)="F^3:100" S DIR("A")="Comments" D ^DIR
S COM=X I $D(DIRUT) S COM="^"
Q COM
;
OVR() ; - Ask for OVERRIDE codes
N COD1,COD2,COD3,DIR,DIRUT W !
S COD1=$$OVRCOD(1,$$GET1^DIQ(52.25,REJ_","_RX,14)) I COD1="^" Q "^"
S COD2=$$OVRCOD(2) I COD2="^" Q "^"
S COD3=$$OVRCOD(3) I COD3="^" Q "^"
;
D OVRDSP^PSOREJU1(COD1_"^"_COD2_"^"_COD3) W !
;
S DIR(0)="Y",DIR("A")=" Confirm? ",DIR("B")="YES"
D ^DIR I $G(Y)=0!$D(DIRUT) Q "^"
;
Q (COD2_"^"_COD1_"^"_COD3)
;
OVRDSP(LST) ; - Display the Override Codes
N I W !
F I=1:1:3 D
. W !?5,$S(I=1:"Reason for Service Code : ",I=2:"Professional Service Code: ",1:"Result of Service Code : ")
. W $E($$OVRX(I,$P(LST,"^",I)),1,48)
Q
;
CLA() ; - Ask for Clarification Code
N DIR,Y,DIRUT,DIROUT
S DIR(0)="52.25,24",DIR("A")="Clarification Code" D ^DIR
I $D(DIRUT)!$D(DIROUT) Q "^"
Q Y
;
HDLG(RX,RFL,CODES,FROM,OPTS,DEF) ; - REJECT Handling
;Input: (r) RX - Rx IEN (#52)
; (o) RFL - Refill # (Default: most recent)
; (r) CODES - List of REJECT CODES to be handled separated by commas (default is "79,88")
; (r) FROM - Same values as BWHERE param. in the EN^BPSNCPDP api
; (r) OPTS - Available options ("IOQ" for IGNORE/OVERRIDE/QUIT)
; (o) DEF - Default Option ("O", "I" or "Q")
;Output: ACTION - "O"-Override, "I"-Ignore,"Q"-Quit,"^"-Up-arrow entered
;
N REJDATA,NEWDATA,CODE,ACTION,REJ,RESP,REJCDI,PSOTRIC,DCODE S CODE=""
I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,PSOTRIC)
I PSOTRIC D ;note that Tricare Rejects need all codes, not just 79/88's
. S OPTS="DQ",DEF="Q",(DCODE,CODES)=""
. F S DCODE=$O(^PSRX(RX,"REJ","B",DCODE)) Q:DCODE="" S CODES=CODES_","_DCODE
. S CODES=$E(CODES,2,9999)
. I CODES["88"!(CODES["79") S OPTS="ODQ"
; - In progress Rx not allowed to be filled
I PSOTRIC,$$STATUS^PSOBPSUT(RX,RFL)["IN PROGRESS" S ACTION="",(DEF,OPTS)="D" D TRICCHK^PSOREJU3(RX,RFL,"",FROM) D Q ACTION
. I $P(ACTION,"^")="D" D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,7,,$P(ACTION,"^",2))
;
F REJCDI=1:1 S CODE=$P(CODES,",",REJCDI) Q:CODE="" D I ACTION="Q"!(ACTION="^") Q
. S ACTION=""
. I $$FIND^PSOREJUT(RX,RFL,.REJDATA,CODE) D
. . S REJ=$O(REJDATA(""))
. . S ACTION=$$ACTION(RX,REJ,OPTS,$G(DEF)) I ACTION="Q"!(ACTION="^") Q
. . I $P(ACTION,"^")="I" D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,6,$P(ACTION,"^",2)) Q
. . I $P(ACTION,"^")="O" D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,1,,$P(ACTION,"^",3),$P(ACTION,"^",2),$P(ACTION,"^",4))
. . I $P(ACTION,"^")="D" D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,7,,$P(ACTION,"^",2)) Q
. . D ECMESND^PSOBPSU1(RX,RFL,,FROM,$$GETNDC^PSONDCUT(RX,RFL),,,$P(ACTION,"^",2,4),,.RESP)
. . I $G(RESP) D Q
. . . W !!?10,"Claim could not be submitted. Please try again later!"
. . . W !,?10,"Reason: ",$S($P(RESP,"^",2)="":"UNKNOWN",1:$P(RESP,"^",2)),$C(7)
. . K NEWDATA I $$FIND^PSOREJUT(RX,RFL,.NEWDATA,CODE) D I ACTION="Q"!(ACTION="^") Q
. . . S ACTION=$$ACTION(RX,$O(NEWDATA("")),OPTS,$G(DEF)) I ACTION="Q"!(ACTION="^") Q
. . . I $P(ACTION,"^")="I" D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,6,$P(ACTION,"^",2))
. . . I $P(ACTION,"^")="O" D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,1,,$P(ACTION,"^",3),$P(ACTION,"^",2),$P(ACTION,"^",4))
Q ACTION
;
OVRX(TYPE,CODE) ; - Returns the extended code/description of the NCPDP DUR override codes
; Input: (r) TYPE - 1 (REASON FOR SERVICE), 2 (PROFESSIONAL SERVICE) or 3 (RESULT OF SERVICE)
; (r) CODE - Table IEN
; Output: "CODE - DESCRIPTION"
N FILE,DIC,X,Y
S FILE=9002313+$S(TYPE=1:.23,TYPE=2:.21,1:.22)
S DIC=FILE,X=CODE D ^DIC
I TYPE=1 Q CODE_" - "_$$GET1^DIQ(9002313.23,+Y,1)
I TYPE=2 Q CODE_" - "_$$GET1^DIQ(9002313.21,+Y,1)
I TYPE=3 Q CODE_" - "_$$GET1^DIQ(9002313.22,+Y,1)
Q ""
;
;
OVRCOD(TYPE,VALUE) ; - Prompt for NCPDP Override Codes
N DIC,X,Y,FILE,PRPT
;
I TYPE=1 S FILE=9002313.23,PRPT="Reason for Service Code : "
I TYPE=2 S FILE=9002313.21,PRPT="Professional Service Code: "
I TYPE=3 S FILE=9002313.22,PRPT="Result of Service Code : "
S DIC=FILE,DIC(0)="Z"
I $G(VALUE)'="" S X=VALUE D ^DIC I Y>0 W !,PRPT,VALUE," ",$P(Y(0),"^",2) Q VALUE
S DIC=FILE,DIC(0)="AQE",DIC("A")=PRPT
D ^DIC I $D(DTOUT)!$D(DUOUT)!(Y<0) Q "^"
Q $P(Y,"^",2)
;
SEL(FIELD,FILE,ARRAY,DEFAULT) ; - Provides field selection (one, multiple or ALL)
N DIC,DTOUT,DUOUT,QT,Y,X
W !!,"You may select a single or multiple "_FIELD_"S,"
W !,"or enter ^ALL to select all "_FIELD_"S.",!
K ARRAY S DIC=FILE,DIC(0)="QEZAM",DIC("A")=FIELD_": "
I $G(DEFAULT)'="" S DIC("B")=DEFAULT
F D ^DIC Q:X="" D Q:$G(QT)
. I $$UP^XLFSTR(X)="^ALL" K ARRAY S ARRAY="ALL",QT=1 Q
. I $D(DTOUT)!$D(DUOUT) K ARRAY S ARRAY="^",QT=1 Q
. W " ",$P(Y,"^",2),$S($D(ARRAY(+Y)):" (already selected)",1:"")
. W ! S ARRAY(+Y)="",DIC("A")="ANOTHER ONE: " K DIC("B")
I '$D(ARRAY) S ARRAY="^"
Q
;
LMREJ(RX,RFL,MSG,BCK) ; Used by ListManager hidden actions to detect unresolved 3rd Party Rejects
;Input: (r) RX - Rx IEN (#52)
; (o) RFL - Refill # (Default: most recent)
;Output: (o) MSG - Usually this will be used to set VALMSG variable, which should be passed in by ref.
; (o) BCK - This will be used to set VALMBCK variable, which should be passed in by ref.
;
I '$D(^PSRX(+RX)) Q 0
I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
I $$FIND^PSOREJUT(RX,RFL) D Q 1
. S MSG="NOT ALLOWED! Rx has OPEN 3rd Party Payer Reject.",BCK="R" W $C(7),$C(7)
Q 0
;
DUP(RX,RSP) ; Checks if REJECT has already been logged in the PRESCRIPTION file
; Input: (r) RX - Rx IEN (#52)
; (o) RSP - Response IEN
; Output: DUP - 1: Already logged (duplicate)
; 0: Not yet logged on PRESCRIPTION file
N DUP,IDX S (DUP,IDX)=0
F S IDX=$O(^PSRX(RX,"REJ",IDX)) Q:'IDX D Q:DUP
. I +RSP=+$$GET1^DIQ(52.25,IDX_","_RX,16,"I") S DUP=1
Q DUP
;
OTH(CODE,LST) ; Removes the current Reject code from the list
; Input: (r) CODE - Current Reject Code (79 or 88)
; (o) LST - List of all Reject codes with response (comma separated)
; Output: OTH - List of OTHER Reject codes (w/out 79 or 88)
;
N I,OTH
F I=1:1:$L(LST,",") D
. I $P(LST,",",I),$P(LST,",",I)'=CODE S OTH=$G(OTH)_","_$P(LST,",",I)
S $E(OTH)=""
Q OTH
;
DAT(DAT) ; - External Date
S X=$$HL7TFM^XLFDT(DAT) I X<0 Q ""
Q X
;
CLEAN(STR) ; Remove blanks from the end of a string and replaces ";" with ","
N LEN F LEN=$L(STR):-1:1 Q:$E(STR,LEN)'=" "
S STR=$TR(STR,";",",")
Q $E(STR,1,LEN)
PSOREJU1 ;BIRM/MFR - BPS (ECME) - Clinical Rejects Utilities (1) ;10/15/04
+1 ;;7.0;OUTPATIENT PHARMACY;**148,247,260,287,289**;DEC 1997;Build 107
+2 ;Reference to File 9002313.21 - BPS NCPDP PROFESSIONAL SERVICE CODE supported by IA 4712
+3 ;Reference to File 9002313.22 - BPS NCPDP RESULT OF SERVICE CODE supported by IA 4713
+4 ;Reference to File 9002313.23 - BPS NCPDP REASON FOR SERVICE CODE supported by IA 4714
+5 ;Reference to File 200 - NEW PERSON supported by IA 10060
+6 ;Reference to SIG^XUSESIG supported by IA 10050
+7 ;
ACTION(RX,REJ,OPTS,DEF) ;
+1 ; Input: (r) RX - Rx IEN (#52)
+2 ; (r) REJ - REJECT ID (IEN)
+3 ; (r) OPTS - Available options ("QIO" for QUIT/IGNORE/OVERRIDE)
+4 ; (o) DEF - Default Option ("O", "I" or "Q")
+5 ; Output: ACTION: "I^Comments" - Ignore Reject
+6 ; "O^COD1^COD2^COD3" - Override with the Override codes COD1(Prof.),COD2(Reason) and COD3(Result)
+7 ; "Q" - Quit
+8 ; "^" - Up-arrow entered or timed out
+9 ;
+10 NEW ACTION,COM,OVR,X,DIR,DIRUT,Y
+11 ;
+12 IF '$GET(RX)!'$GET(REJ)
QUIT
+13 IF '$GET(PSONBILL)
IF '$DATA(^PSRX(RX,"REJ",REJ))
QUIT
+14 ;
+15 ; - Display DUR/79 REJECT information
+16 DO DISPLAY^PSOREJU3(RX,REJ)
+17 ;
ASK KILL ACTION,DIR,DIRUT
+1 SET DIR(0)="SO^"
SET DIR("A")=""
+2 IF (OPTS["O")
SET DIR(0)=DIR(0)_"O:(O)VERRIDE - RESUBMIT WITH OVERRIDE CODES;"
SET DIR("A")=DIR("A")_"(O)verride,"
+3 IF (OPTS["I")
SET DIR(0)=DIR(0)_"I:(I)GNORE - FILL Rx WITHOUT CLAIM SUBMISSION;"
SET DIR("A")=DIR("A")_"(I)gnore,"
+4 IF (OPTS["D")
SET DIR(0)=DIR(0)_"D:(D)iscontinue - DO NOT FILL PRESCRIPTION;"
SET DIR("A")=DIR("A")_"(D)iscontinue,"
+5 IF (OPTS["Q")
SET DIR(0)=DIR(0)_"Q:(Q)UIT - SEND TO WORKLIST (REQUIRES INTERVENTION);"
SET DIR("A")=DIR("A")_"(Q)uit,"
+6 SET $EXTRACT(DIR(0),$LENGTH(DIR(0)))=""
SET $EXTRACT(DIR("A"),$LENGTH(DIR("A")))=""
SET DIR("??")="^D HELP^PSOREJU2("""_OPTS_""")"
+7 IF $GET(DEF)'=""
SET DIR("B")=DEF
DO ^DIR
IF $DATA(DIRUT)
WRITE !
QUIT "Q"
+8 ;
+9 ; - STOP/QUIT Action
+10 SET ACTION=Y
IF ACTION="Q"
QUIT ACTION
+11 ;
+12 ; - IGNORE Action
+13 KILL DIR,DIRUT,X
+14 IF ACTION="I"
SET COM=$$COM()
IF COM="^"
GOTO ASK
IF '$$SIG()
GOTO ASK
SET ACTION=ACTION_"^"_COM
+15 ;
+16 ; - OVERRIDE Action
+17 IF ACTION="O"
Begin DoDot:1
+18 SET OVR=$$OVR()
SET ACTION=ACTION_"^"_OVR
End DoDot:1
IF OVR="^"
GOTO ASK
+19 ;
DC1 ;Discontinue
+1 IF ACTION="D"
SET ACTION=$$DC(RX,ACTION)
IF $DATA(DIRUT)
SET ACTION="D"
DO DISPLAY^PSOREJU3(RX,REJ)
GOTO ASK
+2 ;
+3 QUIT ACTION
+4 ;
DC(RX,ACTION) ; - Discontinue inside and outside call
+1 NEW RXN,MSG,REA,DA,PSCAN,RXNUM
+2 SET DA=RX
SET RXNUM=""
+3 DO NOOR^PSOCAN4
IF $DATA(DIRUT)
WRITE $CHAR(7)," ACTION NOT TAKEN!",!
HANG 1
SET PSORX("DFLG")=1
SET ACTION="Q"
QUIT ACTION
+4 DO REQ^PSOCAN4
IF $DATA(DIRUT)
WRITE $CHAR(7)," ACTION NOT TAKEN!",!
HANG 1
SET PSORX("DFLG")=1
SET ACTION="Q"
QUIT ACTION
+5 SET REA="C"
SET RXNUM=$PIECE(^PSRX(DA,0),"^")
+6 SET MSG="Discontinued "_$SELECT($GET(PSOFDR):" from Reject Processing Screen",1:"")
+7 SET PSCAN(RXNUM)=DA_"^C"
+8 DO CAN^PSOCAN
+9 NEW PSOCKDC
SET PSOCKDC=1
SET PSOQFLAG=1
SET PSOLST(1)=52_"^"_DA_"^"_$$GET1^DIQ(52,RXNUM,100)
SET ORN=1
+10 ;remove rx from label print
DO ECME^PSORXL1
IF '$GET(PPL)
SET PPL=""
+11 QUIT ACTION
+12 ;
SIG() ; - Get electronic signature
+1 NEW CODE,X,X1,Y
+2 SET CODE=$PIECE($GET(^VA(200,DUZ,20)),U,4)
SET Y=0
IF '$LENGTH(CODE)
Begin DoDot:1
+3 WRITE $CHAR(7),!,"You do not have an electronic signature code."
+4 WRITE !,"Please contact your IRM office."
HANG 2
End DoDot:1
QUIT Y
+5 DO SIG^XUSESIG
SET Y=(X1'="")
+6 QUIT Y
+7 ;
COM() ; - Ask for CLOSE comments
+1 KILL COM,DIR,DIRUT,X
+2 WRITE !
SET DIR(0)="F^3:100"
SET DIR("A")="Comments"
DO ^DIR
+3 SET COM=X
IF $DATA(DIRUT)
SET COM="^"
+4 QUIT COM
+5 ;
OVR() ; - Ask for OVERRIDE codes
+1 NEW COD1,COD2,COD3,DIR,DIRUT
WRITE !
+2 SET COD1=$$OVRCOD(1,$$GET1^DIQ(52.25,REJ_","_RX,14))
IF COD1="^"
QUIT "^"
+3 SET COD2=$$OVRCOD(2)
IF COD2="^"
QUIT "^"
+4 SET COD3=$$OVRCOD(3)
IF COD3="^"
QUIT "^"
+5 ;
+6 DO OVRDSP^PSOREJU1(COD1_"^"_COD2_"^"_COD3)
WRITE !
+7 ;
+8 SET DIR(0)="Y"
SET DIR("A")=" Confirm? "
SET DIR("B")="YES"
+9 DO ^DIR
IF $GET(Y)=0!$DATA(DIRUT)
QUIT "^"
+10 ;
+11 QUIT (COD2_"^"_COD1_"^"_COD3)
+12 ;
OVRDSP(LST) ; - Display the Override Codes
+1 NEW I
WRITE !
+2 FOR I=1:1:3
Begin DoDot:1
+3 WRITE !?5,$SELECT(I=1:"Reason for Service Code : ",I=2:"Professional Service Code: ",1:"Result of Service Code : ")
+4 WRITE $EXTRACT($$OVRX(I,$PIECE(LST,"^",I)),1,48)
End DoDot:1
+5 QUIT
+6 ;
CLA() ; - Ask for Clarification Code
+1 NEW DIR,Y,DIRUT,DIROUT
+2 SET DIR(0)="52.25,24"
SET DIR("A")="Clarification Code"
DO ^DIR
+3 IF $DATA(DIRUT)!$DATA(DIROUT)
QUIT "^"
+4 QUIT Y
+5 ;
HDLG(RX,RFL,CODES,FROM,OPTS,DEF) ; - REJECT Handling
+1 ;Input: (r) RX - Rx IEN (#52)
+2 ; (o) RFL - Refill # (Default: most recent)
+3 ; (r) CODES - List of REJECT CODES to be handled separated by commas (default is "79,88")
+4 ; (r) FROM - Same values as BWHERE param. in the EN^BPSNCPDP api
+5 ; (r) OPTS - Available options ("IOQ" for IGNORE/OVERRIDE/QUIT)
+6 ; (o) DEF - Default Option ("O", "I" or "Q")
+7 ;Output: ACTION - "O"-Override, "I"-Ignore,"Q"-Quit,"^"-Up-arrow entered
+8 ;
+9 NEW REJDATA,NEWDATA,CODE,ACTION,REJ,RESP,REJCDI,PSOTRIC,DCODE
SET CODE=""
+10 IF '$DATA(RFL)
SET RFL=$$LSTRFL^PSOBPSU1(RX)
+11 SET PSOTRIC=""
SET PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,PSOTRIC)
+12 ;note that Tricare Rejects need all codes, not just 79/88's
IF PSOTRIC
Begin DoDot:1
+13 SET OPTS="DQ"
SET DEF="Q"
SET (DCODE,CODES)=""
+14 FOR
SET DCODE=$ORDER(^PSRX(RX,"REJ","B",DCODE))
IF DCODE=""
QUIT
SET CODES=CODES_","_DCODE
+15 SET CODES=$EXTRACT(CODES,2,9999)
+16 IF CODES["88"!(CODES["79")
SET OPTS="ODQ"
End DoDot:1
+17 ; - In progress Rx not allowed to be filled
+18 IF PSOTRIC
IF $$STATUS^PSOBPSUT(RX,RFL)["IN PROGRESS"
SET ACTION=""
SET (DEF,OPTS)="D"
DO TRICCHK^PSOREJU3(RX,RFL,"",FROM)
Begin DoDot:1
+19 IF $PIECE(ACTION,"^")="D"
DO CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,7,,$PIECE(ACTION,"^",2))
End DoDot:1
QUIT ACTION
+20 ;
+21 FOR REJCDI=1:1
SET CODE=$PIECE(CODES,",",REJCDI)
IF CODE=""
QUIT
Begin DoDot:1
+22 SET ACTION=""
+23 IF $$FIND^PSOREJUT(RX,RFL,.REJDATA,CODE)
Begin DoDot:2
+24 SET REJ=$ORDER(REJDATA(""))
+25 SET ACTION=$$ACTION(RX,REJ,OPTS,$GET(DEF))
IF ACTION="Q"!(ACTION="^")
QUIT
+26 IF $PIECE(ACTION,"^")="I"
DO CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,6,$PIECE(ACTION,"^",2))
QUIT
+27 IF $PIECE(ACTION,"^")="O"
DO CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,1,,$PIECE(ACTION,"^",3),$PIECE(ACTION,"^",2),$PIECE(ACTION,"^",4))
+28 IF $PIECE(ACTION,"^")="D"
DO CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,7,,$PIECE(ACTION,"^",2))
QUIT
+29 DO ECMESND^PSOBPSU1(RX,RFL,,FROM,$$GETNDC^PSONDCUT(RX,RFL),,,$PIECE(ACTION,"^",2,4),,.RESP)
+30 IF $GET(RESP)
Begin DoDot:3
+31 WRITE !!?10,"Claim could not be submitted. Please try again later!"
+32 WRITE !,?10,"Reason: ",$SELECT($PIECE(RESP,"^",2)="":"UNKNOWN",1:$PIECE(RESP,"^",2)),$CHAR(7)
End DoDot:3
QUIT
+33 KILL NEWDATA
IF $$FIND^PSOREJUT(RX,RFL,.NEWDATA,CODE)
Begin DoDot:3
+34 SET ACTION=$$ACTION(RX,$ORDER(NEWDATA("")),OPTS,$GET(DEF))
IF ACTION="Q"!(ACTION="^")
QUIT
+35 IF $PIECE(ACTION,"^")="I"
DO CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,6,$PIECE(ACTION,"^",2))
+36 IF $PIECE(ACTION,"^")="O"
DO CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,1,,$PIECE(ACTION,"^",3),$PIECE(ACTION,"^",2),$PIECE(ACTION,"^",4))
End DoDot:3
IF ACTION="Q"!(ACTION="^")
QUIT
End DoDot:2
End DoDot:1
IF ACTION="Q"!(ACTION="^")
QUIT
+37 QUIT ACTION
+38 ;
OVRX(TYPE,CODE) ; - Returns the extended code/description of the NCPDP DUR override codes
+1 ; Input: (r) TYPE - 1 (REASON FOR SERVICE), 2 (PROFESSIONAL SERVICE) or 3 (RESULT OF SERVICE)
+2 ; (r) CODE - Table IEN
+3 ; Output: "CODE - DESCRIPTION"
+4 NEW FILE,DIC,X,Y
+5 SET FILE=9002313+$SELECT(TYPE=1:.23,TYPE=2:.21,1:.22)
+6 SET DIC=FILE
SET X=CODE
DO ^DIC
+7 IF TYPE=1
QUIT CODE_" - "_$$GET1^DIQ(9002313.23,+Y,1)
+8 IF TYPE=2
QUIT CODE_" - "_$$GET1^DIQ(9002313.21,+Y,1)
+9 IF TYPE=3
QUIT CODE_" - "_$$GET1^DIQ(9002313.22,+Y,1)
+10 QUIT ""
+11 ;
+12 ;
OVRCOD(TYPE,VALUE) ; - Prompt for NCPDP Override Codes
+1 NEW DIC,X,Y,FILE,PRPT
+2 ;
+3 IF TYPE=1
SET FILE=9002313.23
SET PRPT="Reason for Service Code : "
+4 IF TYPE=2
SET FILE=9002313.21
SET PRPT="Professional Service Code: "
+5 IF TYPE=3
SET FILE=9002313.22
SET PRPT="Result of Service Code : "
+6 SET DIC=FILE
SET DIC(0)="Z"
+7 IF $GET(VALUE)'=""
SET X=VALUE
DO ^DIC
IF Y>0
WRITE !,PRPT,VALUE," ",$PIECE(Y(0),"^",2)
QUIT VALUE
+8 SET DIC=FILE
SET DIC(0)="AQE"
SET DIC("A")=PRPT
+9 DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)!(Y<0)
QUIT "^"
+10 QUIT $PIECE(Y,"^",2)
+11 ;
SEL(FIELD,FILE,ARRAY,DEFAULT) ; - Provides field selection (one, multiple or ALL)
+1 NEW DIC,DTOUT,DUOUT,QT,Y,X
+2 WRITE !!,"You may select a single or multiple "_FIELD_"S,"
+3 WRITE !,"or enter ^ALL to select all "_FIELD_"S.",!
+4 KILL ARRAY
SET DIC=FILE
SET DIC(0)="QEZAM"
SET DIC("A")=FIELD_": "
+5 IF $GET(DEFAULT)'=""
SET DIC("B")=DEFAULT
+6 FOR
DO ^DIC
IF X=""
QUIT
Begin DoDot:1
+7 IF $$UP^XLFSTR(X)="^ALL"
KILL ARRAY
SET ARRAY="ALL"
SET QT=1
QUIT
+8 IF $DATA(DTOUT)!$DATA(DUOUT)
KILL ARRAY
SET ARRAY="^"
SET QT=1
QUIT
+9 WRITE " ",$PIECE(Y,"^",2),$SELECT($DATA(ARRAY(+Y)):" (already selected)",1:"")
+10 WRITE !
SET ARRAY(+Y)=""
SET DIC("A")="ANOTHER ONE: "
KILL DIC("B")
End DoDot:1
IF $GET(QT)
QUIT
+11 IF '$DATA(ARRAY)
SET ARRAY="^"
+12 QUIT
+13 ;
LMREJ(RX,RFL,MSG,BCK) ; Used by ListManager hidden actions to detect unresolved 3rd Party Rejects
+1 ;Input: (r) RX - Rx IEN (#52)
+2 ; (o) RFL - Refill # (Default: most recent)
+3 ;Output: (o) MSG - Usually this will be used to set VALMSG variable, which should be passed in by ref.
+4 ; (o) BCK - This will be used to set VALMBCK variable, which should be passed in by ref.
+5 ;
+6 IF '$DATA(^PSRX(+RX))
QUIT 0
+7 IF '$DATA(RFL)
SET RFL=$$LSTRFL^PSOBPSU1(RX)
+8 IF $$FIND^PSOREJUT(RX,RFL)
Begin DoDot:1
+9 SET MSG="NOT ALLOWED! Rx has OPEN 3rd Party Payer Reject."
SET BCK="R"
WRITE $CHAR(7),$CHAR(7)
End DoDot:1
QUIT 1
+10 QUIT 0
+11 ;
DUP(RX,RSP) ; Checks if REJECT has already been logged in the PRESCRIPTION file
+1 ; Input: (r) RX - Rx IEN (#52)
+2 ; (o) RSP - Response IEN
+3 ; Output: DUP - 1: Already logged (duplicate)
+4 ; 0: Not yet logged on PRESCRIPTION file
+5 NEW DUP,IDX
SET (DUP,IDX)=0
+6 FOR
SET IDX=$ORDER(^PSRX(RX,"REJ",IDX))
IF 'IDX
QUIT
Begin DoDot:1
+7 IF +RSP=+$$GET1^DIQ(52.25,IDX_","_RX,16,"I")
SET DUP=1
End DoDot:1
IF DUP
QUIT
+8 QUIT DUP
+9 ;
OTH(CODE,LST) ; Removes the current Reject code from the list
+1 ; Input: (r) CODE - Current Reject Code (79 or 88)
+2 ; (o) LST - List of all Reject codes with response (comma separated)
+3 ; Output: OTH - List of OTHER Reject codes (w/out 79 or 88)
+4 ;
+5 NEW I,OTH
+6 FOR I=1:1:$LENGTH(LST,",")
Begin DoDot:1
+7 IF $PIECE(LST,",",I)
IF $PIECE(LST,",",I)'=CODE
SET OTH=$GET(OTH)_","_$PIECE(LST,",",I)
End DoDot:1
+8 SET $EXTRACT(OTH)=""
+9 QUIT OTH
+10 ;
DAT(DAT) ; - External Date
+1 SET X=$$HL7TFM^XLFDT(DAT)
IF X<0
QUIT ""
+2 QUIT X
+3 ;
CLEAN(STR) ; Remove blanks from the end of a string and replaces ";" with ","
+1 NEW LEN
FOR LEN=$LENGTH(STR):-1:1
IF $EXTRACT(STR,LEN)'=" "
QUIT
+2 SET STR=$TRANSLATE(STR,";",",")
+3 QUIT $EXTRACT(STR,1,LEN)
