- 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 Feb 19, 2025@00:00:06 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 ;