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

PSOTRI.m

Go to the documentation of this file.
  1. PSOTRI ;BIRM/BNT - OP TRICARE/CHAMPVA Audit Log Utilities ;07/21/2010
  1. ;;7.0;OUTPATIENT PHARMACY;**358,385,427,528**;DEC 1997;Build 10
  1. ;
  1. ; Reference to DUR1^BPSNCPD3 supported by IA 4560
  1. ;
  1. Q
  1. ;
  1. ;
  1. AUDIT(RX,RFL,RXCOB,JST,AUD,ELIG) ;
  1. ; Main entry to create a new record in the PSO AUDIT LOG file #52.87
  1. ; Note that AUDIT^PSOTRI is called by ECME (BPSECMP2) - ICR 6156
  1. ; INPUT: RX (r) = Prescription IEN
  1. ; RFL (o) = Prescription Fill # (Default is original zero fill)
  1. ; RXCOB (o) = Coordination of Benefits
  1. ; 1 = Primary (Default)
  1. ; 2 = Secondary
  1. ; JST (o) = Justification text
  1. ; AUD (r) = Audit Type
  1. ; R = NCPDP REJECT - Associated with an Override audit action
  1. ; N = NON BILLABLE - Associated with an Override audit action
  1. ; I = INPATIENT - Associated with a Bypass audit action
  1. ; P = PARTIAL FILL
  1. ; ELIG (r) = Eligibility Type
  1. ; T = TRICARE
  1. ; C = CHAMPVA
  1. ; RETURN: Successful Audit entry will return the IEN of the new entry in file 52.87
  1. ; Unsuccessful Audit entry will return "0^Error Description"
  1. ;
  1. N PSOTRIC,PSODIV,RXFLDS,RFLFLDS,RXECME,PSOFDA,FN,SFN,PSOIEN,PSOIENS,PSOUSER,PSOTC,PSOET
  1. N I,PSOAIEN,PSOREJ,DFN,PSODOA,PSODOS,PSOERR,PSOX,PSOY,RXARR,RFLARR,PSOPHRM,PSOQTY
  1. N PDDATE,PFARR,PFFLDS,PFIEN,PSOPFIEN,PSOUNITCOST
  1. ;
  1. Q:'$D(^PSRX(RX,0)) "0^Prescription does not exist"
  1. ; Verify refill exists
  1. I RFL=""!RFL<0 S RFL=$$LSTRFL^PSOBPSU1(RX)
  1. ;
  1. ; Not original fill
  1. I RFL Q:'$D(^PSRX(RX,1,RFL)) "0^Refill "_RFL_" does not exist"
  1. ;
  1. ; Verify eligibility exists
  1. Q:ELIG="" "0^Eligibiltiy does not exist"
  1. ;
  1. ; Verify Eligibility Type - TRICARE or CHAMPVA patient
  1. I ("/T/C/")'[("/"_ELIG_"/") Q "0^Invalid Eligibility Type "_ELIG
  1. ; PSOTRIC is used below to determine if there is a eT or eC reject code
  1. S (PSOTRIC,PSOTC)="",PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,PSOTRIC)
  1. ;
  1. ; Verify Audit Type
  1. I ("/R/N/I/P/")'[("/"_AUD_"/") Q "0^Invalid Audit Type "_AUD
  1. ;
  1. ; Coordination of Benefits (default is Primary)
  1. S RXCOB=+$G(RXCOB) I RXCOB=0 S RXCOB=1
  1. ; Audit File and Reject subfile
  1. S FN=52.87,SFN=52.8713
  1. ;
  1. ; Fields for original fill:
  1. ; PROVIDER;NDC;DRUG NAME;QUANTITY;PATIENT;PATIENT STATUS;PHARMACIST;UNIT PRICE OF DRUG
  1. S RXFLDS="4;27;6;7;2;3;23;17"
  1. ; Fields for refills
  1. ; PROVIDER;NDC;QUANTITY;PHARMACIST
  1. S RFLFLDS="15;11;1;4"
  1. ;
  1. ; Get data from RX
  1. D GETS^DIQ(52,RX,RXFLDS,"I","RXARR")
  1. ; Get data from Refill
  1. I RFL D GETS^DIQ(52.1,RFL_","_RX,RFLFLDS,"I","RFLARR")
  1. ; Get Division
  1. S PSODIV=$$RXSITE^PSOBPSUT(RX,RFL)
  1. ; ECME Number, if exists
  1. S RXECME=$$ECMENUM^PSOBPSU2(RX,RFL)
  1. ; Date of Action is NOW
  1. S PSODOA=$$NOW^XLFDT()
  1. ; Date of Service
  1. S PSODOS=$$DOS^PSOBPSU1(RX,RFL)
  1. ; User (If null OR Audit Type is Inpatient OR bypass-type reject, set to POSTMASTER)
  1. S PSOUSER=DUZ
  1. I (PSOUSER="")!(AUD="I")!$$BYPASS^PSOBPSU1(ELIG,JST) S PSOUSER=.5
  1. ; Set up FDA array
  1. S PSOIEN="+1,"
  1. S PSOAIEN=$P($G(^PS(52.87,0)),U,3)+1
  1. ;
  1. ; Quantity, Provider and NDC fields
  1. I AUD="P" D
  1. . ; For Partial Fills pull the QTY, PROVIDER and NDC and from
  1. . ; the appropriate entry in the PARTIAL DATE sub-file #52.2.
  1. . ; Attempt to identify a partial fill for today's date.
  1. . S PSOPFIEN=""
  1. . S PFIEN=0 F S PFIEN=$O(^PSRX(RX,"P",PFIEN)) Q:'PFIEN S PDDATE=$P($G(^PSRX(RX,"P",PFIEN,0)),U,8) I $P(PDDATE,".")=$P(PSODOA,".") S PSOPFIEN=PFIEN
  1. . ; partial fill entry for today not found
  1. . I 'PSOPFIEN Q
  1. . ;
  1. . ;QTY;CURRENT UNIT PRICE OF DRUG;PROVIDER;NDC
  1. . S PFFLDS=".04;.042;6;1"
  1. . D GETS^DIQ(52.2,PSOPFIEN_","_RX,PFFLDS,"I","PFARR")
  1. . S PSOQTY=$G(PFARR(52.2,PSOPFIEN_","_RX_",",.04,"I"))
  1. . ;Get the UNIT PRICE OF DRUG from the Prescription, the UNIT PRICE isn't stored
  1. . ; with the partial fill until later in the processing.
  1. . S PSOUNITCOST=$G(RXARR(52,RX_",",17,"I"))
  1. . ; PROVIDER field
  1. . S PSOFDA(FN,PSOIEN,5)=$G(PFARR(52.2,PSOPFIEN_","_RX_",",6,"I"))
  1. . ; NDC field
  1. . S PSOFDA(FN,PSOIEN,6)=$G(PFARR(52.2,PSOPFIEN_","_RX_",",1,"I"))
  1. . I PSOFDA(FN,PSOIEN,6)'="" S PSOFDA(FN,PSOIEN,6)=$G(RXARR(52,RX_",",27,"I"))
  1. . ; BILL COST field
  1. . S PSOFDA(FN,PSOIEN,8)=(PSOUNITCOST*PSOQTY)+8
  1. E D
  1. . S PSOQTY=$S(RFL>0:$G(RFLARR(52.1,RFL_","_RX_",",1,"I")),1:$G(RXARR(52,RX_",",7,"I")))
  1. . ; PROVIDER field
  1. . S PSOFDA(FN,PSOIEN,5)=$S(RFL>0:$G(RFLARR(52.1,RFL_","_RX_",",15,"I")),1:$G(RXARR(52,RX_",",4,"I")))
  1. . ; NDC field
  1. . S PSOFDA(FN,PSOIEN,6)=$S(RFL>0:$G(RFLARR(52.1,RFL_","_RX_",",11,"I")),1:$G(RXARR(52,RX_",",27,"I")))
  1. . ; BILL COST field
  1. . S PSOFDA(FN,PSOIEN,8)=$G(RXARR(52,RX_",",17,"I"))*PSOQTY+8 ;This needs to be verified
  1. ;
  1. ; AUDIT ID field
  1. S PSOFDA(FN,PSOIEN,.01)=PSOAIEN
  1. ; PRESCRIPTION field
  1. S PSOFDA(FN,PSOIEN,1)=RX
  1. ; FILL field
  1. S PSOFDA(FN,PSOIEN,2)=RFL
  1. ; PATIENT field
  1. S PSOFDA(FN,PSOIEN,3)=$G(RXARR(52,RX_",",2,"I"))
  1. ; DIVISION field
  1. S PSOFDA(FN,PSOIEN,4)=PSODIV
  1. ; DRUG field
  1. S PSOFDA(FN,PSOIEN,7)=$G(RXARR(52,RX_",",6,"I"))
  1. ; ECME NUMBER field
  1. S PSOFDA(FN,PSOIEN,9)=RXECME
  1. ; QTY field
  1. S PSOFDA(FN,PSOIEN,10)=PSOQTY
  1. ; PATIENT STATUS field
  1. S PSOFDA(FN,PSOIEN,11)=$G(RXARR(52,RX_",",3,"I"))
  1. ; AUDIT TYPE field
  1. S PSOFDA(FN,PSOIEN,12)=AUD
  1. ; USER field
  1. S PSOFDA(FN,PSOIEN,14)=PSOUSER
  1. ; DATE OF ACTION field
  1. S PSOFDA(FN,PSOIEN,15)=PSODOA
  1. ; DATE OF SERVICE field
  1. S PSOFDA(FN,PSOIEN,16)=PSODOS
  1. ; TRICARE JUSTIFICATION field
  1. S PSOFDA(FN,PSOIEN,17)=JST
  1. ; Eligibility Code
  1. S PSOFDA(FN,PSOIEN,18)=ELIG
  1. ;
  1. D DUR1^BPSNCPD3(RX,RFL,.PSOREJ,.PSOERR,RXCOB)
  1. S PSOET=$$PSOET^PSOREJP3(RX,RFL) ;check to see if eT or eC is the reject code as no ecme claim.
  1. I PSOET S PSOTC=$S(PSOTRIC=1:"eT",PSOTRIC=2:"eC",1:"")
  1. I PSOTC]"",'$D(PSOREJ(RXCOB,"REJ CODES")) S PSOREJ(RXCOB,"REJ CODES",1,PSOTC)="",PSOREJ(RXCOB,"REJ CODE LST")=PSOTC
  1. I $G(PSOREJ(RXCOB,"REJ CODE LST"))]"" D
  1. . S PSOX="",PSOY=1 F I=1:1 S PSOX=$O(PSOREJ(RXCOB,"REJ CODES",I,0)) Q:PSOX="" D
  1. . . S PSOY=PSOY+1,PSOIENS=PSOY_","_PSOIEN
  1. . . S PSOFDA(SFN,"+"_PSOIENS,.01)=PSOX
  1. ;
  1. D UPDATE^DIE("","PSOFDA","","PSOERR")
  1. I $D(PSOERR("DIERR")) D BMES^XPDUTL(PSOERR("DIERR",1,"TEXT",1))
  1. Q