PSOREJU4 ;BIRM/LE - Pharmacy Reject Overrides ;06/26/08
;;7.0;OUTPATIENT PHARMACY;**289,290,358,359,385,421,448,561,562,648,702,746,747**;DEC 1997;Build 7
; Reference to DUR1^BPSNCPD3 in ICR #4560
; Reference to $$ELIG^BPSBUTL and $$AMT^BPSBUTL in ICR #4719
; Reference to 9002313.93 in ICR #4720
;
AUTOREJ(CODES,PSODIV) ;API to evaluate an array of reject codes to see if they are allowed to be passed to OP reject Worklist
;Input: CODES - required; array of codes to be validated for overrides.
; PSODIV - optional; Division for the Rx and Fill to be evaluated
;
;Output: CODES(0)=0 always - ALLOW ALL REJECTS flag was inactivated with patch 421
;
; CODES(SEQ,REJECT)= 0 (zero) if the fill is not allowed to be passed to the Pharmacy
; Reject Worklist or 1 (one) for the reject code is allowed.
;
N SEQ,COD,AUTO,ALLOW,SPDIV
;if no division passed, first division in file 59 is assumed.
I '$G(PSODIV) S PSODIV=0,PSODIV=$O(^PS(59,PSODIV))
I '$G(PSODIV) S CODES(0)="0^Division undefined in file 59" Q
S SPDIV="",SPDIV=$O(^PS(52.86,"B",PSODIV,SPDIV))
I SPDIV="" S CODES(0)="0^Division is not defined under ePharmacy Site Parameters option." Q
;
; - all rejects allowed flag obsolete, set to 0 for parameter integrity
S CODES(0)=0
;
; - check individual reject codes. If defined, can be passed to Pharmacy Reject Worklist
S (COD,SEQ)="" F S SEQ=$O(CODES(SEQ)) Q:SEQ="" F S COD=$O(CODES(SEQ,COD)) Q:COD="" D
. I $D(^PS(52.86,+SPDIV,1,"B",COD)) S CODES(SEQ,COD)=1
. E S CODES(SEQ,COD)=0
Q
;
WRKLST(RX,RFL,COMMTXT,USERID,DTTIME,OPECC,RXCOB,RESP) ;External API to store reject codes other than 79/88/943/TRICARE/CHAMPVA on the OP Reject Worklist
;
N CLOSECHK,CODE,DATA,I,IDX,PSODIV,PSOTRIC,REJ,REJCD,REJIDX,REJLST,REJS,SPDVI,TXT
S PSODIV=$$RXSITE^PSOBPSUT(RX,RFL)
L +^PSRX("REJ",RX):15 Q:'$T "0^Rx locked by another user."
I $G(RFL)="" S RFL=$$LSTRFL^PSOBPSU1(RX)
D DUR1^BPSNCPD3(RX,RFL,.REJ,"",RXCOB)
;
S REJCD="",CLOSECHK=0
I $L($G(RESP)) D
. I $P(RESP,"^",3)'="T",$P(RESP,"^",3)'="C" Q ;ignore if not TRICARE or CHAMPVA
. I 'RESP Q ;Piece 1 will be 0 if claim was submitted thru ECME
. S REJCD="e"_$P(RESP,"^",3) ; either eT for TRICARE or eC for CHAMPVA
. S REJ(1,"REJ CODE LST")=REJCD
. S REJ(1,"PAYER MESSAGE",1)="Not ECME Billable: "_$P(RESP,U,2)
. S REJ(1,"ELIGBLT")=$P(RESP,"^",3)
. S CLOSECHK=1
;
S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,PSOTRIC)
K REJS S (AUTO,IDX)=""
F S IDX=$O(REJ(IDX)) Q:IDX="" D Q:AUTO'=""
. S TXT=$G(REJ(IDX,"REJ CODE LST"))
. F I=1:1:$L(TXT,",") D
. . S CODE=$P(TXT,",",I)
. . I CODE="" Q
. . I CODE'="79"&(CODE'="88")&(CODE'="943")&('$G(PSOTRIC)) S AUTO=$$EVAL(PSODIV,CODE,OPECC) Q:'+AUTO
. . I PSOTRIC S AUTO=1 ; Send all billable and non-billable rejects to worklist if TRICARE or CHAMPVA
. . I $$DUP^PSOREJU1(RX,+$$CLEAN^PSOREJU1($G(REJ(IDX,"RESPONSE IEN"))),CLOSECHK) S AUTO="0^Rx is already on Pharmacy Reject Worklist."
. . S REJS(IDX,CODE)=""
I '$D(REJS) L -^PSRX("REJ",RX) S AUTO="0^No action taken" Q AUTO
G EXIT:'+AUTO
;
D SYNC2^PSOREJUT
S AUTO=1
EXIT ;
L -^PSRX("REJ",RX)
Q AUTO
;
EVAL(PSODIV,CODE,OPECC,RX,RFNBR,COB,RRRDATA) ;Evaluates whether the reject codes other than 79/88/TRICARE/CHAMPVA is allowed to be passed to OP Reject Worklist
;Input: PSODIV - required; Division for the Rx and Fill to be evaluated
; CODE - required; external reject code
; OPECC - optional, 1 means manually passed by OPECC 0 or null means not passed
; RX - optional; IEN from prescription file
; RFNBR - optional; refill number
; COB - optional; coordination of benefits
;Output: $$EVAL - Return value - 1 means reject is allowed to be passed to Pharmacy Reject Worklist and
; 0 means not allowed.
; When doing a RRR check, RX, RFNBR & COB are required.
; RRRDATA - passed by reference.
; RRRDATA [1] 1/0 is this an RRR reject?
; [2] gross amount due for the Rx/fill/cob
; [3] $ dollar threshold amount from PSO site parameters
;
N ALLOWA,CIEN,ALLOW,ICOD,SPDIV
I '$D(CODE)!(CODE="") Q 0
I '$G(OPECC) S OPECC=0
I '$G(PSODIV) Q 0
S SPDIV="",SPDIV=$O(^PS(52.86,"B",PSODIV,SPDIV))
Q:SPDIV="" "0^Division is not defined under ePharmacy Site Parameters option."
S:'$G(AUTO) AUTO=""
S ICOD="",ICOD=$O(^BPSF(9002313.93,"B",CODE,ICOD))
Q:ICOD="" 0
;
; Check for Resolution Required Reject code if so, return a 1
I $G(RX),$D(RFNBR),$D(COB) S RRRDATA=$$RRRCHK(SPDIV,ICOD,RX,RFNBR,COB) I +RRRDATA Q 1
;
; Transfer reject processing
Q:'$D(^PS(52.86,SPDIV,1,"B",ICOD)) "0^Reject Code is not allowed to be passed to Pharmacy Reject Worklist."
S CIEN="",CIEN=$O(^PS(52.86,SPDIV,1,"B",ICOD,CIEN))
I CIEN="" S AUTO="0^Code not defined."
S (AUTO,ALLOW)="",ALLOW=$$GET1^DIQ(52.8651,CIEN_","_SPDIV,1,"I")
I ALLOW Q 1
I 'ALLOW D
. I OPECC S AUTO=1
. I 'OPECC S AUTO="0^Reject code "_CODE_" cannot be placed on the Pharmacy Reject Worklist"
Q AUTO
;
INLIST(RX,RFL,RXCOB) ;Returns whether a prescription/fill contains UNRESOLVED rejects
;Input:
;RX - Prescription IEN.
;FILL - Fill number being processed.
;Output:
;0 - the fill is not on the Pharmacy Reject Worklist
;1 - the fill is already on the Pharmacy Reject Worklist
N PSOX,PSOX1,PSOX2,REJDATA1
S PSOX=$$FIND^PSOREJUT(RX,RFL,.REJDATA1,"") I PSOX=0 Q 0
S RXCOB=$S(RXCOB=1:"PRIMARY",RXCOB=2:"SECONDARY")
S PSOX1="" F S PSOX1=$O(REJDATA1(PSOX1)) Q:PSOX1="" I REJDATA1(PSOX1,"COB")=RXCOB S PSOX2=1 Q
I '$G(PSOX2) Q 0
Q 1
;
MULTI(RX,RFL,REJDATA,CODE,REJS,RRRFLG) ;due to routine size, called from FIND^PSOREJUT
;returns REJS = 1 means reject code found on Rx, 0 (zero) means not found
N RCODE,I
I $G(RFL)'="" D
. F I=1:1 S RCODE=$P(CODE,",",I) Q:RCODE=""!($G(REJS)) D GET^PSOREJU2(RX,RFL,.REJDATA,,,$G(RCODE),+$G(RRRFLG)) I $D(REJDATA) S REJS=1
E S RFL=0 D I '$D(REJDATA) F S RFL=$O(^PSRX(RX,1,RFL)) Q:'RFL D Q:$G(REJS)
. F I=1:1 S RCODE=$P(CODE,",",I) Q:RCODE=""!($G(REJS)) D GET^PSOREJU2(RX,RFL,.REJDATA,,,$G(RCODE),+$G(RRRFLG)) I $D(REJDATA) S REJS=1
Q REJS
;
SINGLE(RX,RFL,REJDATA,CODE,REJS,RRRFLG) ;due to routine size, called from FIND^PSOREJUT
;Returns REJS = 1 means reject code found on Rx, 0 (zero) means not found
I $G(RFL)'="" D
. D GET^PSOREJU2(RX,RFL,.REJDATA,,,$G(CODE),+$G(RRRFLG))
E S RFL=0 D I '$D(REJDATA) F S RFL=$O(^PSRX(RX,1,RFL)) Q:'RFL D
. D GET^PSOREJU2(RX,RFL,.REJDATA,,,$G(CODE),+$G(RRRFLG))
S REJS=$S($D(REJDATA):1,1:0)
Q REJS
;
RRRCHK(SPDIV,REJ,RX,RFNBR,COB) ; Test a reject for valid Resolution Required Reject code
; INPUT
; SPDIV = required - IEN in site parameter file for the selected division
; REJ = required - IEN of the Reject code to test
; RX = required - IEN from prescription file
; RFNBR = required - prescription refill number
; COB = optional - coordination of benefits
;
; OUTPUT
; Function Value - Returns an "^" delimited string
; [1] 1/0 is this an RRR reject?
; 1 = Valid resolution required reject code.
; 0 = Invalid resolution required reject code.
; [2] If valid RRR then gross amount due for the Rx/fill/cob else null
; [3] If valid RRR then dollar threshold amount from PSO site parameters else null
;
; For a reject code to be valid each of the following needs to be true:
; 1 - Eligibility must be a veteran type
; 2 - Must be the first fill on a prescription
; 3 - Reject code must be defined in the pharmacy division's site parameters
; as a resolution required reject code.
; 4 - Gross amount must be >= DOLLAR THRESHOLD in the pharmacy division's site
; parameters for the given resolution required reject code.
;
; Verify parameters
I '$G(SPDIV) Q 0
I '$D(^PS(52.86,SPDIV)) Q 0
I '$G(REJ) Q 0
I '$D(^BPSF(9002313.93,REJ,0)) Q 0 ; DBIA 4720
I '$G(RX) Q 0
I '$D(^PSRX(RX)) Q 0
I '$D(RFNBR) Q 0
;
N RRRC,AMT,THRSHLD
; SPDIV = IEN in site parameter file for the selected division
; RRRC = indicates the RESOLUTION REQUIRED REJECT CODE exists for the selected division
; it will be a null or an IEN in the 52.865 sub-file
; AMT = RX gross amount due
; THRSHLD = DOLLAR THRESHOLD for RRR code
;
; Test for released status
I $$GET1^DIQ(52,RX_",",31,"I") Q 0
;
; Test Eligibility - IA 4719
I $$ELIG^BPSBUTL(RX,0,$G(COB))'="V" Q 0
;
; is this a Resolution Required Reject code?
S RRRC=0,RRRC=$O(^PS(52.86,SPDIV,5,"B",REJ,RRRC))
I RRRC="" Q 0
;
; Test gross amount against DOLLAR THRESHOLD
S AMT=$$AMT^BPSBUTL(RX,0,$G(COB))
S THRSHLD=$$GET1^DIQ(52.865,RRRC_","_SPDIV_",",.02)
I AMT<THRSHLD Q 0
Q 1_U_AMT_U_THRSHLD
;
REJCOM(RX,FIL,COB,RET) ; Gather PSO reject comments and return
; Input
; RX - prescription IEN required
; FIL - fill# required - will match with the 52.25,5 field
; COB - coordination of benefits# (optional). If present, will match with the 52.25,27 field
; Output
; RET - return array, pass by reference
; RET(external reject code,date/time of comment,incremental counter) =
; [1] date/time of comment
; [2] user pointer 200
; [3] comment text 1-150 characters
;
N REJ,G0,G2,REJCODE,CMT,H0,PSORJCNT
K RET
I '$G(RX) G REJCOMX
I $G(FIL)="" G REJCOMX
S COB=$G(COB)
S PSORJCNT=0
;
S REJ=0 F S REJ=$O(^PSRX(RX,"REJ",REJ)) Q:'REJ D
. S G0=$G(^PSRX(RX,"REJ",REJ,0)),G2=$G(^PSRX(RX,"REJ",REJ,2))
. I FIL'=$P(G0,U,4) Q ; fill# must match
. I COB,COB'=$P(G2,U,7) Q ; cob# must match if COB is passed in
. S REJCODE=$P(G0,U,1) ; save external reject code
. I REJCODE="" Q
. ;
. S CMT=0 F S CMT=$O(^PSRX(RX,"REJ",REJ,"COM",CMT)) Q:'CMT D
.. S H0=$G(^PSRX(RX,"REJ",REJ,"COM",CMT,0)) I 'H0 Q ; make sure the date/time is there
.. S PSORJCNT=PSORJCNT+1 ; increment the counter for unique subscript
.. S RET(REJCODE,$P(H0,U,1),PSORJCNT)=H0 ; save the data in sort order
.. Q
. Q
REJCOMX ;
Q
;
MP(RX,FIL) ; Entry point for PSO API to display Medication Profile List Manager screen given an Rx and Fill
;
N PSOSITE,DFN,PSODFN,PATIENT,SITE,PSOPAR,PSOPAR7,PSOSYS,PSOPINST
N CTRLCOL,COL,D,GMRAL,HDR,HIGHLN,LASTLINE,LENGTH,PSOEXDCE,PSOEXPDC,PSOHD,PSOPI,PSORDCNT,PSORDER,PSORDSEQ,PSOSIGDP,PSOSRTBY
N PSOSTSEQ,PSOSTSGP,PSOTEL,PSOTMP,RSLT,SORT,VA,VACNTRY,VADM,VAPA,VAEL,VAERR
N DAT,DDER,DIW,DIWF,DIWI,DIWT,DIWTC,DIWX,DN,LIST,OUT,POP,POS,PSNDIY,PSOCHNG,PSOQUIT,PSOBM,PSOQFLG
I '$G(RX) G MPX
I $G(FIL)="" G MPX
;
K ^TMP("PSOPI",$J)
S (SITE,PSOSITE)=+$$RXSITE^PSOBPSUT(RX,FIL) ; division ien (ptr to file 59)
S PSOPAR=$G(^PS(59,PSOSITE,1)),PSOPAR7=$G(^PS(59,PSOSITE,"IB")),PSOSYS=$G(^PS(59.7,1,40.1)),PSOPINST=$P($G(^PS(59,PSOSITE,"INI")),U,1)
S (DFN,PSODFN,PATIENT)=+$$GET1^DIQ(52,RX,2,"I") ; patient ien
D LOAD^PSOPMPPF(SITE,DUZ) ; load division/user preferences
D EN^VALM("PSO BPS PMP MAIN") ; call list
K ^TMP("PSOPI",$J),^TMP("PSOPMP0",$J),^TMP("PSOPMPSR",$J) ; clean-up
MPX ;
Q
;
PI(RX,FIL) ; Entry point for PSO API to display Patient Information List Manager screen given an Rx and Fill
N PSOSITE,DFN,PSODFN,PATIENT,SITE,PSOPAR,PSOPAR7,PSOSYS,PSOPINST
N CTRLCOL,COL,D,GMRAL,HDR,HIGHLN,LASTLINE,LENGTH,PSOEXDCE,PSOEXPDC,PSOHD,PSOPI,PSORDCNT,PSORDER,PSORDSEQ,PSOSIGDP,PSOSRTBY
N PSOSTSEQ,PSOSTSGP,PSOTEL,PSOTMP,RSLT,SORT,VA,VACNTRY,VADM,VAPA,VAEL,VAERR
N DAT,DDER,DIW,DIWF,DIWI,DIWT,DIWTC,DIWX,DN,LIST,OUT,POP,POS,PSNDIY,PSOCHNG,PSOQUIT,PSOBM,PSOQFLG
I '$G(RX) G PIX
I $G(FIL)="" G PIX
;
K ^TMP("PSOPI",$J)
S (SITE,PSOSITE)=+$$RXSITE^PSOBPSUT(RX,FIL) ; division ien (ptr to file 59)
S PSOPAR=$G(^PS(59,PSOSITE,1)),PSOPAR7=$G(^PS(59,PSOSITE,"IB")),PSOSYS=$G(^PS(59.7,1,40.1)),PSOPINST=$P($G(^PS(59,PSOSITE,"INI")),U,1)
S (DFN,PSODFN,PATIENT)=+$$GET1^DIQ(52,RX,2,"I") ; patient ien
D ^PSOORUT2 ; build Listman content and header
D EN^VALM("PSO BPS PATIENT INFORMATION") ; call list
K ^TMP("PSOPI",$J) ; clean-up
PIX ;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOREJU4 12653 printed Sep 23, 2025@20:10:07 Page 2
PSOREJU4 ;BIRM/LE - Pharmacy Reject Overrides ;06/26/08
+1 ;;7.0;OUTPATIENT PHARMACY;**289,290,358,359,385,421,448,561,562,648,702,746,747**;DEC 1997;Build 7
+2 ; Reference to DUR1^BPSNCPD3 in ICR #4560
+3 ; Reference to $$ELIG^BPSBUTL and $$AMT^BPSBUTL in ICR #4719
+4 ; Reference to 9002313.93 in ICR #4720
+5 ;
AUTOREJ(CODES,PSODIV) ;API to evaluate an array of reject codes to see if they are allowed to be passed to OP reject Worklist
+1 ;Input: CODES - required; array of codes to be validated for overrides.
+2 ; PSODIV - optional; Division for the Rx and Fill to be evaluated
+3 ;
+4 ;Output: CODES(0)=0 always - ALLOW ALL REJECTS flag was inactivated with patch 421
+5 ;
+6 ; CODES(SEQ,REJECT)= 0 (zero) if the fill is not allowed to be passed to the Pharmacy
+7 ; Reject Worklist or 1 (one) for the reject code is allowed.
+8 ;
+9 NEW SEQ,COD,AUTO,ALLOW,SPDIV
+10 ;if no division passed, first division in file 59 is assumed.
+11 IF '$GET(PSODIV)
SET PSODIV=0
SET PSODIV=$ORDER(^PS(59,PSODIV))
+12 IF '$GET(PSODIV)
SET CODES(0)="0^Division undefined in file 59"
QUIT
+13 SET SPDIV=""
SET SPDIV=$ORDER(^PS(52.86,"B",PSODIV,SPDIV))
+14 IF SPDIV=""
SET CODES(0)="0^Division is not defined under ePharmacy Site Parameters option."
QUIT
+15 ;
+16 ; - all rejects allowed flag obsolete, set to 0 for parameter integrity
+17 SET CODES(0)=0
+18 ;
+19 ; - check individual reject codes. If defined, can be passed to Pharmacy Reject Worklist
+20 SET (COD,SEQ)=""
FOR
SET SEQ=$ORDER(CODES(SEQ))
if SEQ=""
QUIT
FOR
SET COD=$ORDER(CODES(SEQ,COD))
if COD=""
QUIT
Begin DoDot:1
+21 IF $DATA(^PS(52.86,+SPDIV,1,"B",COD))
SET CODES(SEQ,COD)=1
+22 IF '$TEST
SET CODES(SEQ,COD)=0
End DoDot:1
+23 QUIT
+24 ;
WRKLST(RX,RFL,COMMTXT,USERID,DTTIME,OPECC,RXCOB,RESP) ;External API to store reject codes other than 79/88/943/TRICARE/CHAMPVA on the OP Reject Worklist
+1 ;
+2 NEW CLOSECHK,CODE,DATA,I,IDX,PSODIV,PSOTRIC,REJ,REJCD,REJIDX,REJLST,REJS,SPDVI,TXT
+3 SET PSODIV=$$RXSITE^PSOBPSUT(RX,RFL)
+4 LOCK +^PSRX("REJ",RX):15
if '$TEST
QUIT "0^Rx locked by another user."
+5 IF $GET(RFL)=""
SET RFL=$$LSTRFL^PSOBPSU1(RX)
+6 DO DUR1^BPSNCPD3(RX,RFL,.REJ,"",RXCOB)
+7 ;
+8 SET REJCD=""
SET CLOSECHK=0
+9 IF $LENGTH($GET(RESP))
Begin DoDot:1
+10 ;ignore if not TRICARE or CHAMPVA
IF $PIECE(RESP,"^",3)'="T"
IF $PIECE(RESP,"^",3)'="C"
QUIT
+11 ;Piece 1 will be 0 if claim was submitted thru ECME
IF 'RESP
QUIT
+12 ; either eT for TRICARE or eC for CHAMPVA
SET REJCD="e"_$PIECE(RESP,"^",3)
+13 SET REJ(1,"REJ CODE LST")=REJCD
+14 SET REJ(1,"PAYER MESSAGE",1)="Not ECME Billable: "_$PIECE(RESP,U,2)
+15 SET REJ(1,"ELIGBLT")=$PIECE(RESP,"^",3)
+16 SET CLOSECHK=1
End DoDot:1
+17 ;
+18 SET PSOTRIC=""
SET PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,PSOTRIC)
+19 KILL REJS
SET (AUTO,IDX)=""
+20 FOR
SET IDX=$ORDER(REJ(IDX))
if IDX=""
QUIT
Begin DoDot:1
+21 SET TXT=$GET(REJ(IDX,"REJ CODE LST"))
+22 FOR I=1:1:$LENGTH(TXT,",")
Begin DoDot:2
+23 SET CODE=$PIECE(TXT,",",I)
+24 IF CODE=""
QUIT
+25 IF CODE'="79"&(CODE'="88")&(CODE'="943")&('$GET(PSOTRIC))
SET AUTO=$$EVAL(PSODIV,CODE,OPECC)
if '+AUTO
QUIT
+26 ; Send all billable and non-billable rejects to worklist if TRICARE or CHAMPVA
IF PSOTRIC
SET AUTO=1
+27 IF $$DUP^PSOREJU1(RX,+$$CLEAN^PSOREJU1($GET(REJ(IDX,"RESPONSE IEN"))),CLOSECHK)
SET AUTO="0^Rx is already on Pharmacy Reject Worklist."
+28 SET REJS(IDX,CODE)=""
End DoDot:2
End DoDot:1
if AUTO'=""
QUIT
+29 IF '$DATA(REJS)
LOCK -^PSRX("REJ",RX)
SET AUTO="0^No action taken"
QUIT AUTO
+30 if '+AUTO
GOTO EXIT
+31 ;
+32 DO SYNC2^PSOREJUT
+33 SET AUTO=1
EXIT ;
+1 LOCK -^PSRX("REJ",RX)
+2 QUIT AUTO
+3 ;
EVAL(PSODIV,CODE,OPECC,RX,RFNBR,COB,RRRDATA) ;Evaluates whether the reject codes other than 79/88/TRICARE/CHAMPVA is allowed to be passed to OP Reject Worklist
+1 ;Input: PSODIV - required; Division for the Rx and Fill to be evaluated
+2 ; CODE - required; external reject code
+3 ; OPECC - optional, 1 means manually passed by OPECC 0 or null means not passed
+4 ; RX - optional; IEN from prescription file
+5 ; RFNBR - optional; refill number
+6 ; COB - optional; coordination of benefits
+7 ;Output: $$EVAL - Return value - 1 means reject is allowed to be passed to Pharmacy Reject Worklist and
+8 ; 0 means not allowed.
+9 ; When doing a RRR check, RX, RFNBR & COB are required.
+10 ; RRRDATA - passed by reference.
+11 ; RRRDATA [1] 1/0 is this an RRR reject?
+12 ; [2] gross amount due for the Rx/fill/cob
+13 ; [3] $ dollar threshold amount from PSO site parameters
+14 ;
+15 NEW ALLOWA,CIEN,ALLOW,ICOD,SPDIV
+16 IF '$DATA(CODE)!(CODE="")
QUIT 0
+17 IF '$GET(OPECC)
SET OPECC=0
+18 IF '$GET(PSODIV)
QUIT 0
+19 SET SPDIV=""
SET SPDIV=$ORDER(^PS(52.86,"B",PSODIV,SPDIV))
+20 if SPDIV=""
QUIT "0^Division is not defined under ePharmacy Site Parameters option."
+21 if '$GET(AUTO)
SET AUTO=""
+22 SET ICOD=""
SET ICOD=$ORDER(^BPSF(9002313.93,"B",CODE,ICOD))
+23 if ICOD=""
QUIT 0
+24 ;
+25 ; Check for Resolution Required Reject code if so, return a 1
+26 IF $GET(RX)
IF $DATA(RFNBR)
IF $DATA(COB)
SET RRRDATA=$$RRRCHK(SPDIV,ICOD,RX,RFNBR,COB)
IF +RRRDATA
QUIT 1
+27 ;
+28 ; Transfer reject processing
+29 if '$DATA(^PS(52.86,SPDIV,1,"B",ICOD))
QUIT "0^Reject Code is not allowed to be passed to Pharmacy Reject Worklist."
+30 SET CIEN=""
SET CIEN=$ORDER(^PS(52.86,SPDIV,1,"B",ICOD,CIEN))
+31 IF CIEN=""
SET AUTO="0^Code not defined."
+32 SET (AUTO,ALLOW)=""
SET ALLOW=$$GET1^DIQ(52.8651,CIEN_","_SPDIV,1,"I")
+33 IF ALLOW
QUIT 1
+34 IF 'ALLOW
Begin DoDot:1
+35 IF OPECC
SET AUTO=1
+36 IF 'OPECC
SET AUTO="0^Reject code "_CODE_" cannot be placed on the Pharmacy Reject Worklist"
End DoDot:1
+37 QUIT AUTO
+38 ;
INLIST(RX,RFL,RXCOB) ;Returns whether a prescription/fill contains UNRESOLVED rejects
+1 ;Input:
+2 ;RX - Prescription IEN.
+3 ;FILL - Fill number being processed.
+4 ;Output:
+5 ;0 - the fill is not on the Pharmacy Reject Worklist
+6 ;1 - the fill is already on the Pharmacy Reject Worklist
+7 NEW PSOX,PSOX1,PSOX2,REJDATA1
+8 SET PSOX=$$FIND^PSOREJUT(RX,RFL,.REJDATA1,"")
IF PSOX=0
QUIT 0
+9 SET RXCOB=$SELECT(RXCOB=1:"PRIMARY",RXCOB=2:"SECONDARY")
+10 SET PSOX1=""
FOR
SET PSOX1=$ORDER(REJDATA1(PSOX1))
if PSOX1=""
QUIT
IF REJDATA1(PSOX1,"COB")=RXCOB
SET PSOX2=1
QUIT
+11 IF '$GET(PSOX2)
QUIT 0
+12 QUIT 1
+13 ;
MULTI(RX,RFL,REJDATA,CODE,REJS,RRRFLG) ;due to routine size, called from FIND^PSOREJUT
+1 ;returns REJS = 1 means reject code found on Rx, 0 (zero) means not found
+2 NEW RCODE,I
+3 IF $GET(RFL)'=""
Begin DoDot:1
+4 FOR I=1:1
SET RCODE=$PIECE(CODE,",",I)
if RCODE=""!($GET(REJS))
QUIT
DO GET^PSOREJU2(RX,RFL,.REJDATA,,,$GET(RCODE),+$GET(RRRFLG))
IF $DATA(REJDATA)
SET REJS=1
End DoDot:1
+5 IF '$TEST
SET RFL=0
Begin DoDot:1
+6 FOR I=1:1
SET RCODE=$PIECE(CODE,",",I)
if RCODE=""!($GET(REJS))
QUIT
DO GET^PSOREJU2(RX,RFL,.REJDATA,,,$GET(RCODE),+$GET(RRRFLG))
IF $DATA(REJDATA)
SET REJS=1
End DoDot:1
IF '$DATA(REJDATA)
FOR
SET RFL=$ORDER(^PSRX(RX,1,RFL))
if 'RFL
QUIT
Begin DoDot:1
End DoDot:1
if $GET(REJS)
QUIT
+7 QUIT REJS
+8 ;
SINGLE(RX,RFL,REJDATA,CODE,REJS,RRRFLG) ;due to routine size, called from FIND^PSOREJUT
+1 ;Returns REJS = 1 means reject code found on Rx, 0 (zero) means not found
+2 IF $GET(RFL)'=""
Begin DoDot:1
+3 DO GET^PSOREJU2(RX,RFL,.REJDATA,,,$GET(CODE),+$GET(RRRFLG))
End DoDot:1
+4 IF '$TEST
SET RFL=0
Begin DoDot:1
+5 DO GET^PSOREJU2(RX,RFL,.REJDATA,,,$GET(CODE),+$GET(RRRFLG))
End DoDot:1
IF '$DATA(REJDATA)
FOR
SET RFL=$ORDER(^PSRX(RX,1,RFL))
if 'RFL
QUIT
Begin DoDot:1
End DoDot:1
+6 SET REJS=$SELECT($DATA(REJDATA):1,1:0)
+7 QUIT REJS
+8 ;
RRRCHK(SPDIV,REJ,RX,RFNBR,COB) ; Test a reject for valid Resolution Required Reject code
+1 ; INPUT
+2 ; SPDIV = required - IEN in site parameter file for the selected division
+3 ; REJ = required - IEN of the Reject code to test
+4 ; RX = required - IEN from prescription file
+5 ; RFNBR = required - prescription refill number
+6 ; COB = optional - coordination of benefits
+7 ;
+8 ; OUTPUT
+9 ; Function Value - Returns an "^" delimited string
+10 ; [1] 1/0 is this an RRR reject?
+11 ; 1 = Valid resolution required reject code.
+12 ; 0 = Invalid resolution required reject code.
+13 ; [2] If valid RRR then gross amount due for the Rx/fill/cob else null
+14 ; [3] If valid RRR then dollar threshold amount from PSO site parameters else null
+15 ;
+16 ; For a reject code to be valid each of the following needs to be true:
+17 ; 1 - Eligibility must be a veteran type
+18 ; 2 - Must be the first fill on a prescription
+19 ; 3 - Reject code must be defined in the pharmacy division's site parameters
+20 ; as a resolution required reject code.
+21 ; 4 - Gross amount must be >= DOLLAR THRESHOLD in the pharmacy division's site
+22 ; parameters for the given resolution required reject code.
+23 ;
+24 ; Verify parameters
+25 IF '$GET(SPDIV)
QUIT 0
+26 IF '$DATA(^PS(52.86,SPDIV))
QUIT 0
+27 IF '$GET(REJ)
QUIT 0
+28 ; DBIA 4720
IF '$DATA(^BPSF(9002313.93,REJ,0))
QUIT 0
+29 IF '$GET(RX)
QUIT 0
+30 IF '$DATA(^PSRX(RX))
QUIT 0
+31 IF '$DATA(RFNBR)
QUIT 0
+32 ;
+33 NEW RRRC,AMT,THRSHLD
+34 ; SPDIV = IEN in site parameter file for the selected division
+35 ; RRRC = indicates the RESOLUTION REQUIRED REJECT CODE exists for the selected division
+36 ; it will be a null or an IEN in the 52.865 sub-file
+37 ; AMT = RX gross amount due
+38 ; THRSHLD = DOLLAR THRESHOLD for RRR code
+39 ;
+40 ; Test for released status
+41 IF $$GET1^DIQ(52,RX_",",31,"I")
QUIT 0
+42 ;
+43 ; Test Eligibility - IA 4719
+44 IF $$ELIG^BPSBUTL(RX,0,$GET(COB))'="V"
QUIT 0
+45 ;
+46 ; is this a Resolution Required Reject code?
+47 SET RRRC=0
SET RRRC=$ORDER(^PS(52.86,SPDIV,5,"B",REJ,RRRC))
+48 IF RRRC=""
QUIT 0
+49 ;
+50 ; Test gross amount against DOLLAR THRESHOLD
+51 SET AMT=$$AMT^BPSBUTL(RX,0,$GET(COB))
+52 SET THRSHLD=$$GET1^DIQ(52.865,RRRC_","_SPDIV_",",.02)
+53 IF AMT<THRSHLD
QUIT 0
+54 QUIT 1_U_AMT_U_THRSHLD
+55 ;
REJCOM(RX,FIL,COB,RET) ; Gather PSO reject comments and return
+1 ; Input
+2 ; RX - prescription IEN required
+3 ; FIL - fill# required - will match with the 52.25,5 field
+4 ; COB - coordination of benefits# (optional). If present, will match with the 52.25,27 field
+5 ; Output
+6 ; RET - return array, pass by reference
+7 ; RET(external reject code,date/time of comment,incremental counter) =
+8 ; [1] date/time of comment
+9 ; [2] user pointer 200
+10 ; [3] comment text 1-150 characters
+11 ;
+12 NEW REJ,G0,G2,REJCODE,CMT,H0,PSORJCNT
+13 KILL RET
+14 IF '$GET(RX)
GOTO REJCOMX
+15 IF $GET(FIL)=""
GOTO REJCOMX
+16 SET COB=$GET(COB)
+17 SET PSORJCNT=0
+18 ;
+19 SET REJ=0
FOR
SET REJ=$ORDER(^PSRX(RX,"REJ",REJ))
if 'REJ
QUIT
Begin DoDot:1
+20 SET G0=$GET(^PSRX(RX,"REJ",REJ,0))
SET G2=$GET(^PSRX(RX,"REJ",REJ,2))
+21 ; fill# must match
IF FIL'=$PIECE(G0,U,4)
QUIT
+22 ; cob# must match if COB is passed in
IF COB
IF COB'=$PIECE(G2,U,7)
QUIT
+23 ; save external reject code
SET REJCODE=$PIECE(G0,U,1)
+24 IF REJCODE=""
QUIT
+25 ;
+26 SET CMT=0
FOR
SET CMT=$ORDER(^PSRX(RX,"REJ",REJ,"COM",CMT))
if 'CMT
QUIT
Begin DoDot:2
+27 ; make sure the date/time is there
SET H0=$GET(^PSRX(RX,"REJ",REJ,"COM",CMT,0))
IF 'H0
QUIT
+28 ; increment the counter for unique subscript
SET PSORJCNT=PSORJCNT+1
+29 ; save the data in sort order
SET RET(REJCODE,$PIECE(H0,U,1),PSORJCNT)=H0
+30 QUIT
End DoDot:2
+31 QUIT
End DoDot:1
REJCOMX ;
+1 QUIT
+2 ;
MP(RX,FIL) ; Entry point for PSO API to display Medication Profile List Manager screen given an Rx and Fill
+1 ;
+2 NEW PSOSITE,DFN,PSODFN,PATIENT,SITE,PSOPAR,PSOPAR7,PSOSYS,PSOPINST
+3 NEW CTRLCOL,COL,D,GMRAL,HDR,HIGHLN,LASTLINE,LENGTH,PSOEXDCE,PSOEXPDC,PSOHD,PSOPI,PSORDCNT,PSORDER,PSORDSEQ,PSOSIGDP,PSOSRTBY
+4 NEW PSOSTSEQ,PSOSTSGP,PSOTEL,PSOTMP,RSLT,SORT,VA,VACNTRY,VADM,VAPA,VAEL,VAERR
+5 NEW DAT,DDER,DIW,DIWF,DIWI,DIWT,DIWTC,DIWX,DN,LIST,OUT,POP,POS,PSNDIY,PSOCHNG,PSOQUIT,PSOBM,PSOQFLG
+6 IF '$GET(RX)
GOTO MPX
+7 IF $GET(FIL)=""
GOTO MPX
+8 ;
+9 KILL ^TMP("PSOPI",$JOB)
+10 ; division ien (ptr to file 59)
SET (SITE,PSOSITE)=+$$RXSITE^PSOBPSUT(RX,FIL)
+11 SET PSOPAR=$GET(^PS(59,PSOSITE,1))
SET PSOPAR7=$GET(^PS(59,PSOSITE,"IB"))
SET PSOSYS=$GET(^PS(59.7,1,40.1))
SET PSOPINST=$PIECE($GET(^PS(59,PSOSITE,"INI")),U,1)
+12 ; patient ien
SET (DFN,PSODFN,PATIENT)=+$$GET1^DIQ(52,RX,2,"I")
+13 ; load division/user preferences
DO LOAD^PSOPMPPF(SITE,DUZ)
+14 ; call list
DO EN^VALM("PSO BPS PMP MAIN")
+15 ; clean-up
KILL ^TMP("PSOPI",$JOB),^TMP("PSOPMP0",$JOB),^TMP("PSOPMPSR",$JOB)
MPX ;
+1 QUIT
+2 ;
PI(RX,FIL) ; Entry point for PSO API to display Patient Information List Manager screen given an Rx and Fill
+1 NEW PSOSITE,DFN,PSODFN,PATIENT,SITE,PSOPAR,PSOPAR7,PSOSYS,PSOPINST
+2 NEW CTRLCOL,COL,D,GMRAL,HDR,HIGHLN,LASTLINE,LENGTH,PSOEXDCE,PSOEXPDC,PSOHD,PSOPI,PSORDCNT,PSORDER,PSORDSEQ,PSOSIGDP,PSOSRTBY
+3 NEW PSOSTSEQ,PSOSTSGP,PSOTEL,PSOTMP,RSLT,SORT,VA,VACNTRY,VADM,VAPA,VAEL,VAERR
+4 NEW DAT,DDER,DIW,DIWF,DIWI,DIWT,DIWTC,DIWX,DN,LIST,OUT,POP,POS,PSNDIY,PSOCHNG,PSOQUIT,PSOBM,PSOQFLG
+5 IF '$GET(RX)
GOTO PIX
+6 IF $GET(FIL)=""
GOTO PIX
+7 ;
+8 KILL ^TMP("PSOPI",$JOB)
+9 ; division ien (ptr to file 59)
SET (SITE,PSOSITE)=+$$RXSITE^PSOBPSUT(RX,FIL)
+10 SET PSOPAR=$GET(^PS(59,PSOSITE,1))
SET PSOPAR7=$GET(^PS(59,PSOSITE,"IB"))
SET PSOSYS=$GET(^PS(59.7,1,40.1))
SET PSOPINST=$PIECE($GET(^PS(59,PSOSITE,"INI")),U,1)
+11 ; patient ien
SET (DFN,PSODFN,PATIENT)=+$$GET1^DIQ(52,RX,2,"I")
+12 ; build Listman content and header
DO ^PSOORUT2
+13 ; call list
DO EN^VALM("PSO BPS PATIENT INFORMATION")
+14 ; clean-up
KILL ^TMP("PSOPI",$JOB)
PIX ;
+1 QUIT
+2 ;
