- 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 Jan 18, 2025@03:34:46 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