IBTRKR3 ;ALB/AAS - CLAIMS TRACKING - ADD/TRACK RX FILLS ;13-AUG-93
;;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
;;Per VA Directive 6402, this routine should not be modified.
;
% ; -- entry point for nightly background job
N IBTSBDT,IBTSEDT
S IBTSBDT=$$FMADD^XLFDT(DT,-14)-.1
S IBTSEDT=$$FMADD^XLFDT(DT,-7)+.9
D EN1
Q
;
EN ; -- entry point to ask date range
N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI() ;IB*2.0*312
N IBBDT,IBEDT,IBTSBDT,IBTSEDT,IBTALK,IBMESS
S IBTALK=1
I '$P($G(^IBE(350.9,1,6)),"^",4) W !!,"I'm sorry, Tracking of Prescription Refills is currently turned off." G ENQ
W !!!,"Select the Date Range of Rx Refills to Add to Claims Tracking.",!
D DATE^IBOUTL
I IBBDT<1!(IBEDT<1) G ENQ
S IBTSBDT=IBBDT,IBTSEDT=IBEDT
;
; Do NOT PROCESS on VistA if Start or End>=Switch Eff Date ;IB*2.0*312
I +IBSWINFO,((IBTSBDT+1)>$P(IBSWINFO,"^",2))!((IBTSEDT+1)>$P(IBSWINFO,"^",2)) D G EN
.W !!,"The Begin OR End Date CANNOT be on or after"
.W !,"the PFSS Effective Date: ",$$FMTE^XLFDT($P(IBSWINFO,"^",2))
;
; -- check selected dates
S IBTRKR=$G(^IBE(350.9,1,6))
; start date can't be before parameters
I +IBTRKR,IBTSBDT<+IBTRKR S IBTSBDT=IBTRKR W !!,"Begin date is before Claims Tracking Start Date, changed to ",$$DAT1^IBOUTL(IBTSBDT)
; -- end date into future
I IBTSEDT>$$FMADD^XLFDT(DT,-3) W !!,"I'll automatically change the end date to 3 days prior to the date queued to run."
;
W !!!,"I'm going to automatically queue this off and send you a"
W !,"mail message when complete.",!
S ZTIO="",ZTRTN="EN1^IBTRKR3",ZTSAVE("IB*")="",ZTDESC="IB - Add Rx Refills to Claims Tracking"
D ^%ZTLOAD I $G(ZTSK) K ZTSK W !,"Request Queued"
ENQ K ZTSK,ZTIO,ZTSAVE,ZTDESC,ZTRTN
D HOME^%ZIS
Q
;
EN1 ; -- add rx refills to claims tracking file
N I,J,X,Y,IBTRKR,IBDT,IBRXN,IBFILL,DFN,IBDATA,IBCNT,IBCNT1,IBCNT2,LIST1
N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI() ;IB*2.0*312
N IBICD,IBCOPAY
;
; -- check parameters
S IBTRKR=$G(^IBE(350.9,1,6))
G:'$P(IBTRKR,"^",4) EN1Q ; quit if rx tracking off
I +IBTRKR,IBTSBDT<+IBTRKR S IBTSBDT=IBTRKR ; start date can't be before parameters
;
; -- users can queue into future, make sure dates not after date run
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)
;
S IBRXTYP=$O(^IBE(356.6,"AC",4,0)) ; event type pointer for rx billing
;
; -- cnt= total count, cnt1=count added nsc, cnt2=count of pending
S (IBCNT,IBCNT1,IBCNT2)=0
S IBDT=IBTSBDT-.0001
S LIST1="IBTRKAD"
D REF^PSO52EX(IBDT,IBTSEDT,LIST1)
S IBDT=0
F S IBDT=$O(^TMP($J,LIST1,"AD",IBDT)) Q:'IBDT!(IBDT>IBTSEDT) D
.S IBRXN=0
.I +IBSWINFO,(IBDT+1)>$P(IBSWINFO,"^",2) Q
.F S IBRXN=$O(^TMP($J,LIST1,"AD",IBDT,IBRXN)) Q:'IBRXN D
..S IBFILL=""
..F S IBFILL=$O(^TMP($J,LIST1,"AD",IBDT,IBRXN,IBFILL)) Q:IBFILL="" D RXCHK
K ^TMP($J,LIST1)
;
I $G(IBTALK) D BULL^IBTRKR31
EN1Q I $D(ZTQUEUED) S ZTREQ="@"
Q
;
RXCHK ; -- check and add rx
N IBND,LIST,NODE
S IBCNT=IBCNT+1
;I IBFILL<1 G RXCHKQ ; original fill
I IBDT>(DT+.24) G RXCHKQ ; future fill
I '$D(ZTQUEUED),($G(IBTALK)) W "."
;
S DFN=$$FILE^IBRXUTL(IBRXN,2)
S IBRXDATA=$$RXZERO^IBRXUTL(DFN,IBRXN),IBRXSTAT=$$FILE^IBRXUTL(IBRXN,100,"I")
;I IBDT=$P($O(^DPT(DFN,"S",(IBDT-.00001))),".") G RXCHKQ ;scheduled appointment on same day as fill date
;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)
;
; -- not already in claims tracking
I $O(^IBT(356,"ARXFL",IBRXN,IBFILL,"")) G RXCHKQ ; already in claims tracking
;
; -- see if tracking only insured and pt is insured
I $P(IBTRKR,"^",4)=1,'$$INSURED^IBCNS1(DFN,IBDT) G RXCHKQ ; patient not insure
;
; -- check rx status (not deleted)
I IBRXSTAT=13 G RXCHKQ
;
; -- Don't PROCESS IF there is already a PFSS ACCT REF# -- ;IB*2.0*312
I 'IBFILL,+$$FILE^IBRXUTL(IBRXN,125) G RXCHKQ
I +IBFILL,+$$SUBFILE^IBRXUTL(IBRXN,IBFILL,52,21) G RXCHKQ
;
; -- original fill not released or returned to stock
I 'IBFILL,'$$FILE^IBRXUTL(IBRXN,31) G RXCHKQ
I 'IBFILL,$$FILE^IBRXUTL(IBRXN,32.1) G RXCHKQ
;
; -- refill not released or returned to stock
I +IBFILL,'$$SUBFILE^IBRXUTL(IBRXN,IBFILL,52,17) G RXCHKQ
I +IBFILL,$$SUBFILE^IBRXUTL(IBRXN,IBFILL,52,14) G RXCHKQ
;
; -- check drug (not investigational, supply, over the counter drug, or nutritional supplement
S IBDRUG=$P(IBRXDATA,"^",6)
D ZERO^IBRXUTL(IBDRUG)
S IBDEA=$G(^TMP($J,"IBDRUG",+IBDRUG,3))
K ^TMP($J,"IBDRUG")
I IBDEA["I"!(IBDEA["S")!(IBDEA["9")!(IBDEA["N") G RXCHKQ ; investigational drug, supply, otc, or nutritional supplement
;
; -- see if insured for prescriptions
I '$$PTCOV^IBCNSU3(DFN,IBDT,"PHARMACY",.IBANY) S IBRMARK=$S($G(IBANY):"NO PHARMACY COVERAGE",1:"NOT INSURED")
;
; -- check sc status and others
; -- new ICD node in PSO with CIDC, if it exists use this for determination
S LIST="IBTRKRLST"
S NODE="ICD"
S IBICD=0,IBCOPAY=0
D RX^PSO52API(DFN,LIST,IBRXN,,NODE,,)
I +$G(^TMP($J,LIST,DFN,IBRXN,"ICD",0))>0 S IBICD=1 ;Setup ICD Flag
I +$$IBND^IBRXUTL(DFN,IBRXN)>0 S IBCOPAY=1 ;Setup Copay Flag
I $G(IBRMARK)="",IBICD D CL^SDCO21(DFN,IBDT,"",.IBARR) I $D(IBARR) D
.S IBM=0
.F S IBM=$O(^TMP($J,LIST,DFN,IBRXN,"ICD",IBM)) Q:'IBM!($G(IBRMARK)'="") D
..S IBZ=$$ICD^IBRXUTL1(DFN,IBRXN,IBM,LIST) F IBP=1:1:7 Q:$G(IBRMARK)'="" I $D(IBARR(IBP)) D
... S IBRMARK=$S($P(IBZ,"^",IBP+1):$P($T(EXEMPT+IBP),";",3),$P(IBZ,"^",IBP+1)=0:"",1:"NEEDS SC DETERMINATION")
;
; -- no new ICD node in PSO, use old method of determining status
I $G(IBRMARK)="",'IBICD D
. D ELIG^VADPT
. ;if the patient is covered by insurance for pharmacy ($G(IBRMARK)="")
. ;AND if no copay in #350
. ;then we need to determine the non billable reason and set IBRMARK
. ;
. ;IF VAEL(3) -- if this is a veteran with SC(service connection) status
. I VAEL(3),'IBCOPAY D
. . I $P(VAEL(3),"^",2)>49 S IBRMARK="NEEDS SC DETERMINATION"
. . ;in case of POW and Unempl.vet we cannot decide if the 3rd party should be exempt
. . N IBPOWUNV,IBAUTRET S IBAUTRET=$$AUTOINFO^DGMTCOU1(DFN),IBPOWUNV=$S($P(IBAUTRET,U,8):1,$P(IBAUTRET,U,9):1,1:0)
. . I $P(VAEL(3),"^",2)<50 S IBRMARK=$S(IBPOWUNV:"NEEDS SC DETERMINATION",1:"SC TREATMENT")
. . I $$RXST^IBARXEU(DFN,$P(IBRXDATA,U,13))>0 S IBRMARK="NEEDS SC DETERMINATION"
. ;
. ;IF +VAEL(3)=0 if the veteran doesn't have SC status, but
. ;the veteran still may have CV status active
. I $G(IBRMARK)="",+VAEL(3)=0,'IBCOPAY D
. . 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
;
K ^TMP($J,LIST)
;
; ROI check. The variable IBSCROI will be set to:
; '1' if NOT REQUIRED '2' if OBTAINED
; '3' if REQUIRED '4' if REFUSED
N IBSCROI
;
; $$SENS^IBNCPDR returns 1 if the drug is sensitive diagnosis drug
;
I $$SENS^IBNCPDR(IBDRUG) D
. N IBINS,IBFLG,IBINSP
. D ALL^IBCNS1(DFN,"IBINS",1,IBDT,1)
. S IBINSP=$O(IBINS("S",1,99),-1) Q:IBINSP=""
. ; If the DOS is on or after to the Mission Act implementation date,
. ; skip the ROI check.
. I $$MACHK^IBNCPDR4(IBDT) S (IBFLG,IBSCROI)=1,IBRMARK="" Q
. S IBFLG=$$ROI^IBNCPDR4(DFN,$G(IBDRUG),+$G(IBINS(IBINSP,"0")),$G(IBDT))
. I 'IBFLG,$G(IBRMARK)="" S IBRMARK="ROI NOT OBTAINED" ; IB*2*550
. I 'IBFLG S IBSCROI=3
. I IBFLG S IBSCROI=2
;
; -- ok to add to tracking module
D REFILL^IBTUTL1(DFN,IBRXTYP,IBDT,IBRXN,IBFILL,$G(IBRMARK),,$G(IBSCROI)) I '$D(ZTQUEUED),$G(IBTALK) W "+"
;
I $G(IBRMARK)'="" S IBCNT2=IBCNT2+1
I $G(IBRMARK)="" S IBCNT1=IBCNT1+1
K IBANY,IBRMARK,VAEL,VA,IBDEA,IBDRUG,IBRXSTAT,IBRXDATA,DFN,X,Y
K IBARR,IBM,IBZ,IBP
RXCHKQ Q
;
EXEMPT ; exemption reasons
;;AGENT ORANGE
;;IONIZING RADIATION
;;SC TREATMENT
;;SOUTHWEST ASIA
;;MILITARY SEXUAL TRAUMA
;;HEAD/NECK CANCER
;;COMBAT VETERAN
;;PROJECT 112/SHAD
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTRKR3 8294 printed Dec 13, 2024@02:28:39 Page 2
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
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
% ; -- entry point for nightly background job
+1 NEW IBTSBDT,IBTSEDT
+2 SET IBTSBDT=$$FMADD^XLFDT(DT,-14)-.1
+3 SET IBTSEDT=$$FMADD^XLFDT(DT,-7)+.9
+4 DO EN1
+5 QUIT
+6 ;
EN ; -- entry point to ask date range
+1 ;IB*2.0*312
NEW IBSWINFO
SET IBSWINFO=$$SWSTAT^IBBAPI()
+2 NEW IBBDT,IBEDT,IBTSBDT,IBTSEDT,IBTALK,IBMESS
+3 SET IBTALK=1
+4 IF '$PIECE($GET(^IBE(350.9,1,6)),"^",4)
WRITE !!,"I'm sorry, Tracking of Prescription Refills is currently turned off."
GOTO ENQ
+5 WRITE !!!,"Select the Date Range of Rx Refills to Add to Claims Tracking.",!
+6 DO DATE^IBOUTL
+7 IF IBBDT<1!(IBEDT<1)
GOTO ENQ
+8 SET IBTSBDT=IBBDT
SET IBTSEDT=IBEDT
+9 ;
+10 ; Do NOT PROCESS on VistA if Start or End>=Switch Eff Date ;IB*2.0*312
+11 IF +IBSWINFO
IF ((IBTSBDT+1)>$PIECE(IBSWINFO,"^",2))!((IBTSEDT+1)>$PIECE(IBSWINFO,"^",2))
Begin DoDot:1
+12 WRITE !!,"The Begin OR End Date CANNOT be on or after"
+13 WRITE !,"the PFSS Effective Date: ",$$FMTE^XLFDT($PIECE(IBSWINFO,"^",2))
End DoDot:1
GOTO EN
+14 ;
+15 ; -- check selected dates
+16 SET IBTRKR=$GET(^IBE(350.9,1,6))
+17 ; start date can't be before parameters
+18 IF +IBTRKR
IF IBTSBDT<+IBTRKR
SET IBTSBDT=IBTRKR
WRITE !!,"Begin date is before Claims Tracking Start Date, changed to ",$$DAT1^IBOUTL(IBTSBDT)
+19 ; -- end date into future
+20 IF IBTSEDT>$$FMADD^XLFDT(DT,-3)
WRITE !!,"I'll automatically change the end date to 3 days prior to the date queued to run."
+21 ;
+22 WRITE !!!,"I'm going to automatically queue this off and send you a"
+23 WRITE !,"mail message when complete.",!
+24 SET ZTIO=""
SET ZTRTN="EN1^IBTRKR3"
SET ZTSAVE("IB*")=""
SET ZTDESC="IB - Add Rx Refills to Claims Tracking"
+25 DO ^%ZTLOAD
IF $GET(ZTSK)
KILL ZTSK
WRITE !,"Request Queued"
ENQ KILL ZTSK,ZTIO,ZTSAVE,ZTDESC,ZTRTN
+1 DO HOME^%ZIS
+2 QUIT
+3 ;
EN1 ; -- add rx refills to claims tracking file
+1 NEW I,J,X,Y,IBTRKR,IBDT,IBRXN,IBFILL,DFN,IBDATA,IBCNT,IBCNT1,IBCNT2,LIST1
+2 ;IB*2.0*312
NEW IBSWINFO
SET IBSWINFO=$$SWSTAT^IBBAPI()
+3 NEW IBICD,IBCOPAY
+4 ;
+5 ; -- check parameters
+6 SET IBTRKR=$GET(^IBE(350.9,1,6))
+7 ; quit if rx tracking off
if '$PIECE(IBTRKR,"^",4)
GOTO EN1Q
+8 ; start date can't be before parameters
IF +IBTRKR
IF IBTSBDT<+IBTRKR
SET IBTSBDT=IBTRKR
+9 ;
+10 ; -- users can queue into future, make sure dates not after date run
+11 IF IBTSEDT>$$FMADD^XLFDT(DT,-3)
SET IBMESS="(Selected end date of "_$$DAT1^IBOUTL(IBTSEDT)_" automatically changed to "_$$DAT1^IBOUTL($$FMADD^XLFDT(DT,-3))_".)"
SET IBTSEDT=$$FMADD^XLFDT(DT,-3)
+12 ;
+13 ; event type pointer for rx billing
SET IBRXTYP=$ORDER(^IBE(356.6,"AC",4,0))
+14 ;
+15 ; -- cnt= total count, cnt1=count added nsc, cnt2=count of pending
+16 SET (IBCNT,IBCNT1,IBCNT2)=0
+17 SET IBDT=IBTSBDT-.0001
+18 SET LIST1="IBTRKAD"
+19 DO REF^PSO52EX(IBDT,IBTSEDT,LIST1)
+20 SET IBDT=0
+21 FOR
SET IBDT=$ORDER(^TMP($JOB,LIST1,"AD",IBDT))
if 'IBDT!(IBDT>IBTSEDT)
QUIT
Begin DoDot:1
+22 SET IBRXN=0
+23 IF +IBSWINFO
IF (IBDT+1)>$PIECE(IBSWINFO,"^",2)
QUIT
+24 FOR
SET IBRXN=$ORDER(^TMP($JOB,LIST1,"AD",IBDT,IBRXN))
if 'IBRXN
QUIT
Begin DoDot:2
+25 SET IBFILL=""
+26 FOR
SET IBFILL=$ORDER(^TMP($JOB,LIST1,"AD",IBDT,IBRXN,IBFILL))
if IBFILL=""
QUIT
DO RXCHK
End DoDot:2
End DoDot:1
+27 KILL ^TMP($JOB,LIST1)
+28 ;
+29 IF $GET(IBTALK)
DO BULL^IBTRKR31
EN1Q IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 QUIT
+2 ;
RXCHK ; -- check and add rx
+1 NEW IBND,LIST,NODE
+2 SET IBCNT=IBCNT+1
+3 ;I IBFILL<1 G RXCHKQ ; original fill
+4 ; future fill
IF IBDT>(DT+.24)
GOTO RXCHKQ
+5 IF '$DATA(ZTQUEUED)
IF ($GET(IBTALK))
WRITE "."
+6 ;
+7 SET DFN=$$FILE^IBRXUTL(IBRXN,2)
+8 SET IBRXDATA=$$RXZERO^IBRXUTL(DFN,IBRXN)
SET IBRXSTAT=$$FILE^IBRXUTL(IBRXN,100,"I")
+9 ;I IBDT=$P($O(^DPT(DFN,"S",(IBDT-.00001))),".") G RXCHKQ ;scheduled appointment on same day as fill date
+10 ;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)
+11 ;
+12 ; -- not already in claims tracking
+13 ; already in claims tracking
IF $ORDER(^IBT(356,"ARXFL",IBRXN,IBFILL,""))
GOTO RXCHKQ
+14 ;
+15 ; -- see if tracking only insured and pt is insured
+16 ; patient not insure
IF $PIECE(IBTRKR,"^",4)=1
IF '$$INSURED^IBCNS1(DFN,IBDT)
GOTO RXCHKQ
+17 ;
+18 ; -- check rx status (not deleted)
+19 IF IBRXSTAT=13
GOTO RXCHKQ
+20 ;
+21 ; -- Don't PROCESS IF there is already a PFSS ACCT REF# -- ;IB*2.0*312
+22 IF 'IBFILL
IF +$$FILE^IBRXUTL(IBRXN,125)
GOTO RXCHKQ
+23 IF +IBFILL
IF +$$SUBFILE^IBRXUTL(IBRXN,IBFILL,52,21)
GOTO RXCHKQ
+24 ;
+25 ; -- original fill not released or returned to stock
+26 IF 'IBFILL
IF '$$FILE^IBRXUTL(IBRXN,31)
GOTO RXCHKQ
+27 IF 'IBFILL
IF $$FILE^IBRXUTL(IBRXN,32.1)
GOTO RXCHKQ
+28 ;
+29 ; -- refill not released or returned to stock
+30 IF +IBFILL
IF '$$SUBFILE^IBRXUTL(IBRXN,IBFILL,52,17)
GOTO RXCHKQ
+31 IF +IBFILL
IF $$SUBFILE^IBRXUTL(IBRXN,IBFILL,52,14)
GOTO RXCHKQ
+32 ;
+33 ; -- check drug (not investigational, supply, over the counter drug, or nutritional supplement
+34 SET IBDRUG=$PIECE(IBRXDATA,"^",6)
+35 DO ZERO^IBRXUTL(IBDRUG)
+36 SET IBDEA=$GET(^TMP($JOB,"IBDRUG",+IBDRUG,3))
+37 KILL ^TMP($JOB,"IBDRUG")
+38 ; investigational drug, supply, otc, or nutritional supplement
IF IBDEA["I"!(IBDEA["S")!(IBDEA["9")!(IBDEA["N")
GOTO RXCHKQ
+39 ;
+40 ; -- see if insured for prescriptions
+41 IF '$$PTCOV^IBCNSU3(DFN,IBDT,"PHARMACY",.IBANY)
SET IBRMARK=$SELECT($GET(IBANY):"NO PHARMACY COVERAGE",1:"NOT INSURED")
+42 ;
+43 ; -- check sc status and others
+44 ; -- new ICD node in PSO with CIDC, if it exists use this for determination
+45 SET LIST="IBTRKRLST"
+46 SET NODE="ICD"
+47 SET IBICD=0
SET IBCOPAY=0
+48 DO RX^PSO52API(DFN,LIST,IBRXN,,NODE,,)
+49 ;Setup ICD Flag
IF +$GET(^TMP($JOB,LIST,DFN,IBRXN,"ICD",0))>0
SET IBICD=1
+50 ;Setup Copay Flag
IF +$$IBND^IBRXUTL(DFN,IBRXN)>0
SET IBCOPAY=1
+51 IF $GET(IBRMARK)=""
IF IBICD
DO CL^SDCO21(DFN,IBDT,"",.IBARR)
IF $DATA(IBARR)
Begin DoDot:1
+52 SET IBM=0
+53 FOR
SET IBM=$ORDER(^TMP($JOB,LIST,DFN,IBRXN,"ICD",IBM))
if 'IBM!($GET(IBRMARK)'="")
QUIT
Begin DoDot:2
+54 SET IBZ=$$ICD^IBRXUTL1(DFN,IBRXN,IBM,LIST)
FOR IBP=1:1:7
if $GET(IBRMARK)'=""
QUIT
IF $DATA(IBARR(IBP))
Begin DoDot:3
+55 SET IBRMARK=$SELECT($PIECE(IBZ,"^",IBP+1):$PIECE($TEXT(EXEMPT+IBP),";",3),$PIECE(IBZ,"^",IBP+1)=0:"",1:"NEEDS SC DETERMINATION")
End DoDot:3
End DoDot:2
End DoDot:1
+56 ;
+57 ; -- no new ICD node in PSO, use old method of determining status
+58 IF $GET(IBRMARK)=""
IF 'IBICD
Begin DoDot:1
+59 DO ELIG^VADPT
+60 ;if the patient is covered by insurance for pharmacy ($G(IBRMARK)="")
+61 ;AND if no copay in #350
+62 ;then we need to determine the non billable reason and set IBRMARK
+63 ;
+64 ;IF VAEL(3) -- if this is a veteran with SC(service connection) status
+65 IF VAEL(3)
IF 'IBCOPAY
Begin DoDot:2
+66 IF $PIECE(VAEL(3),"^",2)>49
SET IBRMARK="NEEDS SC DETERMINATION"
+67 ;in case of POW and Unempl.vet we cannot decide if the 3rd party should be exempt
+68 NEW IBPOWUNV,IBAUTRET
SET IBAUTRET=$$AUTOINFO^DGMTCOU1(DFN)
SET IBPOWUNV=$SELECT($PIECE(IBAUTRET,U,8):1,$PIECE(IBAUTRET,U,9):1,1:0)
+69 IF $PIECE(VAEL(3),"^",2)<50
SET IBRMARK=$SELECT(IBPOWUNV:"NEEDS SC DETERMINATION",1:"SC TREATMENT")
+70 IF $$RXST^IBARXEU(DFN,$PIECE(IBRXDATA,U,13))>0
SET IBRMARK="NEEDS SC DETERMINATION"
End DoDot:2
+71 ;
+72 ;IF +VAEL(3)=0 if the veteran doesn't have SC status, but
+73 ;the veteran still may have CV status active
+74 IF $GET(IBRMARK)=""
IF +VAEL(3)=0
IF 'IBCOPAY
Begin DoDot:2
+75 ;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
IF $$CVEDT^IBACV(DFN,IBDT)
SET IBRMARK="NEEDS SC DETERMINATION"
End DoDot:2
End DoDot:1
+76 ;
+77 KILL ^TMP($JOB,LIST)
+78 ;
+79 ; ROI check. The variable IBSCROI will be set to:
+80 ; '1' if NOT REQUIRED '2' if OBTAINED
+81 ; '3' if REQUIRED '4' if REFUSED
+82 NEW IBSCROI
+83 ;
+84 ; $$SENS^IBNCPDR returns 1 if the drug is sensitive diagnosis drug
+85 ;
+86 IF $$SENS^IBNCPDR(IBDRUG)
Begin DoDot:1
+87 NEW IBINS,IBFLG,IBINSP
+88 DO ALL^IBCNS1(DFN,"IBINS",1,IBDT,1)
+89 SET IBINSP=$ORDER(IBINS("S",1,99),-1)
if IBINSP=""
QUIT
+90 ; If the DOS is on or after to the Mission Act implementation date,
+91 ; skip the ROI check.
+92 IF $$MACHK^IBNCPDR4(IBDT)
SET (IBFLG,IBSCROI)=1
SET IBRMARK=""
QUIT
+93 SET IBFLG=$$ROI^IBNCPDR4(DFN,$GET(IBDRUG),+$GET(IBINS(IBINSP,"0")),$GET(IBDT))
+94 ; IB*2*550
IF 'IBFLG
IF $GET(IBRMARK)=""
SET IBRMARK="ROI NOT OBTAINED"
+95 IF 'IBFLG
SET IBSCROI=3
+96 IF IBFLG
SET IBSCROI=2
End DoDot:1
+97 ;
+98 ; -- ok to add to tracking module
+99 DO REFILL^IBTUTL1(DFN,IBRXTYP,IBDT,IBRXN,IBFILL,$GET(IBRMARK),,$GET(IBSCROI))
IF '$DATA(ZTQUEUED)
IF $GET(IBTALK)
WRITE "+"
+100 ;
+101 IF $GET(IBRMARK)'=""
SET IBCNT2=IBCNT2+1
+102 IF $GET(IBRMARK)=""
SET IBCNT1=IBCNT1+1
+103 KILL IBANY,IBRMARK,VAEL,VA,IBDEA,IBDRUG,IBRXSTAT,IBRXDATA,DFN,X,Y
+104 KILL IBARR,IBM,IBZ,IBP
RXCHKQ QUIT
+1 ;
EXEMPT ; exemption reasons
+1 ;;AGENT ORANGE
+2 ;;IONIZING RADIATION
+3 ;;SC TREATMENT
+4 ;;SOUTHWEST ASIA
+5 ;;MILITARY SEXUAL TRAUMA
+6 ;;HEAD/NECK CANCER
+7 ;;COMBAT VETERAN
+8 ;;PROJECT 112/SHAD
+9 ;;
