source: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTRKR5.m@ 636

IBTRKR5 ;ALB/AAS - CLAIMS TRACKING - ADD/TRACK PROSTHETICS ;13-JAN-94
 ;;2.0;INTEGRATED BILLING;**13,260,312,339**;21-MAR-94;Build 2
 ;;Per VHA Directive 2004-038, this routine should not be modified.
 ;
% ; -- entry point for nightly background job
 N IBTSBDT,IBTSEDT
 S IBTSBDT=$$FMADD^XLFDT(DT,-30)-.1
 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 !!!,"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
 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
 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)
 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,6)="")!($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 insure
 ;
 ; -- if clasifications required, check exemptions
 I '$D(IBARR) G CLQ
 S IBE=0 F IBP=1:1:4 S IBDX(IBP)=$G(^RMPR(660,+IBDA,"BA"_IBP)) I IBDX(IBP) S IBE=1
 I 'IBE S IBRMARK="NEEDS SC DETERMINATION" G CLQ ; no ICD node in RMPR, use old method of determining status
 S IBE=0 F  S IBE=$O(IBARR(IBE)) Q:'IBE!($L($G(IBRMARK)))  F IBP=1:1:4 Q:$L($G(IBRMARK))  I IBDX(IBP) S IBRMARK=$S($P(IBDX(IBP),"^",IBE+1):$P($T(CLTXT+IBE),";",3),$P(IBDX(IBP),"^",IBE+1)=0:"",1:"NEEDS SC DETERMINATION")
 ;
 ;
CLQ ; -- ok to add to tracking module
 D PRO^IBTUTL1(DFN,IBDT,IBDA,$G(IBRMARK)) I '$D(ZTQUEUED),$G(IBTALK) W "+"
 I $G(IBRMARK)'="" S IBCNT2=IBCNT2+1
 I $G(IBRMARK)="" S IBCNT1=IBCNT1+1
 K VAEL,VA,IBDATA,DFN,X,Y
PRCHKQ Q
 ;
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
 ;;AGENT ORANGE
 ;;IONIZING RADIATION
 ;;SC TREATMENT
 ;;SOUTHWEST ASIA
 ;;MILITARY SEXUAL TRAUMA
 ;;HEAD/NECK CANCER
 ;;COMBAT VETERAN