IBTRKR5 ;ALB/AAS - CLAIMS TRACKING - ADD/TRACK PROSTHETICS ;13-JAN-94
;;2.0;INTEGRATED BILLING;**13,260,312,339,389,474,498,568**;21-MAR-94;Build 40
;;Per VA Directive 6402, this routine should not be modified.
;
% ; -- entry point for nightly background job
N IBTSBDT,IBTSEDT
S IBTSBDT=$$FMADD^XLFDT(DT,$S($E(DT,6,7)=10:-730,1:-20))-.1 ;IB*2.0*568
S IBTSEDT=$$FMADD^XLFDT(DT,-3)+.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
S IBTALK=1
I '$P($G(^IBE(350.9,1,6)),"^",4) W !!,"I'm sorry, Tracking of Prosthetics is currently turned off." G ENQ
W !!!,"Select the Date Range of Prosthetics to Add to Claims Tracking.",!
D DATE^IBOUTL
I IBBDT<1!(IBEDT<1) G ENQ
S IBTSBDT=IBBDT,IBTSEDT=IBEDT
;
; -- check selected dates ;IB*2.0*312
; Do NOT PROCESS on VistA if Start or End>=Switch Eff Dt ;CCR-930
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 the PFSS Effective date"
.W ": ",$$FMTE^XLFDT($P(IBSWINFO,"^",2))
;
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 !!,"This should be queued to run after hours"
W !!!,"I'm going to automatically queue this off and send you a"
W !,"mail message when complete.",!
S ZTIO="",ZTRTN="EN1^IBTRKR5",ZTSAVE("IB*")="",ZTDESC="IB - Add Prosthetics 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 prostethics to claims tracking file
N I,J,X,Y,IBTRKR,IBDT,DFN,IBDATA,IBCNT,IBCNT1,IBCNT2,IBDTS,PROCOV
N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI() ;IB*2.0*312
;
; -- check parameters
S IBTRKR=$G(^IBE(350.9,1,6))
G:'$P(IBTRKR,"^",5) EN1Q ; quit if prothetics 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 IBPRTYP=$O(^IBE(356.6,"AC",3,0)) ; this is the event type pointer for prosthetics
;
; -- cnt= total count, cnt1=count added nsc, cnt2=count of pending
S (IBCNT,IBCNT1,IBCNT2)=0
S (IBDTS,IBDT)=IBTSBDT-.0001
;
; loop twice, once for shipmnet date (new search), and once for
; delivery date (old search) for backward compatibility.
F S IBDT=$O(^RMPR(660,"AF",IBDT)) Q:'IBDT!(IBDT>IBTSEDT) D
.; Do NOT PROCESS on VistA if IBDT>=Switch Eff Date ;CCR-930
.I +IBSWINFO,(IBDT+1)>$P(IBSWINFO,"^",2) Q ;IB*2.0*312
.S IBDA=0 F S IBDA=$O(^RMPR(660,"AF",IBDT,IBDA)) Q:'IBDA D PRCHK
;
; reset date and do old check
S IBDT=IBDTS
F S IBDT=$O(^RMPR(660,"CT",IBDT)) Q:'IBDT!(IBDT>IBTSEDT) D
.; Do NOT PROCESS on VistA if IBDT>=Switch Eff Date ;CCR-930
.I +IBSWINFO,(IBDT+1)>$P(IBSWINFO,"^",2) Q ;IB*2.0*312
.S IBDA="" F S IBDA=$O(^RMPR(660,"CT",IBDT,IBDA)) Q:'IBDA D PRCHK
;
I $G(IBTALK) D BULL ;^IBTRKR51
EN1Q I $D(ZTQUEUED) S ZTREQ="@"
Q
;
PRCHK ; -- check and add item
N IBE,IBP,IBDX,IBRMARK,IBARR,IBT,IBINS
S IBCNT=IBCNT+1,IBRMARK=""
I '$D(ZTQUEUED),($G(IBTALK)) W "."
;
S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA=""
S DFN=$P(IBDATA,"^",2) Q:'DFN
; quit if non billable PSAS HCPCS code is found
I $$IBPHP(IBDA) Q
D CL^SDCO21(DFN,IBDT,"",.IBARR)
;
; -- checks copied from rmprbil v2.0 /feb 2, 1994
Q:'$D(^RMPR(660,+IBDA,"AM"))
Q:$P(^RMPR(660,+IBDA,0),U,9)=""!($P(^(0),U,12)="")!($P(^(0),U,14)="V")!($P(^(0),U,2)="")!($P(^(0),U,15)="*")
;Q:($P(^RMPR(660,+IBDA,"AM"),U,3)=2)!($P(^("AM"),U,3)=3)
;
;
I $O(^IBT(356,"APRO",IBDA,0)) G PRCHKQ ; already in claims tracking
;
; -- see if tracking only insured and pt is insured
I $P(IBTRKR,"^",5)=1,'$$INSURED^IBCNS1(DFN,IBDT) G PRCHKQ ; patient not insured
;
; -- if clasifications required, check exemptions
;IB*2.0*568
N IBSC,SCP,SCR,SUB
S SCR=0
I '$D(IBARR) G CLQ
F IBP=1:1:4 S IBDX(IBP)=$G(^RMPR(660,+IBDA,"BA"_IBP)) D
.S SCR=0 F SCP=2:1:8 Q:SCR=1 I $P(IBDX(IBP),U,SCP)[1 S IBSC(IBP)=SCP,SCR=1
I 'SCR S IBRMARK="NEEDS SC DETERMINATION" G CLQ ; no ICD node in RMPR, use old method of determining status
S IBRMARK=""
S IBE=0 F S IBE=$O(IBARR(IBE)) Q:'IBE D Q:($L($G(IBRMARK)))
.F IBP=1:1:4 Q:$L($G(IBRMARK)) D
..S (SUB,REC)="" I IBSC(IBP) S SUB="CL"_IBSC(IBP),REC=$T(@SUB)
..S IBRMARK=$S(REC'="":$P(REC,";",3),1:"NEEDS SC DETERMINATION")
;
;
CLQ ; -- ok to add to tracking module
S PROCOV=0,SCR=+$G(SCR)
S PROCOV=+$$PTCOV^IBCNSU3(DFN,IBDT,"PROSTHETICS")
I 'PROCOV,IBRMARK="NEEDS SC DETERMINATION" S IBRMARK="NO PROSTHETIC COVERAGE"
I 'PROCOV,IBRMARK="" S IBRMARK="NO PROSTHETIC COVERAGE"
D PRO^IBTUTL1(DFN,IBDT,IBDA,$G(IBRMARK)) I '$D(ZTQUEUED),$G(IBTALK) W "+"
I SCR=1 S IBCNT2=IBCNT2+1
I SCR=0 S IBCNT1=IBCNT1+1
K VAEL,VA,IBDATA,DFN,X,Y
PRCHKQ Q
;
IBPHP(IBDA) ; non billable PSAS HCPCS codes
; input-patient item in #660
; output-value if the code with the first 2 chars in the string is found
N IBPSAS,IBPIN S IBPIN=""
S IBPSAS=",BA,DI,DL,EC,EV,FE,HI,HN,HS,NR,RE,SB,SI,TH,TM,TR,VA,"
; return the pointer^description^the code (#661.1,.01)
S IBPIN=$$PIN^IBATUTL(+IBDA)
S IBPIN=$P(IBPIN,U,3)
S IBPIN=$F(IBPSAS,","_$E(IBPIN,1,2)_",")
Q IBPIN
;
BULL ; -- send bulletin
;
S XMSUB="Prosthetic Items added to Claims Tracking Complete"
S IBT(1)="The process to automatically add Prosthetic Items has successfully completed."
S IBT(1.1)=""
S IBT(2)=" Start Date: "_$$DAT1^IBOUTL(IBTSBDT)
S IBT(3)=" End Date: "_$$DAT1^IBOUTL(IBTSEDT)
I $D(IBMESS) S IBT(3.1)=IBMESS
S IBT(4)=""
S IBT(5)=" Total Prosthetics Items checked: "_$G(IBCNT)
S IBT(6)="Total NSC Prosthetic Items Added: "_$G(IBCNT1)
S IBT(7)=" Total SC Prosthetic Items Added: "_$G(IBCNT2)
S IBT(8)=""
S IBT(9)="*The items added as SC require determination and editing to be billed"
D SEND^IBTRKR31
BULLQ Q
;
CLTXT ; classification text for reason not billable
CL2 ;;AGENT ORANGE
CL3 ;;IONIZING RADIATION
CL4 ;;SC TREATMENT
CL5 ;;SOUTHWEST ASIA
CL6 ;;MILITARY SEXUAL TRAUMA
CL7 ;;HEAD/NECK CANCER
CL8 ;;COMBAT VETERAN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTRKR5 6791 printed Dec 13, 2024@02:28:42 Page 2
IBTRKR5 ;ALB/AAS - CLAIMS TRACKING - ADD/TRACK PROSTHETICS ;13-JAN-94
+1 ;;2.0;INTEGRATED BILLING;**13,260,312,339,389,474,498,568**;21-MAR-94;Build 40
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
% ; -- entry point for nightly background job
+1 NEW IBTSBDT,IBTSEDT
+2 ;IB*2.0*568
SET IBTSBDT=$$FMADD^XLFDT(DT,$SELECT($EXTRACT(DT,6,7)=10:-730,1:-20))-.1
+3 SET IBTSEDT=$$FMADD^XLFDT(DT,-3)+.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
+3 SET IBTALK=1
+4 IF '$PIECE($GET(^IBE(350.9,1,6)),"^",4)
WRITE !!,"I'm sorry, Tracking of Prosthetics is currently turned off."
GOTO ENQ
+5 WRITE !!!,"Select the Date Range of Prosthetics 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 ; -- check selected dates ;IB*2.0*312
+11 ; Do NOT PROCESS on VistA if Start or End>=Switch Eff Dt ;CCR-930
+12 IF +IBSWINFO
IF ((IBTSBDT+1)>$PIECE(IBSWINFO,"^",2))!((IBTSEDT+1)>$PIECE(IBSWINFO,"^",2))
Begin DoDot:1
+13 WRITE !!,"The Begin OR End Date CANNOT be on or after the PFSS Effective date"
+14 WRITE ": ",$$FMTE^XLFDT($PIECE(IBSWINFO,"^",2))
End DoDot:1
GOTO EN
+15 ;
+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 !!,"This should be queued to run after hours"
+23 WRITE !!!,"I'm going to automatically queue this off and send you a"
+24 WRITE !,"mail message when complete.",!
+25 SET ZTIO=""
SET ZTRTN="EN1^IBTRKR5"
SET ZTSAVE("IB*")=""
SET ZTDESC="IB - Add Prosthetics to Claims Tracking"
+26 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 prostethics to claims tracking file
+1 NEW I,J,X,Y,IBTRKR,IBDT,DFN,IBDATA,IBCNT,IBCNT1,IBCNT2,IBDTS,PROCOV
+2 ;IB*2.0*312
NEW IBSWINFO
SET IBSWINFO=$$SWSTAT^IBBAPI()
+3 ;
+4 ; -- check parameters
+5 SET IBTRKR=$GET(^IBE(350.9,1,6))
+6 ; quit if prothetics tracking off
if '$PIECE(IBTRKR,"^",5)
GOTO EN1Q
+7 ; start date can't be before parameters
IF +IBTRKR
IF IBTSBDT<+IBTRKR
SET IBTSBDT=IBTRKR
+8 ;
+9 ; -- users can queue into future, make sure dates not after date run
+10 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)
+11 ;
+12 ;S IBPRTYP=$O(^IBE(356.6,"AC",3,0)) ; this is the event type pointer for prosthetics
+13 ;
+14 ; -- cnt= total count, cnt1=count added nsc, cnt2=count of pending
+15 SET (IBCNT,IBCNT1,IBCNT2)=0
+16 SET (IBDTS,IBDT)=IBTSBDT-.0001
+17 ;
+18 ; loop twice, once for shipmnet date (new search), and once for
+19 ; delivery date (old search) for backward compatibility.
+20 FOR
SET IBDT=$ORDER(^RMPR(660,"AF",IBDT))
if 'IBDT!(IBDT>IBTSEDT)
QUIT
Begin DoDot:1
+21 ; Do NOT PROCESS on VistA if IBDT>=Switch Eff Date ;CCR-930
+22 ;IB*2.0*312
IF +IBSWINFO
IF (IBDT+1)>$PIECE(IBSWINFO,"^",2)
QUIT
+23 SET IBDA=0
FOR
SET IBDA=$ORDER(^RMPR(660,"AF",IBDT,IBDA))
if 'IBDA
QUIT
DO PRCHK
End DoDot:1
+24 ;
+25 ; reset date and do old check
+26 SET IBDT=IBDTS
+27 FOR
SET IBDT=$ORDER(^RMPR(660,"CT",IBDT))
if 'IBDT!(IBDT>IBTSEDT)
QUIT
Begin DoDot:1
+28 ; Do NOT PROCESS on VistA if IBDT>=Switch Eff Date ;CCR-930
+29 ;IB*2.0*312
IF +IBSWINFO
IF (IBDT+1)>$PIECE(IBSWINFO,"^",2)
QUIT
+30 SET IBDA=""
FOR
SET IBDA=$ORDER(^RMPR(660,"CT",IBDT,IBDA))
if 'IBDA
QUIT
DO PRCHK
End DoDot:1
+31 ;
+32 ;^IBTRKR51
IF $GET(IBTALK)
DO BULL
EN1Q IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 QUIT
+2 ;
PRCHK ; -- check and add item
+1 NEW IBE,IBP,IBDX,IBRMARK,IBARR,IBT,IBINS
+2 SET IBCNT=IBCNT+1
SET IBRMARK=""
+3 IF '$DATA(ZTQUEUED)
IF ($GET(IBTALK))
WRITE "."
+4 ;
+5 SET IBDATA=$GET(^RMPR(660,+IBDA,0))
if IBDATA=""
QUIT
+6 SET DFN=$PIECE(IBDATA,"^",2)
if 'DFN
QUIT
+7 ; quit if non billable PSAS HCPCS code is found
+8 IF $$IBPHP(IBDA)
QUIT
+9 DO CL^SDCO21(DFN,IBDT,"",.IBARR)
+10 ;
+11 ; -- checks copied from rmprbil v2.0 /feb 2, 1994
+12 if '$DATA(^RMPR(660,+IBDA,"AM"))
QUIT
+13 if $PIECE(^RMPR(660,+IBDA,0),U,9)=""!($PIECE(^(0),U,12)="")!($PIECE(^(0),U,14)="V")!($PIECE(^(0),U,2)="")!($PIECE(^(0),U,15)="*")
QUIT
+14 ;Q:($P(^RMPR(660,+IBDA,"AM"),U,3)=2)!($P(^("AM"),U,3)=3)
+15 ;
+16 ;
+17 ; already in claims tracking
IF $ORDER(^IBT(356,"APRO",IBDA,0))
GOTO PRCHKQ
+18 ;
+19 ; -- see if tracking only insured and pt is insured
+20 ; patient not insured
IF $PIECE(IBTRKR,"^",5)=1
IF '$$INSURED^IBCNS1(DFN,IBDT)
GOTO PRCHKQ
+21 ;
+22 ; -- if clasifications required, check exemptions
+23 ;IB*2.0*568
+24 NEW IBSC,SCP,SCR,SUB
+25 SET SCR=0
+26 IF '$DATA(IBARR)
GOTO CLQ
+27 FOR IBP=1:1:4
SET IBDX(IBP)=$GET(^RMPR(660,+IBDA,"BA"_IBP))
Begin DoDot:1
+28 SET SCR=0
FOR SCP=2:1:8
if SCR=1
QUIT
IF $PIECE(IBDX(IBP),U,SCP)[1
SET IBSC(IBP)=SCP
SET SCR=1
End DoDot:1
+29 ; no ICD node in RMPR, use old method of determining status
IF 'SCR
SET IBRMARK="NEEDS SC DETERMINATION"
GOTO CLQ
+30 SET IBRMARK=""
+31 SET IBE=0
FOR
SET IBE=$ORDER(IBARR(IBE))
if 'IBE
QUIT
Begin DoDot:1
+32 FOR IBP=1:1:4
if $LENGTH($GET(IBRMARK))
QUIT
Begin DoDot:2
+33 SET (SUB,REC)=""
IF IBSC(IBP)
SET SUB="CL"_IBSC(IBP)
SET REC=$TEXT(@SUB)
+34 SET IBRMARK=$SELECT(REC'="":$PIECE(REC,";",3),1:"NEEDS SC DETERMINATION")
End DoDot:2
End DoDot:1
if ($LENGTH($GET(IBRMARK)))
QUIT
+35 ;
+36 ;
CLQ ; -- ok to add to tracking module
+1 SET PROCOV=0
SET SCR=+$GET(SCR)
+2 SET PROCOV=+$$PTCOV^IBCNSU3(DFN,IBDT,"PROSTHETICS")
+3 IF 'PROCOV
IF IBRMARK="NEEDS SC DETERMINATION"
SET IBRMARK="NO PROSTHETIC COVERAGE"
+4 IF 'PROCOV
IF IBRMARK=""
SET IBRMARK="NO PROSTHETIC COVERAGE"
+5 DO PRO^IBTUTL1(DFN,IBDT,IBDA,$GET(IBRMARK))
IF '$DATA(ZTQUEUED)
IF $GET(IBTALK)
WRITE "+"
+6 IF SCR=1
SET IBCNT2=IBCNT2+1
+7 IF SCR=0
SET IBCNT1=IBCNT1+1
+8 KILL VAEL,VA,IBDATA,DFN,X,Y
PRCHKQ QUIT
+1 ;
IBPHP(IBDA) ; non billable PSAS HCPCS codes
+1 ; input-patient item in #660
+2 ; output-value if the code with the first 2 chars in the string is found
+3 NEW IBPSAS,IBPIN
SET IBPIN=""
+4 SET IBPSAS=",BA,DI,DL,EC,EV,FE,HI,HN,HS,NR,RE,SB,SI,TH,TM,TR,VA,"
+5 ; return the pointer^description^the code (#661.1,.01)
+6 SET IBPIN=$$PIN^IBATUTL(+IBDA)
+7 SET IBPIN=$PIECE(IBPIN,U,3)
+8 SET IBPIN=$FIND(IBPSAS,","_$EXTRACT(IBPIN,1,2)_",")
+9 QUIT IBPIN
+10 ;
BULL ; -- send bulletin
+1 ;
+2 SET XMSUB="Prosthetic Items added to Claims Tracking Complete"
+3 SET IBT(1)="The process to automatically add Prosthetic Items has successfully completed."
+4 SET IBT(1.1)=""
+5 SET IBT(2)=" Start Date: "_$$DAT1^IBOUTL(IBTSBDT)
+6 SET IBT(3)=" End Date: "_$$DAT1^IBOUTL(IBTSEDT)
+7 IF $DATA(IBMESS)
SET IBT(3.1)=IBMESS
+8 SET IBT(4)=""
+9 SET IBT(5)=" Total Prosthetics Items checked: "_$GET(IBCNT)
+10 SET IBT(6)="Total NSC Prosthetic Items Added: "_$GET(IBCNT1)
+11 SET IBT(7)=" Total SC Prosthetic Items Added: "_$GET(IBCNT2)
+12 SET IBT(8)=""
+13 SET IBT(9)="*The items added as SC require determination and editing to be billed"
+14 DO SEND^IBTRKR31
BULLQ QUIT
+1 ;
CLTXT ; classification text for reason not billable
CL2 ;;AGENT ORANGE
CL3 ;;IONIZING RADIATION
CL4 ;;SC TREATMENT
CL5 ;;SOUTHWEST ASIA
CL6 ;;MILITARY SEXUAL TRAUMA
CL7 ;;HEAD/NECK CANCER
CL8 ;;COMBAT VETERAN
