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

PSOBPSU2.m

Go to the documentation of this file.
  1. PSOBPSU2 ;BIRM/MFR - BPS (ECME) Utilities 2 ;10/15/04
  1. ;;7.0;OUTPATIENT PHARMACY;**260,287,289,341,290,358,359,385,421,459,482,512,544,562,660,681,703,704**;DEC 1997;Build 16
  1. ; Reference to ^VA(200 in ICR #10060
  1. ; Reference to DUR1^BPSNCPD3 in ICR #4560
  1. ; Reference to $$NCPDPQTY^PSSBPSUT in ICR #4992
  1. ; Reference to $$CLAIM^BPSBUTL in ICR #4719
  1. ; Reference to $$TRICVANB^PSXRPPL1 in ICR #7351
  1. ;
  1. MWC(RX,RFL) ; Returns whether a prescription is (M)ail, (W)indow or (C)MOP
  1. ; Input: (r) RX - Rx IEN (#52)
  1. ; (o) RFL - Refill # (Default: most recent)
  1. ; Output: "M": MAIL / "W": WINDOW / "C": CMOP
  1. ;
  1. N MWC
  1. ;
  1. I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
  1. ;
  1. ; If RFL is not zero, then pull the value from MAIL/WINDOW on the
  1. ; REFILL multiple. Otherwise, pull the value from MAIL/WINDOW
  1. ; at the Prescription level.
  1. ;
  1. I RFL S MWC=$$GET1^DIQ(52.1,RFL_","_RX,2,"I")
  1. E S MWC=$$GET1^DIQ(52,RX,11,"I")
  1. ;
  1. ; If <blank>, default to Window.
  1. ; If neither Mail nor Window, quit now and skip other checks.
  1. ;
  1. I MWC="" S MWC="W"
  1. I MWC'="M",MWC'="W" Q MWC
  1. ;
  1. ; - Checking the RX SUSPENSE file (#52.5)
  1. ; File# 52, field# 100 is STATUS; 5=Suspended
  1. I $$GET1^DIQ(52,RX,100,"I")=5 D
  1. . N RXS
  1. . S RXS=+$O(^PS(52.5,"B",RX,0))
  1. . I 'RXS Q
  1. . ;
  1. . ; File#52.5, RX SUSPENSE; field# 3, CMOP INDICATOR
  1. . ; If the CMOP INDICATOR is not blank, then this is CMOP...
  1. . I $$GET1^DIQ(52.5,RXS,3,"I")'="" S MWC="C" Q
  1. . ; ...otherwise, this is a Mail fill.
  1. . S MWC="M"
  1. ;
  1. ; Checking the CMOP EVENT sub-file (#52.01)
  1. I MWC'="C" D
  1. . N CMP
  1. . S CMP=0
  1. . F S CMP=$O(^PSRX(RX,4,CMP)) Q:'CMP D I MWC="C" Q
  1. . . I $$GET1^DIQ(52.01,CMP_","_RX,2,"I")=RFL S MWC="C"
  1. ;
  1. Q MWC
  1. ;
  1. RXACT(RX,RFL,COMM,TYPE,USR) ; - Add an entry to the ECME Activity Log (PRESCRIPTION file)
  1. ;Input: (r) RX - Rx IEN (#52)
  1. ; (o) RFL - Refill # (Default: most recent)
  1. ; (r) COMM - Comments (up to 100 characters)
  1. ; (r) TYPE - Comments type: (M-ECME,E-Edit, etc...) See file #52 DD for all values
  1. ; (o) USR - User logging the comments (Default: DUZ)
  1. ;
  1. I '$D(^PSRX(RX)) Q
  1. ;
  1. S COMM=$E($G(COMM),1,100)
  1. I COMM="" Q
  1. ;
  1. I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
  1. I '$D(USR) S USR=DUZ
  1. I '$D(^VA(200,+USR,0)) S USR=DUZ
  1. I '$D(^VA(200,+USR,0)) S USR=.5
  1. ;
  1. N PSOTRIC
  1. S PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,"")
  1. I PSOTRIC=1,$E(COMM,1,7)'="TRICARE" S COMM=$E("TRICARE-"_COMM,1,100)
  1. I PSOTRIC=2,$E(COMM,1,7)'="CHAMPVA" S COMM=$E("CHAMPVA-"_COMM,1,100)
  1. ;
  1. N DA,DD,DIC,DINUM,DLAYGO,DO,DR,X,Y
  1. S DA(1)=RX
  1. S DIC="^PSRX("_RX_",""A"","
  1. S DLAYGO=52.3
  1. S DIC(0)="L"
  1. S DIC("DR")=".02///"_TYPE_";.03////"_USR_";.04///"_$S(TYPE'="M"&(RFL>5):RFL+1,1:RFL)_";.05///"_COMM
  1. S X=$$NOW^XLFDT()
  1. D FILE^DICN
  1. Q
  1. ;
  1. ECMENUM(RX,RFL) ; Returns the ECME number for a specific prescription and fill
  1. I $G(RX)="" Q ""
  1. N ECMENUM
  1. ;
  1. ; If RFL was passed in, return ECME # based on that.
  1. ;
  1. I $G(RFL)'="" S ECMENUM=$$GETECME(RX,RFL) Q ECMENUM
  1. ;
  1. ; If RFL was not passed in, determine the last refill, and return
  1. ; the ECME # based on that, if possible.
  1. ;
  1. S RFL=$$LSTRFL^PSOBPSU1(RX)
  1. S ECMENUM=$$GETECME(RX,RFL)
  1. I ECMENUM'="" Q ECMENUM
  1. ;
  1. ; If still no ECME #, then go backwards through the fills until
  1. ; we are able to determine an ECME #.
  1. ;
  1. F S RFL=RFL-1 Q:(RFL<0) S ECMENUM=$$GETECME(RX,RFL) I ECMENUM'="" Q
  1. Q ECMENUM
  1. ;
  1. GETECME(RX,RFL) ; Internal function used by ECMENUM to get the ECME # from BPS
  1. I $G(RX)="" Q ""
  1. I $G(RFL)="" Q ""
  1. Q $P($$CLAIM^BPSBUTL(RX,RFL),U,6)
  1. ;
  1. RXNUM(ECME) ; Returns the Rx number for a specific ECME number
  1. ;
  1. N FOUND,MAX,LFT,RAD,I,DIR,RX,X,Y,DIRUT
  1. S ECME=+ECME,LFT=0,FOUND=0
  1. S MAX=$O(^PSRX(9999999999999),-1) ; MAX = largest Rx ien on file
  1. ;
  1. ; Attempt left digit matching logic in specific case only,
  1. ; otherwise attempt a normal lookup.
  1. I $L(MAX)>7,$L(ECME)'>7 D
  1. . S LFT=$E(MAX,1,$L(MAX)-7) ; LFT = left most digits
  1. . F RAD=LFT:-1:0 S RX=RAD*10000000+ECME I $D(^PSRX(RX,0)),$$ECMENUM(RX)'="" S FOUND=FOUND+1,FOUND(FOUND)=RX
  1. . Q
  1. E S RX=ECME I $D(^PSRX(RX,0)),$$ECMENUM(RX)'="" S FOUND=FOUND+1,FOUND(FOUND)=RX
  1. ;
  1. I 'FOUND S FOUND=-1 G RXNUMX ; Rx not found
  1. I FOUND=1 S FOUND=FOUND(1) G RXNUMX ; exactly 1 found
  1. ;
  1. ; More than 1 found so build a list and ask
  1. W !
  1. F I=1:1:FOUND W !?5,I,". ",$$GET1^DIQ(52,FOUND(I),.01),?25,$$GET1^DIQ(52,FOUND(I),6)
  1. W !
  1. S DIR(0)="NA^1:"_FOUND
  1. S DIR("A")="Select one: "
  1. S DIR("B")=1
  1. D ^DIR
  1. I $D(DIRUT) S FOUND=-1 G RXNUMX
  1. S FOUND=FOUND(Y)
  1. ;
  1. RXNUMX ;
  1. Q FOUND
  1. ;
  1. ELIG(RX,RFL,PSOELIG) ;Stores eligibility flag
  1. I RFL>0,'$D(^PSRX(RX,1,RFL,0)) QUIT
  1. N DA,DIE,X,Y,PSOTRIC
  1. I 'RFL S DA=RX,DIE="^PSRX(",DR="85///"_PSOELIG D ^DIE
  1. I RFL S DA=RFL,DA(1)=RX,DIE="^PSRX("_DA(1)_",1,",DR="85///"_PSOELIG D ^DIE
  1. Q
  1. ;
  1. ECMESTAT(RX,RFL) ;called from local mail
  1. ; Input:
  1. ; RX = Prescription File IEN
  1. ; RFL = Refill
  1. ; Output:
  1. ; 0 for not allowed to print from suspense
  1. ; 1 for allowed to print from suspense
  1. ;
  1. N STATUS,PSOTRIC
  1. S STATUS=$$STATUS^PSOBPSUT(RX,RFL)
  1. ; IN PROGRESS claims - try again. If still IN PROGRESS, do not allow to print
  1. I STATUS["IN PROGRESS" H 5 S STATUS=$$STATUS^PSOBPSUT(RX,RFL) I STATUS["IN PROGRESS" Q 0
  1. ;
  1. ; no ECME status, allow to print. This will eliminate 90% of the cases
  1. I STATUS="" Q 1
  1. ;
  1. ; check for suspense hold date/host reject errors
  1. I $$DUR(RX,RFL)=0 Q 0
  1. ;
  1. ; check for any TRICARE/CHAMPVA rejects, not allowed to go to print until resolved.
  1. ; But allow to print if RX/RFL is in the TRI/CVA Audit Log with no unresolved rejects
  1. S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,.PSOTRIC)
  1. I PSOTRIC,STATUS'["PAYABLE",$$TRIAUD^PSOREJU3(RX,RFL) Q 1 ; on TRI/CVA Audit log - allow to print
  1. ;
  1. ; Disallow printing from suspense if the prescription has an unresolved
  1. ; 79/88/943 reject or an RRR reject.
  1. I $$FIND^PSOREJUT(RX,RFL,,"79,88,943",,1) Q 0
  1. ;
  1. Q 1
  1. ;
  1. ; This function checks to see if a RX should be submitted to ECME
  1. ; Submit when:
  1. ; RX/Fill was not submitted before (STATUS="")
  1. ; Previous submission had Host Reject Error Code(s)
  1. ; Input:
  1. ; RX = Prescription file #52 IEN
  1. ; RFL = Refill number
  1. ; Returns:
  1. ; 1 = OK to resubmit
  1. ; 0 = Don't resubmit
  1. ECMEST2(RX,RFL) ;
  1. ; Do not resubmit a claim if this Rx has a closed eT/eC reject.
  1. I $$TRICVANB^PSXRPPL1(RX,RFL) Q 0
  1. N STATUS
  1. S STATUS=$$STATUS^PSOBPSUT(RX,RFL)
  1. ;
  1. ; Never submitted before, OK to submit
  1. I STATUS="" Q 1
  1. ;
  1. ; If status other than E REJECTED, don't resubmit
  1. I STATUS'="E REJECTED" Q 0
  1. ;
  1. ; Check for host reject codes(s)
  1. Q $$HOSTREJ(RX,RFL,1)
  1. ;
  1. ; This subroutine checks an RX/FILL for Host Reject Errors (M6, M8,
  1. ; NN, 99) returned from previous ECME submissions.
  1. ; Note that host reject errors do not pass to the pharmacy reject
  1. ; worklist so it's necessary to check ECME for these type errors.
  1. ; Input:
  1. ; RX = Prescription File IEN
  1. ; RFL = Refill
  1. ; ONE = Either 1 or 0 - Defaults to 1
  1. ; If 1, At least ONE reject code associated with the RX/FILL
  1. ; must match either M6, M8, NN, or 99.
  1. ; If 0, ALL reject codes must match either M6, M8, NN, or 99
  1. ; Return:
  1. ; 0 = no host rejects exists based on ONE parameter
  1. ; 1 = host reject exists based on ONE parameter
  1. ; Note: The REJ array may be updated by the call to DUR1^BPSNCPD3.
  1. HOSTREJ(RX,RFL,ONE) ; called from PSXRPPL2 and this routine
  1. N IDX,TXT,CODE,HRCODE,HRQUIT,RETV,REJ,I
  1. S IDX="",(RETV,HRQUIT)=0
  1. I '$D(ONE) S ONE=1
  1. ;for print from suspense there will only be primary insurance or an index of 1 in REJ array
  1. D DUR1^BPSNCPD3(RX,RFL,.REJ) ; Get reject list from last submission if not present
  1. S TXT=$G(REJ(1,"REJ CODE LST"))
  1. I TXT="" Q 0
  1. I ONE=0,TXT'["," S ONE=1
  1. F I=1:1:$L(TXT,",") S CODE=$P(TXT,",",I) D Q:HRQUIT
  1. . F HRCODE=99,"M6","M8","NN" D Q:HRQUIT
  1. . . I CODE=HRCODE S RETV=1 I ONE S HRQUIT=1 Q
  1. . . I CODE'=HRCODE,RETV=1 S RETV=0,HRQUIT=1 Q
  1. Q RETV
  1. ;
  1. ; Input: RX = Prescription file #52 IEN
  1. ; RFL = Refill number
  1. ; Returns: A value of 0 (zero) will be returned when reject codes M6, M8,
  1. ; NN, and 99 are present OR if on susp hold which means the prescription should not
  1. ; be printed from suspense. Otherwise, a value of 1(one) will be returned.
  1. DUR(RX,RFL) ;
  1. N REJ,IDX,TXT,CODE,SHOLD,SHCODE,ESTAT,SHDT
  1. S SHOLD=1,IDX=""
  1. I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
  1. S SHDT=$$SHDT(RX,RFL) ; Get suspense hold date for rx/refill
  1. I SHDT'="",SHDT'<$$FMADD^XLFDT(DT,1) Q 0
  1. I $$HOSTREJ^PSOBPSU2(RX,RFL,1) I SHDT="" S SHOLD=0 D SHDTLOG(RX,RFL)
  1. Q SHOLD
  1. ;
  1. ; This subroutine sets the EPHARMACY SUSPENSE HOLD DATE field
  1. ; for the rx or refill to tomorrow and adds an entry to the SUSPENSE Activity Log.
  1. ; Input: RX = Prescription File IEN
  1. ; RFL = Refill
  1. SHDTLOG(RX,RFL) ;
  1. N DA,DIE,DR,COMM,SHDT
  1. I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
  1. S SHDT=$$FMADD^XLFDT(DT,1)
  1. S COMM="SUSPENSE HOLD until "_$$FMTE^XLFDT(SHDT,"2D")_" due to host reject error."
  1. I RFL=0 S DA=RX,DIE="^PSRX(",DR="86///"_SHDT D ^DIE
  1. E S DA=RFL,DA(1)=RX,DIE="^PSRX("_DA(1)_",1,",DR="86///"_SHDT D ^DIE
  1. D RXACT(RX,RFL,COMM,"S",+$G(DUZ)) ; Create Activity Log entry
  1. Q
  1. ;
  1. ; This function returns the EPHARMACY SUSPENSE HOLD DATE field
  1. ; for the original fill or the refill.
  1. ; Input: RX = Prescription File IEN
  1. ; RFL = Refill
  1. SHDT(RX,RFL) ;
  1. N FILE,IENS
  1. I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
  1. S FILE=$S(RFL=0:52,1:52.1),IENS=$S(RFL=0:RX_",",1:RFL_","_RX_",")
  1. Q $$GET1^DIQ(FILE,IENS,86,"I")
  1. ;
  1. ELOG(RESP) ; Logs an ECME Activity Log if Rx Qty is different than Billing Qty
  1. I '$G(RESP),$T(NCPDPQTY^PSSBPSUT)'="" D
  1. . N DRUG,RXQTY,BLQTY,BLDU,Z
  1. . S DRUG=$$GET1^DIQ(52,RX,6,"I")
  1. . S RXQTY=$S('RFL:$$GET1^DIQ(52,RX,7,"I"),1:$$GET1^DIQ(52.1,RFL_","_RX,1))/1
  1. . S Z=$$NCPDPQTY^PSSBPSUT(DRUG,RXQTY),BLQTY=Z/1,BLDU=$P(Z,"^",2)
  1. . I RXQTY'=BLQTY D
  1. . . D RXACT(RX,RFL,"QUANTITY SUBMITTED ON CLAIM: "_$J(BLQTY,0,$L($P(BLQTY,".",2)))_" ("_BLDU_")","M",DUZ)
  1. Q
  1. ;
  1. UPDFL(RXREC,SUB,INDT) ; Update fill date with release date when NDC changes at CMOP and OPAI auto-release
  1. ; Input: RXREC = Prescription File IEN
  1. ; SUB = Refill
  1. ; INDT = Release date
  1. N COM,DA,DEAD,DIE,DR,DTOUT,DUOUT,EXDAT,EXPDATE,II,OFILLD
  1. N PSOSUSPA,RXRECI
  1. ;
  1. S DEAD=0
  1. S EXDAT=INDT
  1. I EXDAT["." S EXDAT=$P(EXDAT,".")
  1. ;
  1. ; If the expiration date of the prescription is on or before
  1. ; the Released Date, then Quit out (i.e. do not change the
  1. ; Fill Date, do not add an entry to the Activity Log).
  1. ;
  1. S EXPDATE=$$GET1^DIQ(52,RXREC,26,"I")
  1. I EXPDATE'="",EXPDATE'>EXDAT Q
  1. ;
  1. I '$D(SUB) S SUB=0 F II=0:0 S II=$O(^PSRX(RXREC,1,II)) Q:'II S SUB=+II
  1. I 'SUB D
  1. . S OFILLD=$$GET1^DIQ(52,RXREC,22,"I")
  1. . I OFILLD=EXDAT Q
  1. . S DA=RXREC
  1. . S DIE=52
  1. . S DR="22///"_EXDAT_";101///"_EXDAT
  1. . D ^DIE
  1. . K DIE,DA
  1. . Q
  1. I SUB D
  1. . S OFILLD=$$GET1^DIQ(52.1,SUB_","_RXREC,.01,"I")
  1. . I OFILLD=EXDAT Q
  1. . S DA=SUB
  1. . S DA(1)=RXREC
  1. . S DIE="^PSRX("_DA(1)_",1,"
  1. . S DR=".01///"_EXDAT
  1. . D ^DIE
  1. . K DIE
  1. . S $P(^PSRX(RXREC,3),"^")=EXDAT ; Field# 101, Last Dispensed Date
  1. . Q
  1. I $D(DTOUT)!($D(DUOUT)) Q
  1. ;
  1. S RXRECI=$O(^PS(52.5,"B",RXREC,0))
  1. I RXRECI S PSOSUSPA=$P($G(^PS(52.5,RXRECI,0)),"^",5)
  1. S COM="Change "_$S($G(PSOSUSPA):"Partial",'$G(SUB):"Fill",1:"Refill")_" Date "_$E(OFILLD,4,5)_"/"_$E(OFILLD,6,7)_"/"_$E(OFILLD,2,3)_" to "_$E(INDT,4,5)_"/"_$E(INDT,6,7)_"/"_$E(INDT,2,3)
  1. D RXACT(RXREC,SUB,COM,"S",DUZ)
  1. FIN ;
  1. Q
  1. ;
  1. SEND(PSORX,PSOFILL) ; Determine whether to send a claim.
  1. ;
  1. ; Returns: 1 = Send a claim
  1. ; 0 = Do not send a claim
  1. ;
  1. ; A claim should not be sent if the last submission was rejected
  1. ; and all rejects have been closed.
  1. ;
  1. ; If status of last submission is not E REJECTED, then send a claim.
  1. ;
  1. N PSOSTATUS
  1. S PSOSTATUS=$$STATUS^PSOBPSUT(PSORX,PSOFILL)
  1. I PSOSTATUS'="E REJECTED" Q 1
  1. ;
  1. ; If there are any open rejects, then send a claim.
  1. ;
  1. I $$FIND^PSOREJUT(PSORX,PSOFILL) Q 1
  1. ;
  1. ; The last submission was rejected, and there are no open rejects.
  1. ; Quit with a 0 (zero) to indicate a claim should not be sent.
  1. ;
  1. Q 0