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

IBTRKR3.m

Go to the documentation of this file. 
  1. IBTRKR3 ;ALB/AAS - CLAIMS TRACKING - ADD/TRACK RX FILLS ;13-AUG-93
  1.  ;;2.0;INTEGRATED BILLING;**13,43,121,160,247,275,260,309,336,312,339,347,405,384,550,624**;21-MAR-94;Build 10
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1. % ; -- entry point for nightly background job
  1.  N IBTSBDT,IBTSEDT
  1.  S IBTSBDT=$$FMADD^XLFDT(DT,-14)-.1
  1.  S IBTSEDT=$$FMADD^XLFDT(DT,-7)+.9
  1.  D EN1
  1.  Q
  1.  ;
  1. EN ; -- entry point to ask date range
  1.  N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI() ;IB*2.0*312
  1.  N IBBDT,IBEDT,IBTSBDT,IBTSEDT,IBTALK,IBMESS
  1.  S IBTALK=1
  1.  I '$P($G(^IBE(350.9,1,6)),"^",4) W !!,"I'm sorry, Tracking of Prescription Refills is currently turned off." G ENQ
  1.  W !!!,"Select the Date Range of Rx Refills to Add to Claims Tracking.",!
  1.  D DATE^IBOUTL
  1.  I IBBDT<1!(IBEDT<1) G ENQ
  1.  S IBTSBDT=IBBDT,IBTSEDT=IBEDT
  1.  ;
  1.  ; Do NOT PROCESS on VistA if Start or End>=Switch Eff Date ;IB*2.0*312
  1.  I +IBSWINFO,((IBTSBDT+1)>$P(IBSWINFO,"^",2))!((IBTSEDT+1)>$P(IBSWINFO,"^",2)) D  G EN
  1.  .W !!,"The Begin OR End Date CANNOT be on or after"
  1.  .W !,"the PFSS Effective Date: ",$$FMTE^XLFDT($P(IBSWINFO,"^",2))
  1.  ;
  1.  ; -- check selected dates
  1.  S IBTRKR=$G(^IBE(350.9,1,6))
  1.  ; start date can't be before parameters
  1.  I +IBTRKR,IBTSBDT<+IBTRKR S IBTSBDT=IBTRKR W !!,"Begin date is before Claims Tracking Start Date, changed to ",$$DAT1^IBOUTL(IBTSBDT)
  1.  ; -- end date into future
  1.  I IBTSEDT>$$FMADD^XLFDT(DT,-3) W !!,"I'll automatically change the end date to 3 days prior to the date queued to run."
  1.  ;
  1.  W !!!,"I'm going to automatically queue this off and send you a"
  1.  W !,"mail message when complete.",!
  1.  S ZTIO="",ZTRTN="EN1^IBTRKR3",ZTSAVE("IB*")="",ZTDESC="IB - Add Rx Refills to Claims Tracking"
  1.  D ^%ZTLOAD I $G(ZTSK) K ZTSK W !,"Request Queued"
  1. ENQ K ZTSK,ZTIO,ZTSAVE,ZTDESC,ZTRTN
  1.  D HOME^%ZIS
  1.  Q
  1.  ;
  1. EN1 ; -- add rx refills to claims tracking file
  1.  N I,J,X,Y,IBTRKR,IBDT,IBRXN,IBFILL,DFN,IBDATA,IBCNT,IBCNT1,IBCNT2,LIST1
  1.  N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI() ;IB*2.0*312
  1.  N IBICD,IBCOPAY
  1.  ;
  1.  ; -- check parameters
  1.  S IBTRKR=$G(^IBE(350.9,1,6))
  1.  G:'$P(IBTRKR,"^",4) EN1Q ; quit if rx tracking off
  1.  I +IBTRKR,IBTSBDT<+IBTRKR S IBTSBDT=IBTRKR ; start date can't be before parameters
  1.  ;
  1.  ; -- users can queue into future, make sure dates not after date run
  1.  I IBTSEDT>$$FMADD^XLFDT(DT,-3) S IBMESS="(Selected end date of "_$$DAT1^IBOUTL(IBTSEDT)_" automatically changed to "_$$DAT1^IBOUTL($$FMADD^XLFDT(DT,-3))_".)",IBTSEDT=$$FMADD^XLFDT(DT,-3)
  1.  ;
  1.  S IBRXTYP=$O(^IBE(356.6,"AC",4,0)) ; event type pointer for rx billing
  1.  ;
  1.  ; -- cnt= total count, cnt1=count added nsc, cnt2=count of pending
  1.  S (IBCNT,IBCNT1,IBCNT2)=0
  1.  S IBDT=IBTSBDT-.0001
  1.  S LIST1="IBTRKAD"
  1.  D REF^PSO52EX(IBDT,IBTSEDT,LIST1)
  1.  S IBDT=0
  1.  F  S IBDT=$O(^TMP($J,LIST1,"AD",IBDT)) Q:'IBDT!(IBDT>IBTSEDT)  D
  1.  .S IBRXN=0
  1.  .I +IBSWINFO,(IBDT+1)>$P(IBSWINFO,"^",2) Q
  1.  .F  S IBRXN=$O(^TMP($J,LIST1,"AD",IBDT,IBRXN)) Q:'IBRXN  D
  1.  ..S IBFILL=""
  1.  ..F  S IBFILL=$O(^TMP($J,LIST1,"AD",IBDT,IBRXN,IBFILL)) Q:IBFILL=""  D RXCHK
  1.  K ^TMP($J,LIST1)
  1.  ;
  1.  I $G(IBTALK) D BULL^IBTRKR31
  1. EN1Q I $D(ZTQUEUED) S ZTREQ="@"
  1.  Q
  1.  ;
  1. RXCHK ; -- check and add rx
  1.  N IBND,LIST,NODE
  1.  S IBCNT=IBCNT+1
  1.  ;I IBFILL<1 G RXCHKQ ; original fill
  1.  I IBDT>(DT+.24) G RXCHKQ ; future fill
  1.  I '$D(ZTQUEUED),($G(IBTALK)) W "."
  1.  ;
  1.  S DFN=$$FILE^IBRXUTL(IBRXN,2)
  1.  S IBRXDATA=$$RXZERO^IBRXUTL(DFN,IBRXN),IBRXSTAT=$$FILE^IBRXUTL(IBRXN,100,"I")
  1.  ;I IBDT=$P($O(^DPT(DFN,"S",(IBDT-.00001))),".") G RXCHKQ ;scheduled appointment on same day as fill date
  1.  ;I $$BABCSC^IBEFUNC(DFN,$P(IBDT,".",1)) G RXCHKQ ; is billable clinic stop in encounter file for data (allows telephone stops on same day, but not others) (P121 - RC, can now bill Rx if on same day as opt visit)
  1.  ;
  1.  ; -- not already in claims tracking
  1.  I $O(^IBT(356,"ARXFL",IBRXN,IBFILL,"")) G RXCHKQ ; already in claims tracking
  1.  ;
  1.  ; -- see if tracking only insured and pt is insured
  1.  I $P(IBTRKR,"^",4)=1,'$$INSURED^IBCNS1(DFN,IBDT) G RXCHKQ ; patient not insure
  1.  ;
  1.  ; -- check rx status (not deleted)
  1.  I IBRXSTAT=13 G RXCHKQ
  1.  ;
  1.  ; -- Don't PROCESS IF there is already a PFSS ACCT REF# -- ;IB*2.0*312
  1.  I 'IBFILL,+$$FILE^IBRXUTL(IBRXN,125) G RXCHKQ
  1.  I +IBFILL,+$$SUBFILE^IBRXUTL(IBRXN,IBFILL,52,21) G RXCHKQ
  1.  ;
  1.  ; -- original fill not released or returned to stock
  1.  I 'IBFILL,'$$FILE^IBRXUTL(IBRXN,31) G RXCHKQ
  1.  I 'IBFILL,$$FILE^IBRXUTL(IBRXN,32.1) G RXCHKQ
  1.  ;
  1.  ; -- refill not released or returned to stock
  1.  I +IBFILL,'$$SUBFILE^IBRXUTL(IBRXN,IBFILL,52,17) G RXCHKQ
  1.  I +IBFILL,$$SUBFILE^IBRXUTL(IBRXN,IBFILL,52,14) G RXCHKQ
  1.  ;
  1.  ; -- check drug (not investigational, supply, over the counter drug, or nutritional supplement
  1.  S IBDRUG=$P(IBRXDATA,"^",6)
  1.  D ZERO^IBRXUTL(IBDRUG)
  1.  S IBDEA=$G(^TMP($J,"IBDRUG",+IBDRUG,3))
  1.  K ^TMP($J,"IBDRUG")
  1.  I IBDEA["I"!(IBDEA["S")!(IBDEA["9")!(IBDEA["N") G RXCHKQ ; investigational drug, supply, otc, or nutritional supplement
  1.  ;
  1.  ; -- see if insured for prescriptions
  1.  I '$$PTCOV^IBCNSU3(DFN,IBDT,"PHARMACY",.IBANY) S IBRMARK=$S($G(IBANY):"NO PHARMACY COVERAGE",1:"NOT INSURED")
  1.  ;
  1.  ; -- check sc status and others
  1.  ; -- new ICD node in PSO with CIDC, if it exists use this for determination
  1.  S LIST="IBTRKRLST"
  1.  S NODE="ICD"
  1.  S IBICD=0,IBCOPAY=0
  1.  D RX^PSO52API(DFN,LIST,IBRXN,,NODE,,)
  1.  I +$G(^TMP($J,LIST,DFN,IBRXN,"ICD",0))>0 S IBICD=1 ;Setup ICD Flag
  1.  I +$$IBND^IBRXUTL(DFN,IBRXN)>0 S IBCOPAY=1 ;Setup Copay Flag
  1.  I $G(IBRMARK)="",IBICD D CL^SDCO21(DFN,IBDT,"",.IBARR) I $D(IBARR) D
  1.  .S IBM=0
  1.  .F  S IBM=$O(^TMP($J,LIST,DFN,IBRXN,"ICD",IBM)) Q:'IBM!($G(IBRMARK)'="")  D
  1.  ..S IBZ=$$ICD^IBRXUTL1(DFN,IBRXN,IBM,LIST) F IBP=1:1:7 Q:$G(IBRMARK)'=""  I $D(IBARR(IBP)) D
  1.  ... S IBRMARK=$S($P(IBZ,"^",IBP+1):$P($T(EXEMPT+IBP),";",3),$P(IBZ,"^",IBP+1)=0:"",1:"NEEDS SC DETERMINATION")
  1.  ;
  1.  ; -- no new ICD node in PSO, use old method of determining status
  1.  I $G(IBRMARK)="",'IBICD D
  1.  . D ELIG^VADPT
  1.  . ;if the patient is covered by insurance for pharmacy ($G(IBRMARK)="")
  1.  . ;AND if no copay in #350
  1.  . ;then we need to determine the non billable reason and set IBRMARK
  1.  . ;
  1.  . ;IF VAEL(3) -- if this is a veteran with SC(service connection) status
  1.  . I VAEL(3),'IBCOPAY D
  1.  . . I $P(VAEL(3),"^",2)>49 S IBRMARK="NEEDS SC DETERMINATION"
  1.  . . ;in case of POW and Unempl.vet we cannot decide if the 3rd party should be exempt
  1.  . . N IBPOWUNV,IBAUTRET S IBAUTRET=$$AUTOINFO^DGMTCOU1(DFN),IBPOWUNV=$S($P(IBAUTRET,U,8):1,$P(IBAUTRET,U,9):1,1:0)
  1.  . . I $P(VAEL(3),"^",2)<50 S IBRMARK=$S(IBPOWUNV:"NEEDS SC DETERMINATION",1:"SC TREATMENT")
  1.  . . I $$RXST^IBARXEU(DFN,$P(IBRXDATA,U,13))>0 S IBRMARK="NEEDS SC DETERMINATION"
  1.  . ;
  1.  . ;IF +VAEL(3)=0 if the veteran doesn't have SC status, but
  1.  . ;the veteran still may have CV status active
  1.  . I $G(IBRMARK)="",+VAEL(3)=0,'IBCOPAY D
  1.  . . I $$CVEDT^IBACV(DFN,IBDT) S IBRMARK="NEEDS SC DETERMINATION" ;SC-because IB staff usually is using this reason to search for cases that need to be reviewed. COMBAT VETERAN reason will be used after review if this was a case
  1.  ;
  1.  K ^TMP($J,LIST)
  1.  ;
  1.  ; ROI check.  The variable IBSCROI will be set to:
  1.  ; '1' if NOT REQUIRED  '2' if OBTAINED
  1.  ; '3' if REQUIRED      '4' if REFUSED
  1.  N IBSCROI
  1.  ;
  1.  ; $$SENS^IBNCPDR returns 1 if the drug is sensitive diagnosis drug
  1.  ;
  1.  I $$SENS^IBNCPDR(IBDRUG) D
  1.  . N IBINS,IBFLG,IBINSP
  1.  . D ALL^IBCNS1(DFN,"IBINS",1,IBDT,1)
  1.  . S IBINSP=$O(IBINS("S",1,99),-1) Q:IBINSP=""
  1.  . ; If the DOS is on or after to the Mission Act implementation date,
  1.  . ; skip the ROI check.
  1.  . I $$MACHK^IBNCPDR4(IBDT) S (IBFLG,IBSCROI)=1,IBRMARK="" Q 
  1.  . S IBFLG=$$ROI^IBNCPDR4(DFN,$G(IBDRUG),+$G(IBINS(IBINSP,"0")),$G(IBDT))
  1.  . I 'IBFLG,$G(IBRMARK)="" S IBRMARK="ROI NOT OBTAINED"      ; IB*2*550
  1.  . I 'IBFLG S IBSCROI=3
  1.  . I IBFLG S IBSCROI=2
  1.  ;
  1.  ; -- ok to add to tracking module
  1.  D REFILL^IBTUTL1(DFN,IBRXTYP,IBDT,IBRXN,IBFILL,$G(IBRMARK),,$G(IBSCROI)) I '$D(ZTQUEUED),$G(IBTALK) W "+"
  1.  ;
  1.  I $G(IBRMARK)'="" S IBCNT2=IBCNT2+1
  1.  I $G(IBRMARK)="" S IBCNT1=IBCNT1+1
  1.  K IBANY,IBRMARK,VAEL,VA,IBDEA,IBDRUG,IBRXSTAT,IBRXDATA,DFN,X,Y
  1.  K IBARR,IBM,IBZ,IBP
  1. RXCHKQ Q
  1.  ;
  1. EXEMPT ; exemption reasons
  1.  ;;AGENT ORANGE
  1.  ;;IONIZING RADIATION
  1.  ;;SC TREATMENT
  1.  ;;SOUTHWEST ASIA
  1.  ;;MILITARY SEXUAL TRAUMA
  1.  ;;HEAD/NECK CANCER
  1.  ;;COMBAT VETERAN
  1.  ;;PROJECT 112/SHAD
  1.  ;;