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

IBTRKR5.m

Go to the documentation of this file. 
  1. 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
  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,$S($E(DT,6,7)=10:-730,1:-20))-.1  ;IB*2.0*568
  1.  S IBTSEDT=$$FMADD^XLFDT(DT,-3)+.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
  1.  S IBTALK=1
  1.  I '$P($G(^IBE(350.9,1,6)),"^",4) W !!,"I'm sorry, Tracking of Prosthetics is currently turned off." G ENQ
  1.  W !!!,"Select the Date Range of Prosthetics 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.  ; -- check selected dates                                 ;IB*2.0*312
  1.  ; Do NOT PROCESS on VistA if Start or End>=Switch Eff Dt  ;CCR-930
  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 the PFSS Effective date"
  1.   .W ": ",$$FMTE^XLFDT($P(IBSWINFO,"^",2))
  1.  ;
  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 !!,"This should be queued to run after hours"
  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^IBTRKR5",ZTSAVE("IB*")="",ZTDESC="IB - Add Prosthetics 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 prostethics to claims tracking file
  1.  N I,J,X,Y,IBTRKR,IBDT,DFN,IBDATA,IBCNT,IBCNT1,IBCNT2,IBDTS,PROCOV
  1.  N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI()                   ;IB*2.0*312
  1.  ;
  1.  ; -- check parameters
  1.  S IBTRKR=$G(^IBE(350.9,1,6))
  1.  G:'$P(IBTRKR,"^",5) EN1Q ; quit if prothetics 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 IBPRTYP=$O(^IBE(356.6,"AC",3,0)) ; this is the event type pointer for prosthetics
  1.  ;
  1.  ; -- cnt= total count, cnt1=count added nsc, cnt2=count of pending
  1.  S (IBCNT,IBCNT1,IBCNT2)=0
  1.  S (IBDTS,IBDT)=IBTSBDT-.0001
  1.  ;
  1.  ; loop twice, once for shipmnet date (new search), and once for
  1.  ; delivery date (old search) for backward compatibility.
  1.  F  S IBDT=$O(^RMPR(660,"AF",IBDT)) Q:'IBDT!(IBDT>IBTSEDT)  D
  1.     .; Do NOT PROCESS on VistA if IBDT>=Switch Eff Date    ;CCR-930
  1.     .I +IBSWINFO,(IBDT+1)>$P(IBSWINFO,"^",2) Q             ;IB*2.0*312
  1.     .S IBDA=0 F  S IBDA=$O(^RMPR(660,"AF",IBDT,IBDA)) Q:'IBDA  D PRCHK
  1.  ;
  1.  ; reset date and do old check
  1.  S IBDT=IBDTS
  1.  F  S IBDT=$O(^RMPR(660,"CT",IBDT)) Q:'IBDT!(IBDT>IBTSEDT)  D
  1.     .; Do NOT PROCESS on VistA if IBDT>=Switch Eff Date    ;CCR-930
  1.     .I +IBSWINFO,(IBDT+1)>$P(IBSWINFO,"^",2) Q             ;IB*2.0*312
  1.     .S IBDA="" F  S IBDA=$O(^RMPR(660,"CT",IBDT,IBDA)) Q:'IBDA  D PRCHK
  1.  ;
  1.  I $G(IBTALK) D BULL ;^IBTRKR51
  1. EN1Q I $D(ZTQUEUED) S ZTREQ="@"
  1.  Q
  1.  ;
  1. PRCHK ; -- check and add item
  1.  N IBE,IBP,IBDX,IBRMARK,IBARR,IBT,IBINS
  1.  S IBCNT=IBCNT+1,IBRMARK=""
  1.  I '$D(ZTQUEUED),($G(IBTALK)) W "."
  1.  ;
  1.  S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA=""
  1.  S DFN=$P(IBDATA,"^",2) Q:'DFN
  1.  ; quit if non billable PSAS HCPCS code is found
  1.  I $$IBPHP(IBDA) Q
  1.  D CL^SDCO21(DFN,IBDT,"",.IBARR)
  1.  ;
  1.  ; -- checks copied from rmprbil v2.0 /feb 2, 1994
  1.  Q:'$D(^RMPR(660,+IBDA,"AM"))
  1.  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)="*")
  1.  ;Q:($P(^RMPR(660,+IBDA,"AM"),U,3)=2)!($P(^("AM"),U,3)=3)
  1.  ;
  1.  ;
  1.  I $O(^IBT(356,"APRO",IBDA,0)) G PRCHKQ ; already in claims tracking
  1.  ;
  1.  ; -- see if tracking only insured and pt is insured
  1.  I $P(IBTRKR,"^",5)=1,'$$INSURED^IBCNS1(DFN,IBDT) G PRCHKQ ; patient not insured
  1.  ;
  1.  ; -- if clasifications required, check exemptions
  1.  ;IB*2.0*568
  1.  N IBSC,SCP,SCR,SUB
  1.  S SCR=0
  1.  I '$D(IBARR) G CLQ
  1.  F IBP=1:1:4 S IBDX(IBP)=$G(^RMPR(660,+IBDA,"BA"_IBP)) D
  1.  .S SCR=0 F SCP=2:1:8 Q:SCR=1  I $P(IBDX(IBP),U,SCP)[1 S IBSC(IBP)=SCP,SCR=1
  1.  I 'SCR S IBRMARK="NEEDS SC DETERMINATION" G CLQ ; no ICD node in RMPR, use old method of determining status
  1.  S IBRMARK=""
  1.  S IBE=0 F  S IBE=$O(IBARR(IBE)) Q:'IBE  D  Q:($L($G(IBRMARK)))
  1.  .F IBP=1:1:4 Q:$L($G(IBRMARK))  D
  1.  ..S (SUB,REC)="" I IBSC(IBP) S SUB="CL"_IBSC(IBP),REC=$T(@SUB)
  1.  ..S IBRMARK=$S(REC'="":$P(REC,";",3),1:"NEEDS SC DETERMINATION")
  1.  ;
  1.  ;
  1. CLQ ; -- ok to add to tracking module
  1.  S PROCOV=0,SCR=+$G(SCR)
  1.  S PROCOV=+$$PTCOV^IBCNSU3(DFN,IBDT,"PROSTHETICS")
  1.  I 'PROCOV,IBRMARK="NEEDS SC DETERMINATION" S IBRMARK="NO PROSTHETIC COVERAGE"
  1.  I 'PROCOV,IBRMARK="" S IBRMARK="NO PROSTHETIC COVERAGE"
  1.  D PRO^IBTUTL1(DFN,IBDT,IBDA,$G(IBRMARK)) I '$D(ZTQUEUED),$G(IBTALK) W "+"
  1.  I SCR=1 S IBCNT2=IBCNT2+1
  1.  I SCR=0 S IBCNT1=IBCNT1+1
  1.  K VAEL,VA,IBDATA,DFN,X,Y
  1. PRCHKQ Q
  1.  ;
  1. IBPHP(IBDA) ; non billable PSAS HCPCS codes
  1.  ; input-patient item in #660
  1.  ; output-value if the code with the first 2 chars in the string is found
  1.  N IBPSAS,IBPIN S IBPIN=""
  1.  S IBPSAS=",BA,DI,DL,EC,EV,FE,HI,HN,HS,NR,RE,SB,SI,TH,TM,TR,VA,"
  1.  ; return the pointer^description^the code (#661.1,.01)
  1.  S IBPIN=$$PIN^IBATUTL(+IBDA)
  1.  S IBPIN=$P(IBPIN,U,3)
  1.  S IBPIN=$F(IBPSAS,","_$E(IBPIN,1,2)_",")
  1.  Q IBPIN
  1.  ;
  1. BULL ; -- send bulletin
  1.  ;
  1.  S XMSUB="Prosthetic Items added to Claims Tracking Complete"
  1.  S IBT(1)="The process to automatically add Prosthetic Items has successfully completed."
  1.  S IBT(1.1)=""
  1.  S IBT(2)="                      Start Date: "_$$DAT1^IBOUTL(IBTSBDT)
  1.  S IBT(3)="                        End Date: "_$$DAT1^IBOUTL(IBTSEDT)
  1.  I $D(IBMESS) S IBT(3.1)=IBMESS
  1.  S IBT(4)=""
  1.  S IBT(5)=" Total Prosthetics Items checked: "_$G(IBCNT)
  1.  S IBT(6)="Total NSC Prosthetic Items Added: "_$G(IBCNT1)
  1.  S IBT(7)=" Total SC Prosthetic Items Added: "_$G(IBCNT2)
  1.  S IBT(8)=""
  1.  S IBT(9)="*The items added as SC require determination and editing to be billed"
  1.  D SEND^IBTRKR31
  1. BULLQ Q
  1.  ;
  1. CLTXT ; classification text for reason not billable
  1. CL2 ;;AGENT ORANGE
  1. CL3 ;;IONIZING RADIATION
  1. CL4 ;;SC TREATMENT
  1. CL5 ;;SOUTHWEST ASIA
  1. CL6 ;;MILITARY SEXUAL TRAUMA
  1. CL7 ;;HEAD/NECK CANCER
  1. CL8 ;;COMBAT VETERAN