Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOREJU4

PSOREJU4.m

Go to the documentation of this file. 
  1. PSOREJU4 ;BIRM/LE - Pharmacy Reject Overrides ;06/26/08
  1.  ;;7.0;OUTPATIENT PHARMACY;**289**;DEC 1997;Build 107
  1.  ;Reference to DUR1^BPSNCPD3 supported by IA 4560
  1.  ;
  1. 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.  
  1.  ;           PSODIV - optional; Division for the Rx and Fill to be evaluated
  1.  ;        
  1.  ;Output:     CODES(0)=   1 for all reject codes are allowed to be passed to Pharmacy
  1.  ;                         Reject Worklist or 0 (zero) means only default of 79/88/Tricare and
  1.  ;                         any individually override rejects can be passed to the worklist. 
  1.  ;                        
  1.  ;            CODES(SEQ,REJECT)= 0 (zero) if the fill is not allowed to be passed to the Pharmacy
  1.  ;                                Reject Worklist or 1 (one) for the reject code is allowed.
  1.  ;                                
  1.  N SEQ,COD,AUTO,ALLOW,SPDIV
  1.  ;if no division passed, first division in file 59 is assumed.
  1.  I '$G(PSODIV) S PSODIV=0,PSODIV=$O(^PS(59,PSODIV))
  1.  I '$G(PSODIV) S CODES(0)="0^Division undefined in file 59" Q 
  1.  S SPDIV="",SPDIV=$O(^PS(52.86,"B",PSODIV,SPDIV))
  1.  I SPDIV="" S CODES(0)="0^Division is not defined under ePharmacy Site Parameters option." Q
  1.  ;
  1.  ; - all rejects allowed to pass to Pharmacy Reject Worklist?
  1.  S CODES(0)=$$GET1^DIQ(52.86,SPDIV,1,"I")
  1.  ;
  1.  ; - check individual reject codes.  If defined, can be passed to Pharmacy Reject Worklist
  1.  S (COD,SEQ)="" F  S SEQ=$O(CODES(SEQ)) Q:SEQ=""  F  S COD=$O(CODES(SEQ,COD)) Q:COD=""  D
  1.  . I $D(^PS(52.86,+SPDIV,1,"B",COD)) S CODES(SEQ,COD)=1
  1.  . E  S CODES(SEQ,COD)=0
  1.  Q
  1.  ;
  1. WRKLST(RX,RFL,COMMTXT,USERID,DTTIME,OPECC) ;External API to store reject codes other that 79/88/Tricare on the OP Reject Worklist
  1.  ; 
  1.  N REJ,REJS,REJLST,I,IDX,CODE,DATA,TXT,PSOTRIC,SPDVI,PSODIV
  1.  S PSODIV=$$RXSITE^PSOBPSUT(RX,RFL)
  1.  L +^PSRX("REJ",RX):15 Q:'$T "0^Rx locked by another user."
  1.  I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
  1.  D DUR1^BPSNCPD3(RX,RFL,.REJ)
  1.  S PSOTRIC="" S:$G(REJ(1,"ELIGBLT"))="T" PSOTRIC=1
  1.  S:PSOTRIC="" PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,PSOTRIC)
  1.  K REJS S (AUTO,IDX)=""
  1.  F  S IDX=$O(REJ(IDX)) Q:IDX=""  D  Q:AUTO'=""
  1.  . S TXT=REJ(IDX,"REJ CODE LST")
  1.  . F I=1:1:$L(TXT,",") D
  1.  . . S CODE=$P(TXT,",",I)
  1.  . . I CODE'="79"&(CODE'="88")&('$G(PSOTRIC)) S AUTO=$$EVAL(PSODIV,CODE,OPECC,.AUTO) Q:'+AUTO
  1.  . . I $$DUP^PSOREJU1(RX,+$$CLEAN^PSOREJU1($G(REJ(IDX,"RESPONSE IEN")))) S AUTO="0^Rx is already on Pharmacy Reject Worklist."
  1.  . . S REJS(IDX,CODE)=""
  1.  I '$D(REJS) L -^PSRX("REJ",RX) S AUTO="0^No action taken" Q AUTO
  1.  ;D SAVECOM^PSOREJP3(RX,PSREJIEN,COMMTXT,DTTIME,USER)
  1.  G EXIT:'+AUTO
  1.  ;
  1.  D SYNC2^PSOREJUT
  1.  S AUTO=1
  1. EXIT ;
  1.  L -^PSRX("REJ",RX)
  1.  Q AUTO
  1.  ;
  1. EVAL(PSODIV,CODE,OPECC,AUTO) ;Evaluates whether the reject codes other than 79/88/Tricare is allowed to be passed to OP Reject Worklist
  1.  ;Input:      PSODIV - required; Division for the Rx and Fill to be evaluated
  1.  ;              CODE - required; reject code
  1.  ;             OPECC - optional, 1 means manually passed by OPECC means not passed
  1.  ;              AUTO - passed in value to be returned.
  1.  ;Output:       AUTO - 1 means reject is allowed to be passed to Pharmacy Reject Worklist and zero
  1.  ;                       means not allowed.
  1.  ;                       
  1.  N ALLOWA,CIEN,ALLOW,ICOD,SPDIV
  1.  I '$D(CODE)!(CODE="") Q 0
  1.  I '$G(OPECC) S OPECC=0
  1.  I '$G(PSODIV) Q 0
  1.  S SPDIV="",SPDIV=$O(^PS(52.86,"B",PSODIV,SPDIV))
  1.  Q:SPDIV="" "0^Division is not defined under ePharmacy Site Parameters option."
  1.  S:'$G(AUTO) AUTO=""
  1.  S ICOD="",ICOD=$O(^BPSF(9002313.93,"B",CODE,ICOD))
  1.  Q:ICOD="" 0
  1.  S ALLOWA=$$GET1^DIQ(52.86,SPDIV,1,"I") I ALLOWA Q 1
  1.  Q:'$D(^PS(52.86,SPDIV,1,"B",ICOD)) "0^Reject Code is not allowed to be passed to Pharmacy Reject Worklist."
  1.  S CIEN="",CIEN=$O(^PS(52.86,SPDIV,1,"B",ICOD,CIEN))
  1.  I CIEN="" S AUTO="0^Code not defined."
  1.  S (AUTO,ALLOW)="",ALLOW=$$GET1^DIQ(52.8651,CIEN_","_SPDIV,1,"I")
  1.  I ALLOW Q 1
  1.  I 'ALLOW D
  1.  . I OPECC S AUTO=1
  1.  . I 'OPECC S AUTO="0^Reject code "_CODE_" cannot be placed on the Pharmacy Reject Worklist"
  1.  Q AUTO
  1.  ;
  1. OVER ;due to size of PSOREJU1 this subroutine was needed. also used by OVERMSG
  1.  ;The variables RX, RFL, CODE and CODES are expected to remain when exiting this subroutine
  1.  ;
  1.  N DCODE,AUTO,PSODIV,OCODES S (PSODIV,AUTO,DCODE,OCODES,OVRARR)=""
  1.  S OCODES=CODES,CODES=""
  1.  S PSODIV=$$RXSITE^PSOBPSUT(RX,RFL)
  1.  F  S DCODE=$O(^PSRX(RX,"REJ","B",DCODE)) Q:DCODE=""  D
  1.  . I DCODE[79!(DCODE[88) S CODES=CODES_","_DCODE Q
  1.  . S AUTO=$$EVAL(PSODIV,DCODE,0,.AUTO)
  1.  . Q:'+AUTO
  1.  . S CODES=CODES_","_DCODE,OVRARR(DCODE)=""
  1.  S CODES=$E(CODES,2,9999)
  1.  S:CODES="" CODES=OCODES
  1.  Q
  1.  ;
  1. OVRMSG(RX,RFL,OVRMSG,REJDAT) ;
  1.  N CODES,OVRARR,COD
  1.  S CODES=""
  1.  D OVER
  1.  I '$D(REJDAT) D NOW^%DTC S REJDAT=%
  1.  Q:'$D(OVRARR)
  1.  F  S COD=$O(OVRARR(COD)) Q:COD=""  D
  1.  . D SAVECOM^PSOREJP3(RX,COD,OVRMSG,REJDAT,$S($G(DUZ):DUZ,1:.5))
  1.  Q
  1.  ;
  1. INLIST(RX,RFL) ;Returns whether a prescription/fill contains UNRESOLVED rejects
  1.  ;Input:
  1.  ;RX - Prescription IEN. 
  1.  ;FILL - Fill number being processed. 
  1.  ;Output:
  1.  ;0 - the fill is not on the Pharmacy Reject Worklist
  1.  ;1 - the fill is already on the Pharmacy Reject Worklist
  1.  Q $$FIND^PSOREJUT(RX,RFL)
  1.  ;
  1. MULTI(RX,RFL,REJDATA,CODE,REJS) ;due to routine size, called from FIND^PSOREJUT
  1.  ;returns REJS = 1 means reject code found on Rx, 0 (zero) means not found
  1.  I $G(RFL) D
  1.  . F I=1:1 S RCODE=$P(CODE,",",I) Q:RCODE=""!($G(REJS))  D GET^PSOREJU2(RX,RFL,.REJDATA,,,$G(RCODE)) I $D(REJDATA) S REJS=1
  1.  E  S RFL=0 D  I '$D(REJDATA) F  S RFL=$O(^PSRX(RX,1,RFL)) Q:'RFL  D  Q:$G(REJS)
  1.  . F I=1:1 S RCODE=$P(CODE,",",I) Q:RCODE=""!($G(REJS))  D GET^PSOREJU2(RX,RFL,.REJDATA,,,$G(RCODE)) I $D(REJDATA) S REJS=1
  1.  Q REJS
  1.  ;
  1. SINGLE(RX,RFL,REJDATA,CODE,REJS) ;due to routine size, called from FIND^PSOREJUT
  1.  ;Returns REJS = 1 means reject code found on Rx, 0 (zero) means not found
  1.  I $G(RFL) D
  1.  . D GET^PSOREJU2(RX,RFL,.REJDATA,,,$G(CODE))
  1.  E  S RFL=0 D  I '$D(REJDATA) F  S RFL=$O(^PSRX(RX,1,RFL)) Q:'RFL  D
  1.  . D GET^PSOREJU2(RX,RFL,.REJDATA,,,$G(CODE))
  1.  S REJS=$S($D(REJDATA):1,1:0)
  1.  Q REJS