PSOREJU1 ;BIRM/MFR - BPS (ECME) - Clinical Rejects Utilities (1) ;10/15/04
;;7.0;OUTPATIENT PHARMACY;**148,247,260,287,289,358,359,385,403,421,482,562,702**;DEC 1997;Build 14
; Reference to File 9002313.21 - BPS NCPDP PROFESSIONAL SERVICE CODE in ICR #4712
; Reference to File 9002313.22 - BPS NCPDP RESULT OF SERVICE CODE in ICR #4713
; Reference to File 9002313.23 - BPS NCPDP REASON FOR SERVICE CODE in ICR #4714
; Reference to File 9002313.25 - BPS NCPDP SUBMISSION CLARIFICATION CODE in ICR #5064
; Reference to File 200 - NEW PERSON in ICR #10060
; Reference to SIG^XUSESIG in ICR #10050
; Reference to AMT^BPSBUTL in ICR #4719
;
ACTION(RX,REJ,OPTS,DEF,RRR) ;
; Input: (r) RX - Rx IEN (#52)
; (r) REJ - REJECT ID (IEN)
; (r) OPTS - Available options ("QIDO" for QUIT/IGNORE/DISCONTINUE/OVERRIDE)
; (o) DEF - Default Option ("O", "I" or "Q")
; (o) RRR - Reject Resolution Required information Flag(0/1)^Threshold Amt^Gross Amt Due (Default: 0)
; If Flag = 0, there is no Reject Resolution Required reject code.
; Output: ACTION: "I^Comments" - Ignore Reject
; "O^COD1^COD2^COD3" - Override with the Override codes COD1(Prof.),COD2(Reason) and COD3(Result)
; "D" - Discontinue
; "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 reject information
D DISPLAY^PSOREJU3(RX,REJ,,RRR)
;
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"
S ACTION=Y
;
; STOP/QUIT Action
I ACTION="Q" Q ACTION
;
; IGNORE Action
K DIR,DIRUT,X
;
N PSOIT
S PSOIT=""
I ACTION="I" S PSOIT=$$IGNORE(RX,RFL)
I $P(PSOIT,"^")=0 D G ASK
. I $P(PSOIT,"^",2)'="" D
. . W $C(7),!,"Gross Amount Due is $"_$P(PSOIT,"^",2)_". IGNORE requires EPHARMACY SITE MANAGER key.",!
;
; If TRICARE/CHAMPVA, require confirmation before ignoring.
I PSOTRIC,ACTION="I",'$$CONT W $C(7),!," ACTION NOT TAKEN!",! H 1 G ASK
;
I ACTION="I" S:'PSOTRIC COM=$$COM() S:PSOTRIC COM=$$TCOM^PSOREJP3(RX,RFL) 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,1) I $D(DIRUT) S ACTION="D" D DISPLAY^PSOREJU3(RX,REJ) G ASK
;
Q ACTION
;
DC(RX,ACTION,DC1) ; Discontinue inside and outside call
; DC1 Indicates that DIRUT needs to be returned if applicable
S DC1=+$G(DC1)
N RXN,MSG,REA,DA,PSCAN,RXNUM
S DA=RX,RXNUM=""
; Set PSOTRIC, if not already set. PSOTRIC is used by NOOR^PSOCAN4,
; which is called by COM^PSOCAN1.
I '$D(PSOTRIC) N PSOTRIC S PSOTRIC=$$TRIC^PSOREJP1(RX)
N VALMBCK,PS
S VALMBCK="",PS="Discontinue"
D YN^PSOCAN I VALMBCK="R" W $C(7)," ACTION NOT TAKEN!",! H 1 S PSORX("DFLG")=1,ACTION="Q" S:DC1 DIRUT=1 Q ACTION
N PKIR
K DIR
D COM^PSOCAN1 I $D(DIRUT) W $C(7)," ACTION NOT TAKEN!",! H 1 S PSORX("DFLG")=1,ACTION="Q" Q ACTION
N PSOCANRD S PSOCANRD=$P(^PSRX(DA,0),"^",4)
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
;
; These two lines may not be needed. It seems premature to remove the
; RX from the label list when the Rx probably hasn't been added yet.
; In addition, PSORXL has code to remove discontinued RXs from the
; label list (using the ECME^PSORXL1 call).
S PSOLST(1)=52_"^"_DA_"^"_$$GET1^DIQ(52,DA,100),ORN=1
N PSOCKDC S PSOCKDC=1 D ECME^PSORXL1 I '$G(PPL) S PPL="" ;remove rx from label print
Q ACTION
;
CONT() ; Ask to continue for bypassing claims processing
N DIR,DIRUT,Y
S DIR(0)="Y",DIR("A")="You are bypassing claims processing. Do you wish to continue",DIR("B")="NO"
D ^DIR
I $D(DIRUT) S Y=0
Q $G(Y)
;
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
; Called by ASK above (Reject Notification Screen)
N COD1,COD2,COD3,DIR,DIRUT W !
S COD1=$$OVRCOD(1,$$GET1^DIQ(52.25,REJ_","_RX,14)) I COD1="^"!(COD1="") Q "^"
S COD2=$$OVRCOD(2) I COD2="^" Q COD2
S COD3=$$OVRCOD(3) I COD3="^" Q COD3
;
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 (COD1_"^"_COD2_"^"_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 up to 3 Clarification Codes
; Called by SMA^PSOREJP1 (SMA action) and CLA^PSOREJP1 (CLA action)
N DIC,X,Y,PSOSCC,DTOUT,DUOUT,PSOQ,PSOI,I,DUP
S DIC(0)="QEAM",DIC=9002313.25,PSOQ=0,PSOSCC=""
S DIC("S")="I $P($G(^(0)),""^"",3)'=1"
F PSOI=1:1:3 Q:PSOQ S DIC("A")="Submission Clarification Code "_PSOI_": " D CLADIC
Q $S(PSOQ=1:"^",1:PSOSCC)
;
CLADIC ;
; DIC variables, PSOI, PSOSCC, and DUP newed and set by CLA
D ^DIC
I ($D(DUOUT))!($D(DTOUT)) S PSOQ=1 Q
I Y=-1 S PSOQ=2 Q
S DUP=0
F I=1:1:PSOI I $P(PSOSCC,"~",I)=$P(Y,U,2) S DUP=1 Q
I DUP=1 W " Duplicates not allowed",! G CLADIC
S $P(PSOSCC,"~",PSOI)=$P(Y,U,2)
Q
;
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,943")
; (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,"D"-Discontinue,"^"-Up-arrow entered
;
N ACTION,NEWDATA,PSOTRIC,REJ,REJDATA,REJI,REJIEN,RESP,RESPI,RESPREJ,RRR
S ACTION="",RRR=0
I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
;
; Get all open/unresolved rejects
I '$$FIND^PSOREJUT(RX,RFL,.REJDATA) Q ACTION
;
S PSOTRIC=$$TRIC^PSOREJP1(RX,RFL)
;
; Check for TRICARE/CHAMPVA open rejects
I PSOTRIC D HDLGTC(.REJDATA,.OPTS,.DEF,.CODES,DUZ)
;
; In progress TRICARE/CHAMPVA Rx not allowed to be filled
I PSOTRIC,$$STATUS^PSOBPSUT(RX,RFL)["IN PROGRESS" D TRICCHK^PSOREJU3(RX,RFL,"",FROM) Q ACTION
;
; Check for VET with open RRR rejects, PSO*421
I 'PSOTRIC D HDLGRRR(.REJDATA,.OPTS,.DEF,.RRR,.CODES)
;
; Check for open rejects that match CODES
I '$$FIND^PSOREJUT(RX,RFL,.REJDATA,CODES) Q ACTION
;
; Get reject for last response, if multiple responses exist.
S REJ=$O(REJDATA(""))
S ACTION=$$ACTION(RX,REJ,OPTS,$G(DEF),RRR)
;
; Loop through each REJECT IEN and perform action
S REJI="" F S REJI=$O(REJDATA(REJI)) Q:REJI="" D
. I $P(ACTION,"^")="I" D CLOSE^PSOREJUT(RX,RFL,REJI,DUZ,6,$P(ACTION,"^",2),"","","","","",1) D AUDIT^PSOTRI(RX,RFL,,$P(ACTION,"^",2),$S($$PSOET^PSOREJP3(RX,RFL):"N",1:"R"),$S(PSOTRIC=1:"T",PSOTRIC=2:"C",1:""))
. I $P(ACTION,"^")="O" D CLOSE^PSOREJUT(RX,RFL,REJI,DUZ,1,,$P(ACTION,"^",2,4))
. I $P(ACTION,"^")="D" D CLOSE^PSOREJUT(RX,RFL,REJI,DUZ,7,,$P(ACTION,"^",2))
. Q
. ;
; Resubmit claim if overriding
I $P(ACTION,"^")="O" D
. 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)
. . Q
. ;
. ; Get all open/unresolved rejects
. K NEWDATA I $$FIND^PSOREJUT(RX,RFL,.NEWDATA) D I ACTION="Q"!(ACTION="^") Q
. . ;
. . ;For TRICARE/CHAMPVA, override OPTS and DEF if necessary
. . I PSOTRIC D HDLGTC(.NEWDATA,.OPTS,.DEF,.CODES,DUZ)
. . ;
. . ;For Vet, override OPTS, DEF and set up RRR variable if necessary
. . I 'PSOTRIC D HDLGRRR(.NEWDATA,.OPTS,.DEF,.RRR,.CODES)
. . S OPTS=$TR(OPTS,"O") ; Remove the "O" to prevent the user from picking the override option repeatedly
. . I '$$FIND^PSOREJUT(RX,RFL,.NEWDATA,CODES) Q
. . S ACTION=$$ACTION(RX,$O(NEWDATA("")),OPTS,$G(DEF),RRR) I ACTION="Q"!(ACTION="^") Q
. . I $P(ACTION,"^")="I" D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,6,$P(ACTION,"^",2),"","","","","",1) D AUDIT^PSOTRI(RX,RFL,,$P(ACTION,"^",2),"R",$S(PSOTRIC=1:"T",PSOTRIC=2:"C",1:""))
. . I $P(ACTION,"^")="O" D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,1,,$P(ACTION,"^",2,4))
. . Q
. Q
;
Q ACTION
;
HDLGRRR(RRRDATA,OPTS,DEF,RRR,CODES) ; Check for VET with open RRR rejects, new tag PSO*421
; Input: (r) RRRDATA - reject array returned by $$FIND
; (r) OPTS - Available options ("QIDO" for QUIT/IGNORE/DISCONTINUE/OVERRIDE)
; - possibly modified by subroutine
; (r) DEF - Default Option ("O", "I" or "Q")
; - possibly modified by subroutine
; (r) CODES - Open reject codes
; - modified by subroutine
; Output:(r) RRR - Reject Resolution Required information Flag(0/1)^Threshold Amt^Gross Amt Due
; - only return a value for RRR if not 79 or 88 or 943
;
N REJIEN,EX7988,SAVECODES
S SAVECODES=CODES
S (REJIEN,CODES)="",RRR=0,EX7988=0
;
; Set CODES with all open RRR, 79, 88, and 943 reject codes for RX/Fill returned from $$FIND
F S REJIEN=$O(RRRDATA(REJIEN)) Q:(REJIEN="")!EX7988 D
. ;
. ; Find RRR reject
. I RRRDATA(REJIEN,"RRR FLAG")="YES" D Q
. . S RRR=1_U_RRRDATA(REJIEN,"RRR THRESHOLD AMT")_U_RRRDATA(REJIEN,"RRR GROSS AMT DUE")
. . S CODES=RRRDATA(REJIEN,"CODE")_","_CODES
. . Q
. ;
. ; If reject code 79 or 88 or 943 is present, then don't set up RRR for display on reject notification screen (EX7988=1)
. I "/79/88/943/"[("/"_RRRDATA(REJIEN,"CODE")_"/") S RRR=0,EX7988=1
. Q
;
I 'RRR S CODES=SAVECODES Q ;if not RRR, don't override CODES
;
; Strip the last comma off CODES
I $E(CODES,$L(CODES))="," S CODES=$E(CODES,1,$L(CODES)-1)
;
; Set action prompt.
S OPTS="IQ",DEF="Q"
Q
;
HDLGTC(REJDATA,OPTS,DEF,CODES,DUZ) ; Check for TRICARE/CHAMPVA open rejects
; Input: (r) REJDATA - reject array returned by $$FIND
; (r) OPTS - Available options ("QIDO" for QUIT/IGNORE/DISCONTINUE/OVERRIDE)
; - possibly modified by subroutine
; (r) DEF - Default Option ("O", "I" or "Q")
; - possibly modified by subroutine
; (r) CODES - Open reject codes
; - modified by subroutine
; (r) DUZ - Internal IEN of user
N REJIEN
S (REJIEN,CODES)=""
;
; Set CODES with all open reject codes for RX/Fill returned from $$FIND
F S REJIEN=$O(REJDATA(REJIEN)) Q:REJIEN="" S CODES=REJDATA(REJIEN,"CODE")_","_CODES
;
; Strip the last comma off CODES
I $E(CODES,$L(CODES))="," S CODES=$E(CODES,1,$L(CODES)-1)
;
; Set action prompt.
S DEF="Q"
S OPTS="DQ"
I (","_CODES_",")[(",79,") S OPTS="ODQ"
I (","_CODES_",")[(",88,") S OPTS="ODQ"
I (","_CODES_",")[(",943,") S OPTS="ODQ"
;
; Include the Ignore action prompt if user holds key.
I $D(^XUSEC("PSO TRICARE/CHAMPVA",DUZ)) S OPTS=OPTS_"I"
Q
;
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 Q CODE_" - "_$$GET1^DIQ(FILE,+Y,1)
Q ""
;
;
OVRCOD(TYPE,VALUE) ; Prompt for NCPDP Override Codes
; Called by OVR above (reject notification screen), OVR^PSOREJP1 (OVR action)
N DIC,DTOUT,DUOUT,FILE,PRPT,X,Y
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)="AQE",DIC("A")=PRPT
I $G(VALUE)'="" S DIC("B")=VALUE
S DIC("S")="I $P($G(^(0)),""^"",3)'=1"
D ^DIC
I $D(DTOUT)!$D(DUOUT) Q "^"
; At second and third prompts of the set, user entering no data is like exiting the option
I TYPE'=1,Y<0 Q "^"
Q $P(Y,"^",2)
;
OVRCOD1(VALUE,NUM) ; Prompt for Reason for Service Code
; Called by SMAOVR (SMA action) only
N DIR,DTOUT,DTOUT,DIRUT,DIROUT,KFLAG,X,Y
S DIR(0)="P^9002313.23:AOEMZ"
S DIR("A")="Reason for Service Code "_NUM_" "
S DIR("B")=VALUE
S DIR("PRE")="I X=""@"" S X=""^"",KFLAG=1"
S KFLAG=0
S DIR("S")="I $P($G(^(0)),""^"",3)'=1"
D ^DIR Q:KFLAG "@"
I $D(DIRUT)!$D(DIROUT) Q "^"
Q $P(Y,"^",2)
;
OVRCOD2(TYPE,VALUE,NUM) ; Prompt for NCPDP Override Codes
; Called by SMAOVR (SMA action) only
N DIC,DTOUT,DUOUT,FILE,PRPT,X,Y
I TYPE=1 S FILE=9002313.23,PRPT="Reason for Service Code "_NUM_" : "
I TYPE=2 S FILE=9002313.21,PRPT="Professional Service Code "_NUM_": "
I TYPE=3 S FILE=9002313.22,PRPT="Result of Service Code "_NUM_" : "
S DIC=FILE,DIC(0)="AQE",DIC("A")=PRPT
I $G(VALUE)'="" S DIC("B")=VALUE
S DIC("S")="I $P($G(^(0)),""^"",3)'=1"
D ^DIC
I $D(DTOUT)!$D(DUOUT) Q "^"
; At second and third prompts of the set, user entering no data is like exiting the option
I TYPE'=1,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,CLOSED) ; Checks if REJECT has already been logged in the PRESCRIPTION file
; Input: (r) RX - Rx IEN (#52)
; (o) RSP - Response IEN
; (o) CLOSED - If CLOSED=1 and Reject is closed, then do not count as duplicate
; Output: DUP - 1: Already logged (duplicate)
; 0: Not yet logged on PRESCRIPTION file
N DUP,IDX
I $G(CLOSED)="" S CLOSED=0
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
. I CLOSED=1,+$$GET1^DIQ(52.25,IDX_","_RX,9,"I")=1 S DUP=0
Q DUP
;
OTH(CODE,LST) ; Removes the current Reject code from the list
; Input: (r) CODE - Current Reject Code (79 or 88 or 943)
; (o) LST - List of all Reject codes with response (comma separated)
; Output: OTH - List of OTHER Reject codes (w/out 79 or 88 or 943)
;
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)
;
DSC(FILE,VALUE,FIELD) ; Look up code descriptions
N IEN
I '$G(FILE)!($G(VALUE)="")!('$G(FIELD)) Q ""
I '$D(^BPS(FILE)) Q ""
I '$D(^BPS(FILE,"B",VALUE)) Q ""
S IEN=$O(^BPS(FILE,"B",VALUE,"")) I '$D(^BPS(FILE,IEN)) Q ""
Q $$GET1^DIQ(FILE,IEN,FIELD)
;
SMAOVR(RSC,NUM) ; - Ask for OVERRIDE codes - allows deletion of defaults - PSO*7*421
; Called by SMA^PSOREJP1 (SMA action)
;
; INPUT: RSC - Reason for Service code
; NUM - Sequence number (1-3)
;
N COD1,COD2,COD3 W !
I RSC]"" S COD1=$$OVRCOD1($G(RSC),NUM) I COD1="^"!(COD1="")!(COD1="@") Q COD1
I RSC']"" S COD1=$$OVRCOD2(1,$G(RSC),NUM) I COD1="^"!(COD1="") Q COD1
S COD2=$$OVRCOD2(2,"",NUM) I COD2="^" Q "^"
S COD3=$$OVRCOD2(3,"",NUM) I COD3="^" Q "^"
Q (COD1_U_COD2_U_COD3)
;
IGNORE(RX,RFL) ;
; RX = Prescription IEN
; RFL = Refill
; Return value 1 = Allow IGNORE.
; Return value 0 = Don't allow IGNORE.
; Return value 0^GrossAmtDue = Don't allow. Return amt for user msg.
;
N DIR,DIRUT,PSOAMT,PSODIV,PSODIVIEN,PSOIGNORE
;
; Get Gross Amount Due
S PSOAMT=$$AMT^BPSBUTL(RX,RFL) ; DBIA #4719
;
; Get Ignore Threshold Value
S PSODIV=$$GET1^DIQ(52,RX,20,"I")
S PSODIVIEN=$O(^PS(52.86,"B",PSODIV,""))
S PSOIGNORE=$$GET1^DIQ(52.86,PSODIVIEN,7)
;
; If Ignore Threshold is NIL or Gross Amt Due < Ignore
; Threshold - Allow IGNORE. Check of security key not
; required for these conditions.
I (PSOIGNORE="")!(PSOAMT<PSOIGNORE) Q 1
;
; At this point Gross Amt Due is equal to or greater
; than the Ignore Threshold. User must have required
; security key to continue.
;
S PSOAMT=$J(PSOAMT*100\1/100,0,2)
;
; User does not have required security key to continue.
; Don't allow IGNORE. Return PSOAMT to be used in message
; to user.
I '$D(^XUSEC("PSO EPHARMACY SITE MANAGER",DUZ)) Q 0_"^"_PSOAMT
;
; User has required security key. Prompt if OK to continue.
S DIR(0)="Y"
S DIR("A")="Gross Amount Due is $"_PSOAMT_". Do you want to continue (Y/N)"
S DIR("B")="NO"
D ^DIR
I $D(DIRUT) Q 0
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOREJU1 18819 printed Apr 09, 2024@21:36:37 Page 2
PSOREJU1 ;BIRM/MFR - BPS (ECME) - Clinical Rejects Utilities (1) ;10/15/04
+1 ;;7.0;OUTPATIENT PHARMACY;**148,247,260,287,289,358,359,385,403,421,482,562,702**;DEC 1997;Build 14
+2 ; Reference to File 9002313.21 - BPS NCPDP PROFESSIONAL SERVICE CODE in ICR #4712
+3 ; Reference to File 9002313.22 - BPS NCPDP RESULT OF SERVICE CODE in ICR #4713
+4 ; Reference to File 9002313.23 - BPS NCPDP REASON FOR SERVICE CODE in ICR #4714
+5 ; Reference to File 9002313.25 - BPS NCPDP SUBMISSION CLARIFICATION CODE in ICR #5064
+6 ; Reference to File 200 - NEW PERSON in ICR #10060
+7 ; Reference to SIG^XUSESIG in ICR #10050
+8 ; Reference to AMT^BPSBUTL in ICR #4719
+9 ;
ACTION(RX,REJ,OPTS,DEF,RRR) ;
+1 ; Input: (r) RX - Rx IEN (#52)
+2 ; (r) REJ - REJECT ID (IEN)
+3 ; (r) OPTS - Available options ("QIDO" for QUIT/IGNORE/DISCONTINUE/OVERRIDE)
+4 ; (o) DEF - Default Option ("O", "I" or "Q")
+5 ; (o) RRR - Reject Resolution Required information Flag(0/1)^Threshold Amt^Gross Amt Due (Default: 0)
+6 ; If Flag = 0, there is no Reject Resolution Required reject code.
+7 ; Output: ACTION: "I^Comments" - Ignore Reject
+8 ; "O^COD1^COD2^COD3" - Override with the Override codes COD1(Prof.),COD2(Reason) and COD3(Result)
+9 ; "D" - Discontinue
+10 ; "Q" - Quit
+11 ; "^" - Up-arrow entered or timed out
+12 ;
+13 NEW ACTION,COM,OVR,X,DIR,DIRUT,Y
+14 ;
+15 IF '$GET(RX)!'$GET(REJ)
QUIT
+16 IF '$GET(PSONBILL)
if '$DATA(^PSRX(RX,"REJ",REJ))
QUIT
+17 ;
+18 ; Display reject information
+19 DO DISPLAY^PSOREJU3(RX,REJ,,RRR)
+20 ;
ASK ;
+1 KILL ACTION,DIR,DIRUT
+2 SET DIR(0)="SO^"
SET DIR("A")=""
+3 if (OPTS["O")
SET DIR(0)=DIR(0)_"O:(O)VERRIDE - RESUBMIT WITH OVERRIDE CODES;"
SET DIR("A")=DIR("A")_"(O)verride,"
+4 if (OPTS["I")
SET DIR(0)=DIR(0)_"I:(I)GNORE - FILL Rx WITHOUT CLAIM SUBMISSION;"
SET DIR("A")=DIR("A")_"(I)gnore,"
+5 if (OPTS["D")
SET DIR(0)=DIR(0)_"D:(D)iscontinue - DO NOT FILL PRESCRIPTION;"
SET DIR("A")=DIR("A")_"(D)iscontinue,"
+6 if (OPTS["Q")
SET DIR(0)=DIR(0)_"Q:(Q)UIT - SEND TO WORKLIST (REQUIRES INTERVENTION);"
SET DIR("A")=DIR("A")_"(Q)uit,"
+7 SET $EXTRACT(DIR(0),$LENGTH(DIR(0)))=""
SET $EXTRACT(DIR("A"),$LENGTH(DIR("A")))=""
SET DIR("??")="^D HELP^PSOREJU2("""_OPTS_""")"
+8 if $GET(DEF)'=""
SET DIR("B")=DEF
+9 DO ^DIR
+10 IF $DATA(DIRUT)
WRITE !
QUIT "Q"
+11 SET ACTION=Y
+12 ;
+13 ; STOP/QUIT Action
+14 IF ACTION="Q"
QUIT ACTION
+15 ;
+16 ; IGNORE Action
+17 KILL DIR,DIRUT,X
+18 ;
+19 NEW PSOIT
+20 SET PSOIT=""
+21 IF ACTION="I"
SET PSOIT=$$IGNORE(RX,RFL)
+22 IF $PIECE(PSOIT,"^")=0
Begin DoDot:1
+23 IF $PIECE(PSOIT,"^",2)'=""
Begin DoDot:2
+24 WRITE $CHAR(7),!,"Gross Amount Due is $"_$PIECE(PSOIT,"^",2)_". IGNORE requires EPHARMACY SITE MANAGER key.",!
End DoDot:2
End DoDot:1
GOTO ASK
+25 ;
+26 ; If TRICARE/CHAMPVA, require confirmation before ignoring.
+27 IF PSOTRIC
IF ACTION="I"
IF '$$CONT
WRITE $CHAR(7),!," ACTION NOT TAKEN!",!
HANG 1
GOTO ASK
+28 ;
+29 IF ACTION="I"
if 'PSOTRIC
SET COM=$$COM()
if PSOTRIC
SET COM=$$TCOM^PSOREJP3(RX,RFL)
if COM="^"
GOTO ASK
if '$$SIG()
GOTO ASK
SET ACTION=ACTION_"^"_COM
+30 ;
+31 ; OVERRIDE Action
+32 IF ACTION="O"
Begin DoDot:1
+33 SET OVR=$$OVR()
SET ACTION=ACTION_"^"_OVR
End DoDot:1
if OVR="^"
GOTO ASK
+34 ;
DC1 ;Discontinue
+1 IF ACTION="D"
SET ACTION=$$DC(RX,ACTION,1)
IF $DATA(DIRUT)
SET ACTION="D"
DO DISPLAY^PSOREJU3(RX,REJ)
GOTO ASK
+2 ;
+3 QUIT ACTION
+4 ;
DC(RX,ACTION,DC1) ; Discontinue inside and outside call
+1 ; DC1 Indicates that DIRUT needs to be returned if applicable
+2 SET DC1=+$GET(DC1)
+3 NEW RXN,MSG,REA,DA,PSCAN,RXNUM
+4 SET DA=RX
SET RXNUM=""
+5 ; Set PSOTRIC, if not already set. PSOTRIC is used by NOOR^PSOCAN4,
+6 ; which is called by COM^PSOCAN1.
+7 IF '$DATA(PSOTRIC)
NEW PSOTRIC
SET PSOTRIC=$$TRIC^PSOREJP1(RX)
+8 NEW VALMBCK,PS
+9 SET VALMBCK=""
SET PS="Discontinue"
+10 DO YN^PSOCAN
IF VALMBCK="R"
WRITE $CHAR(7)," ACTION NOT TAKEN!",!
HANG 1
SET PSORX("DFLG")=1
SET ACTION="Q"
if DC1
SET DIRUT=1
QUIT ACTION
+11 NEW PKIR
+12 KILL DIR
+13 DO COM^PSOCAN1
IF $DATA(DIRUT)
WRITE $CHAR(7)," ACTION NOT TAKEN!",!
HANG 1
SET PSORX("DFLG")=1
SET ACTION="Q"
QUIT ACTION
+14 NEW PSOCANRD
SET PSOCANRD=$PIECE(^PSRX(DA,0),"^",4)
+15 DO REQ^PSOCAN4
IF $DATA(DIRUT)
WRITE $CHAR(7)," ACTION NOT TAKEN!",!
HANG 1
SET PSORX("DFLG")=1
SET ACTION="Q"
QUIT ACTION
+16 SET REA="C"
SET RXNUM=$PIECE(^PSRX(DA,0),"^")
+17 SET MSG="Discontinued "_$SELECT($GET(PSOFDR):" from Reject Processing Screen",1:"")
+18 SET PSCAN(RXNUM)=DA_"^C"
+19 DO CAN^PSOCAN
+20 ;
+21 ; These two lines may not be needed. It seems premature to remove the
+22 ; RX from the label list when the Rx probably hasn't been added yet.
+23 ; In addition, PSORXL has code to remove discontinued RXs from the
+24 ; label list (using the ECME^PSORXL1 call).
+25 SET PSOLST(1)=52_"^"_DA_"^"_$$GET1^DIQ(52,DA,100)
SET ORN=1
+26 ;remove rx from label print
NEW PSOCKDC
SET PSOCKDC=1
DO ECME^PSORXL1
IF '$GET(PPL)
SET PPL=""
+27 QUIT ACTION
+28 ;
CONT() ; Ask to continue for bypassing claims processing
+1 NEW DIR,DIRUT,Y
+2 SET DIR(0)="Y"
SET DIR("A")="You are bypassing claims processing. Do you wish to continue"
SET DIR("B")="NO"
+3 DO ^DIR
+4 IF $DATA(DIRUT)
SET Y=0
+5 QUIT $GET(Y)
+6 ;
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
+4 IF $DATA(DIRUT)
SET COM="^"
+5 QUIT COM
+6 ;
OVR() ; Ask for OVERRIDE codes
+1 ; Called by ASK above (Reject Notification Screen)
+2 NEW COD1,COD2,COD3,DIR,DIRUT
WRITE !
+3 SET COD1=$$OVRCOD(1,$$GET1^DIQ(52.25,REJ_","_RX,14))
IF COD1="^"!(COD1="")
QUIT "^"
+4 SET COD2=$$OVRCOD(2)
IF COD2="^"
QUIT COD2
+5 SET COD3=$$OVRCOD(3)
IF COD3="^"
QUIT COD3
+6 ;
+7 DO OVRDSP^PSOREJU1(COD1_"^"_COD2_"^"_COD3)
+8 WRITE !
+9 ;
+10 SET DIR(0)="Y"
SET DIR("A")=" Confirm? "
SET DIR("B")="YES"
+11 DO ^DIR
+12 IF $GET(Y)=0!$DATA(DIRUT)
QUIT "^"
+13 ;
+14 QUIT (COD1_"^"_COD2_"^"_COD3)
+15 ;
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 up to 3 Clarification Codes
+1 ; Called by SMA^PSOREJP1 (SMA action) and CLA^PSOREJP1 (CLA action)
+2 NEW DIC,X,Y,PSOSCC,DTOUT,DUOUT,PSOQ,PSOI,I,DUP
+3 SET DIC(0)="QEAM"
SET DIC=9002313.25
SET PSOQ=0
SET PSOSCC=""
+4 SET DIC("S")="I $P($G(^(0)),""^"",3)'=1"
+5 FOR PSOI=1:1:3
if PSOQ
QUIT
SET DIC("A")="Submission Clarification Code "_PSOI_": "
DO CLADIC
+6 QUIT $SELECT(PSOQ=1:"^",1:PSOSCC)
+7 ;
CLADIC ;
+1 ; DIC variables, PSOI, PSOSCC, and DUP newed and set by CLA
+2 DO ^DIC
+3 IF ($DATA(DUOUT))!($DATA(DTOUT))
SET PSOQ=1
QUIT
+4 IF Y=-1
SET PSOQ=2
QUIT
+5 SET DUP=0
+6 FOR I=1:1:PSOI
IF $PIECE(PSOSCC,"~",I)=$PIECE(Y,U,2)
SET DUP=1
QUIT
+7 IF DUP=1
WRITE " Duplicates not allowed",!
GOTO CLADIC
+8 SET $PIECE(PSOSCC,"~",PSOI)=$PIECE(Y,U,2)
+9 QUIT
+10 ;
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,943")
+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,"D"-Discontinue,"^"-Up-arrow entered
+8 ;
+9 NEW ACTION,NEWDATA,PSOTRIC,REJ,REJDATA,REJI,REJIEN,RESP,RESPI,RESPREJ,RRR
+10 SET ACTION=""
SET RRR=0
+11 IF '$DATA(RFL)
SET RFL=$$LSTRFL^PSOBPSU1(RX)
+12 ;
+13 ; Get all open/unresolved rejects
+14 IF '$$FIND^PSOREJUT(RX,RFL,.REJDATA)
QUIT ACTION
+15 ;
+16 SET PSOTRIC=$$TRIC^PSOREJP1(RX,RFL)
+17 ;
+18 ; Check for TRICARE/CHAMPVA open rejects
+19 IF PSOTRIC
DO HDLGTC(.REJDATA,.OPTS,.DEF,.CODES,DUZ)
+20 ;
+21 ; In progress TRICARE/CHAMPVA Rx not allowed to be filled
+22 IF PSOTRIC
IF $$STATUS^PSOBPSUT(RX,RFL)["IN PROGRESS"
DO TRICCHK^PSOREJU3(RX,RFL,"",FROM)
QUIT ACTION
+23 ;
+24 ; Check for VET with open RRR rejects, PSO*421
+25 IF 'PSOTRIC
DO HDLGRRR(.REJDATA,.OPTS,.DEF,.RRR,.CODES)
+26 ;
+27 ; Check for open rejects that match CODES
+28 IF '$$FIND^PSOREJUT(RX,RFL,.REJDATA,CODES)
QUIT ACTION
+29 ;
+30 ; Get reject for last response, if multiple responses exist.
+31 SET REJ=$ORDER(REJDATA(""))
+32 SET ACTION=$$ACTION(RX,REJ,OPTS,$GET(DEF),RRR)
+33 ;
+34 ; Loop through each REJECT IEN and perform action
+35 SET REJI=""
FOR
SET REJI=$ORDER(REJDATA(REJI))
if REJI=""
QUIT
Begin DoDot:1
+36 IF $PIECE(ACTION,"^")="I"
DO CLOSE^PSOREJUT(RX,RFL,REJI,DUZ,6,$PIECE(ACTION,"^",2),"","","","","",1)
DO AUDIT^PSOTRI(RX,RFL,,$PIECE(ACTION,"^",2),$SELECT($$PSOET^PSOREJP3(RX,RFL):"N",1:"R"),$SELECT(PSOTRIC=1:"T",PSOTRIC=2:"C",1:""))
+37 IF $PIECE(ACTION,"^")="O"
DO CLOSE^PSOREJUT(RX,RFL,REJI,DUZ,1,,$PIECE(ACTION,"^",2,4))
+38 IF $PIECE(ACTION,"^")="D"
DO CLOSE^PSOREJUT(RX,RFL,REJI,DUZ,7,,$PIECE(ACTION,"^",2))
+39 QUIT
+40 ;
End DoDot:1
+41 ; Resubmit claim if overriding
+42 IF $PIECE(ACTION,"^")="O"
Begin DoDot:1
+43 DO ECMESND^PSOBPSU1(RX,RFL,,FROM,$$GETNDC^PSONDCUT(RX,RFL),,,$PIECE(ACTION,"^",2,4),,.RESP)
+44 IF $GET(RESP)
Begin DoDot:2
+45 WRITE !!?10,"Claim could not be submitted. Please try again later!"
+46 WRITE !,?10,"Reason: ",$SELECT($PIECE(RESP,"^",2)="":"UNKNOWN",1:$PIECE(RESP,"^",2)),$CHAR(7)
+47 QUIT
End DoDot:2
QUIT
+48 ;
+49 ; Get all open/unresolved rejects
+50 KILL NEWDATA
IF $$FIND^PSOREJUT(RX,RFL,.NEWDATA)
Begin DoDot:2
+51 ;
+52 ;For TRICARE/CHAMPVA, override OPTS and DEF if necessary
+53 IF PSOTRIC
DO HDLGTC(.NEWDATA,.OPTS,.DEF,.CODES,DUZ)
+54 ;
+55 ;For Vet, override OPTS, DEF and set up RRR variable if necessary
+56 IF 'PSOTRIC
DO HDLGRRR(.NEWDATA,.OPTS,.DEF,.RRR,.CODES)
+57 ; Remove the "O" to prevent the user from picking the override option repeatedly
SET OPTS=$TRANSLATE(OPTS,"O")
+58 IF '$$FIND^PSOREJUT(RX,RFL,.NEWDATA,CODES)
QUIT
+59 SET ACTION=$$ACTION(RX,$ORDER(NEWDATA("")),OPTS,$GET(DEF),RRR)
IF ACTION="Q"!(ACTION="^")
QUIT
+60 IF $PIECE(ACTION,"^")="I"
DO CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,6,$PIECE(ACTION,"^",2),"","","","","",1)
DO AUDIT^PSOTRI(RX,RFL,,$PIECE(ACTION,"^",2),"R",$SELECT(PSOTRIC=1:"T",PSOTRIC=2:"C",1:""))
+61 IF $PIECE(ACTION,"^")="O"
DO CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,1,,$PIECE(ACTION,"^",2,4))
+62 QUIT
End DoDot:2
IF ACTION="Q"!(ACTION="^")
QUIT
+63 QUIT
End DoDot:1
+64 ;
+65 QUIT ACTION
+66 ;
HDLGRRR(RRRDATA,OPTS,DEF,RRR,CODES) ; Check for VET with open RRR rejects, new tag PSO*421
+1 ; Input: (r) RRRDATA - reject array returned by $$FIND
+2 ; (r) OPTS - Available options ("QIDO" for QUIT/IGNORE/DISCONTINUE/OVERRIDE)
+3 ; - possibly modified by subroutine
+4 ; (r) DEF - Default Option ("O", "I" or "Q")
+5 ; - possibly modified by subroutine
+6 ; (r) CODES - Open reject codes
+7 ; - modified by subroutine
+8 ; Output:(r) RRR - Reject Resolution Required information Flag(0/1)^Threshold Amt^Gross Amt Due
+9 ; - only return a value for RRR if not 79 or 88 or 943
+10 ;
+11 NEW REJIEN,EX7988,SAVECODES
+12 SET SAVECODES=CODES
+13 SET (REJIEN,CODES)=""
SET RRR=0
SET EX7988=0
+14 ;
+15 ; Set CODES with all open RRR, 79, 88, and 943 reject codes for RX/Fill returned from $$FIND
+16 FOR
SET REJIEN=$ORDER(RRRDATA(REJIEN))
if (REJIEN="")!EX7988
QUIT
Begin DoDot:1
+17 ;
+18 ; Find RRR reject
+19 IF RRRDATA(REJIEN,"RRR FLAG")="YES"
Begin DoDot:2
+20 SET RRR=1_U_RRRDATA(REJIEN,"RRR THRESHOLD AMT")_U_RRRDATA(REJIEN,"RRR GROSS AMT DUE")
+21 SET CODES=RRRDATA(REJIEN,"CODE")_","_CODES
+22 QUIT
End DoDot:2
QUIT
+23 ;
+24 ; If reject code 79 or 88 or 943 is present, then don't set up RRR for display on reject notification screen (EX7988=1)
+25 IF "/79/88/943/"[("/"_RRRDATA(REJIEN,"CODE")_"/")
SET RRR=0
SET EX7988=1
+26 QUIT
End DoDot:1
+27 ;
+28 ;if not RRR, don't override CODES
IF 'RRR
SET CODES=SAVECODES
QUIT
+29 ;
+30 ; Strip the last comma off CODES
+31 IF $EXTRACT(CODES,$LENGTH(CODES))=","
SET CODES=$EXTRACT(CODES,1,$LENGTH(CODES)-1)
+32 ;
+33 ; Set action prompt.
+34 SET OPTS="IQ"
SET DEF="Q"
+35 QUIT
+36 ;
HDLGTC(REJDATA,OPTS,DEF,CODES,DUZ) ; Check for TRICARE/CHAMPVA open rejects
+1 ; Input: (r) REJDATA - reject array returned by $$FIND
+2 ; (r) OPTS - Available options ("QIDO" for QUIT/IGNORE/DISCONTINUE/OVERRIDE)
+3 ; - possibly modified by subroutine
+4 ; (r) DEF - Default Option ("O", "I" or "Q")
+5 ; - possibly modified by subroutine
+6 ; (r) CODES - Open reject codes
+7 ; - modified by subroutine
+8 ; (r) DUZ - Internal IEN of user
+9 NEW REJIEN
+10 SET (REJIEN,CODES)=""
+11 ;
+12 ; Set CODES with all open reject codes for RX/Fill returned from $$FIND
+13 FOR
SET REJIEN=$ORDER(REJDATA(REJIEN))
if REJIEN=""
QUIT
SET CODES=REJDATA(REJIEN,"CODE")_","_CODES
+14 ;
+15 ; Strip the last comma off CODES
+16 IF $EXTRACT(CODES,$LENGTH(CODES))=","
SET CODES=$EXTRACT(CODES,1,$LENGTH(CODES)-1)
+17 ;
+18 ; Set action prompt.
+19 SET DEF="Q"
+20 SET OPTS="DQ"
+21 IF (","_CODES_",")[(",79,")
SET OPTS="ODQ"
+22 IF (","_CODES_",")[(",88,")
SET OPTS="ODQ"
+23 IF (","_CODES_",")[(",943,")
SET OPTS="ODQ"
+24 ;
+25 ; Include the Ignore action prompt if user holds key.
+26 IF $DATA(^XUSEC("PSO TRICARE/CHAMPVA",DUZ))
SET OPTS=OPTS_"I"
+27 QUIT
+28 ;
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
QUIT CODE_" - "_$$GET1^DIQ(FILE,+Y,1)
+8 QUIT ""
+9 ;
+10 ;
OVRCOD(TYPE,VALUE) ; Prompt for NCPDP Override Codes
+1 ; Called by OVR above (reject notification screen), OVR^PSOREJP1 (OVR action)
+2 NEW DIC,DTOUT,DUOUT,FILE,PRPT,X,Y
+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)="AQE"
SET DIC("A")=PRPT
+7 IF $GET(VALUE)'=""
SET DIC("B")=VALUE
+8 SET DIC("S")="I $P($G(^(0)),""^"",3)'=1"
+9 DO ^DIC
+10 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT "^"
+11 ; At second and third prompts of the set, user entering no data is like exiting the option
+12 IF TYPE'=1
IF Y<0
QUIT "^"
+13 QUIT $PIECE(Y,"^",2)
+14 ;
OVRCOD1(VALUE,NUM) ; Prompt for Reason for Service Code
+1 ; Called by SMAOVR (SMA action) only
+2 NEW DIR,DTOUT,DTOUT,DIRUT,DIROUT,KFLAG,X,Y
+3 SET DIR(0)="P^9002313.23:AOEMZ"
+4 SET DIR("A")="Reason for Service Code "_NUM_" "
+5 SET DIR("B")=VALUE
+6 SET DIR("PRE")="I X=""@"" S X=""^"",KFLAG=1"
+7 SET KFLAG=0
+8 SET DIR("S")="I $P($G(^(0)),""^"",3)'=1"
+9 DO ^DIR
if KFLAG
QUIT "@"
+10 IF $DATA(DIRUT)!$DATA(DIROUT)
QUIT "^"
+11 QUIT $PIECE(Y,"^",2)
+12 ;
OVRCOD2(TYPE,VALUE,NUM) ; Prompt for NCPDP Override Codes
+1 ; Called by SMAOVR (SMA action) only
+2 NEW DIC,DTOUT,DUOUT,FILE,PRPT,X,Y
+3 IF TYPE=1
SET FILE=9002313.23
SET PRPT="Reason for Service Code "_NUM_" : "
+4 IF TYPE=2
SET FILE=9002313.21
SET PRPT="Professional Service Code "_NUM_": "
+5 IF TYPE=3
SET FILE=9002313.22
SET PRPT="Result of Service Code "_NUM_" : "
+6 SET DIC=FILE
SET DIC(0)="AQE"
SET DIC("A")=PRPT
+7 IF $GET(VALUE)'=""
SET DIC("B")=VALUE
+8 SET DIC("S")="I $P($G(^(0)),""^"",3)'=1"
+9 DO ^DIC
+10 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT "^"
+11 ; At second and third prompts of the set, user entering no data is like exiting the option
+12 IF TYPE'=1
IF Y<0
QUIT "^"
+13 QUIT $PIECE(Y,"^",2)
+14 ;
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,CLOSED) ; Checks if REJECT has already been logged in the PRESCRIPTION file
+1 ; Input: (r) RX - Rx IEN (#52)
+2 ; (o) RSP - Response IEN
+3 ; (o) CLOSED - If CLOSED=1 and Reject is closed, then do not count as duplicate
+4 ; Output: DUP - 1: Already logged (duplicate)
+5 ; 0: Not yet logged on PRESCRIPTION file
+6 NEW DUP,IDX
+7 IF $GET(CLOSED)=""
SET CLOSED=0
+8 SET (DUP,IDX)=0
+9 FOR
SET IDX=$ORDER(^PSRX(RX,"REJ",IDX))
if 'IDX
QUIT
Begin DoDot:1
+10 IF +RSP=+$$GET1^DIQ(52.25,IDX_","_RX,16,"I")
SET DUP=1
+11 IF CLOSED=1
IF +$$GET1^DIQ(52.25,IDX_","_RX,9,"I")=1
SET DUP=0
End DoDot:1
if DUP
QUIT
+12 QUIT DUP
+13 ;
OTH(CODE,LST) ; Removes the current Reject code from the list
+1 ; Input: (r) CODE - Current Reject Code (79 or 88 or 943)
+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 or 943)
+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)
+4 ;
DSC(FILE,VALUE,FIELD) ; Look up code descriptions
+1 NEW IEN
+2 IF '$GET(FILE)!($GET(VALUE)="")!('$GET(FIELD))
QUIT ""
+3 IF '$DATA(^BPS(FILE))
QUIT ""
+4 IF '$DATA(^BPS(FILE,"B",VALUE))
QUIT ""
+5 SET IEN=$ORDER(^BPS(FILE,"B",VALUE,""))
IF '$DATA(^BPS(FILE,IEN))
QUIT ""
+6 QUIT $$GET1^DIQ(FILE,IEN,FIELD)
+7 ;
SMAOVR(RSC,NUM) ; - Ask for OVERRIDE codes - allows deletion of defaults - PSO*7*421
+1 ; Called by SMA^PSOREJP1 (SMA action)
+2 ;
+3 ; INPUT: RSC - Reason for Service code
+4 ; NUM - Sequence number (1-3)
+5 ;
+6 NEW COD1,COD2,COD3
WRITE !
+7 IF RSC]""
SET COD1=$$OVRCOD1($GET(RSC),NUM)
IF COD1="^"!(COD1="")!(COD1="@")
QUIT COD1
+8 IF RSC']""
SET COD1=$$OVRCOD2(1,$GET(RSC),NUM)
IF COD1="^"!(COD1="")
QUIT COD1
+9 SET COD2=$$OVRCOD2(2,"",NUM)
IF COD2="^"
QUIT "^"
+10 SET COD3=$$OVRCOD2(3,"",NUM)
IF COD3="^"
QUIT "^"
+11 QUIT (COD1_U_COD2_U_COD3)
+12 ;
IGNORE(RX,RFL) ;
+1 ; RX = Prescription IEN
+2 ; RFL = Refill
+3 ; Return value 1 = Allow IGNORE.
+4 ; Return value 0 = Don't allow IGNORE.
+5 ; Return value 0^GrossAmtDue = Don't allow. Return amt for user msg.
+6 ;
+7 NEW DIR,DIRUT,PSOAMT,PSODIV,PSODIVIEN,PSOIGNORE
+8 ;
+9 ; Get Gross Amount Due
+10 ; DBIA #4719
SET PSOAMT=$$AMT^BPSBUTL(RX,RFL)
+11 ;
+12 ; Get Ignore Threshold Value
+13 SET PSODIV=$$GET1^DIQ(52,RX,20,"I")
+14 SET PSODIVIEN=$ORDER(^PS(52.86,"B",PSODIV,""))
+15 SET PSOIGNORE=$$GET1^DIQ(52.86,PSODIVIEN,7)
+16 ;
+17 ; If Ignore Threshold is NIL or Gross Amt Due < Ignore
+18 ; Threshold - Allow IGNORE. Check of security key not
+19 ; required for these conditions.
+20 IF (PSOIGNORE="")!(PSOAMT<PSOIGNORE)
QUIT 1
+21 ;
+22 ; At this point Gross Amt Due is equal to or greater
+23 ; than the Ignore Threshold. User must have required
+24 ; security key to continue.
+25 ;
+26 SET PSOAMT=$JUSTIFY(PSOAMT*100\1/100,0,2)
+27 ;
+28 ; User does not have required security key to continue.
+29 ; Don't allow IGNORE. Return PSOAMT to be used in message
+30 ; to user.
+31 IF '$DATA(^XUSEC("PSO EPHARMACY SITE MANAGER",DUZ))
QUIT 0_"^"_PSOAMT
+32 ;
+33 ; User has required security key. Prompt if OK to continue.
+34 SET DIR(0)="Y"
+35 SET DIR("A")="Gross Amount Due is $"_PSOAMT_". Do you want to continue (Y/N)"
+36 SET DIR("B")="NO"
+37 DO ^DIR
+38 IF $DATA(DIRUT)
QUIT 0
+39 QUIT Y
