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

IBTUTL3.m

Go to the documentation of this file. 
  1. IBTUTL3 ;ALB/AAS - CLAIMS TRACKING UTILITY ROUTINE ; 21-JUN-93
  1.  ;;Version 2.0 ; INTEGRATED BILLING ;**32**; 21-MAR-94
  1.  ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1. ADDC(IBTRCDT,IBTRN) ; -- add new entry to reviews file, ibt(356.1
  1.  ; -- Input  IBTRVDT :=  Review date (in internal fileman format)
  1.  ;             IBTRN :=  pointer to tracking module
  1.  ;
  1.  N %DT,DD,DO,DIC,DR,DIE,DLAYGO
  1.  S DIC="^IBT(356.2,",DIC(0)="L",DLAYGO=356.2
  1.  S DIC("DR")=".19////1;.02////"_$G(IBTRN)
  1.  S X=IBTRCDT D FILE^DICN
  1.  S IBTRC=+Y,IBNEW=1
  1. ADDCQ Q
  1.  ;
  1. COM(IBTRCDT,IBTRN,IBX,IBTRV) ; -- add initial communication entry
  1.  ; -- Input  IBTRCDT :=  Communication date (in internal fileman format)
  1.  ;             IBTRN :=  pointer to tracking module
  1.  ;               IBX :=  code for type of contact (if null, will compute)
  1.  ;             IBTRV :=  pointer to initial review (if it exists)
  1.  ;
  1.  N X,Y,DA,DR,DIE,DIC,IBXIFN,IBNXRV
  1.  D ADDC(IBTRCDT,$G(IBTRN))
  1.  ;
  1.  I $G(IBX) S IBXIFN=$O(^IBE(356.11,"ACODE",+IBX,0))
  1.  I '$G(IBXIFN) S IBXIFN=$O(^IBE(356.11,"B",$$TYPE^IBTRC(+$G(IBTRC)),0))
  1.  ;
  1.  S DA=IBTRC,DIE="^IBT(356.2,"
  1.  S IBNXRV=DT
  1.  I IBTRCDT>$$FMADD^XLFDT(DT,7) S IBNXRV=$$FMADD^XLFDT(IBTRCDT,-7)
  1.  L +^IBT(356.2,+IBTRC):10 I '$T G COMQ
  1.  S DR=".03////"_$G(IBTRV)_";.04////"_IBXIFN_";.05////"_DFN_";.24////"_IBNXRV_";1.01///NOW;1.02////"_DUZ
  1.  D ^DIE K DA,DR,DIE
  1.  L -^IBT(356.2,+IBTRC)
  1. COMQ Q
  1.  ;
  1. DAY(X,X1,IBTRN) ; -- compute number of days approved for tracking id
  1.  ; -- if same date, difference = 1
  1.  ; -- input x  = beginning date (required)
  1.  ;          x1 = ending date (required)
  1.  ;       ibtrn = (optional) if defined will compute max days for episode
  1.  ;               and will not count discharge date
  1.  N DIFF,IBCDT,IBBET,IBEND,IBMAX S DIFF=0
  1.  I $E(X,1,7)'?7N G DAYQ
  1.  I 'X1 S DIFF=1 G DAYQ
  1.  I $E(X1,1,7)'?7N G DAYQ
  1.  I X,$E(X,1,7)=$E(X1,1,7) S DIFF=1 G DAYQ
  1.  I $G(IBTRN),$P($G(^IBT(356,+IBTRN,0)),"^",5) D
  1.  .S IBCDT=$$CDT^IBTODD1(IBTRN)
  1.  .; patch 32 changed I 'IBEND
  1.  .S IBBEG=+IBCDT,IBEND=+$P(IBCDT,"^",2)\1 I 'IBEND S IBEND=DT
  1.  .S IBMAX=$$FMDIFF^XLFDT(IBEND,IBBEG)
  1.  .;I X1>IBEND S X1=IBEND
  1.  .;I X<IBBEG S X=IBBEG
  1.  S DIFF=$$FMDIFF^XLFDT(X1,X) I $G(IBCDT),$G(IBTRN) I $S('$P(IBCDT,"^",2):1,X1<($P(IBCDT,"^",2)\1):1,1:0) S DIFF=DIFF+1 ;add one if not include discharge date
  1.  I $G(IBMAX),$P($G(IBCDT),"^",2),DIFF>IBMAX S DIFF=IBMAX
  1. DAYQ Q DIFF
  1.  ;
  1. SCP(DFN) ; -- is patient sc, and percent
  1.  N VAEL D ELIG^VADPT
  1.  I '$G(VAEL(3)) S Y="NO"
  1.  I $G(VAEL(3)) S Y=$P(VAEL(3),"^",2)_"%"
  1.  Q Y
  1.  ;
  1. OTB(DFN) ; -- did patient ever have other type of bill
  1.  N I,J,Y S Y=""
  1.  I '$O(^IBT(356,"ASPC",DFN,0)) G OTBQ
  1.  S I=""
  1.  F  S I=$O(^IBT(356,"ASPC",DFN,I)) Q:'I  D  ;S J="" F  S J=$O(^IBT(356,"ASPC",DFN,I,J)) Q:'J
  1.  .S:Y'="" Y=Y_", "
  1.  .S Y=$S(I=1:"TORT",I=2:"OWCP",I=3:"WORK COMP.",1:"OTHER")
  1.  .; -- later add ability to find bills, dates, etc
  1. OTBQ Q Y
  1.  ;
  1. MSG(DFN) ; -- set message for display in lower bar
  1.  N Y,IBSCP,IBOTB S Y=""
  1.  S IBSCP=$$SCP(DFN),IBOTB=$$OTB(DFN)
  1.  S Y="Service Connected: "_IBSCP
  1.  I IBOTB'="" S Y=Y_"   Previous Spec. Bills: "_IBOTB
  1. MSGQ Q Y
  1.  ;
  1. ARRAY(IBTRC) ; -- see if other reviews have dates
  1.  ;
  1.  I '$G(IBTRC) G ARRAYQ
  1.  N I,IBTRN K ARRAY
  1.  S IBTRN=$P($G(^IBT(356.2,+IBTRC,0)),"^",2) G:'IBTRN ARRAYQ
  1.  S IBCNS=$P($G(^IBT(356.2,+IBTRC,0)),"^",8)
  1.  S I=0 F  S I=$O(^IBT(356.2,"C",IBTRN,I)) Q:'I  D
  1.  .Q:$P(^IBT(356.2,+I,0),"^",8)'=IBCNS  ; must be same ins. co.
  1.  .I $P($G(^IBT(356.2,+I,1)),"^",8) S ARRAY=I Q  ; whole admission authorized
  1.  .I $P($G(^IBT(356.2,+I,1)),"^",7) S ARRAY(0)=I Q  ;whole admission denied
  1.  .I $P($G(^IBT(356.2,+I,0)),"^",12) S ARRAY(+$P(^IBT(356.2,+I,0),"^",12),+$P(^IBT(356.2,+I,0),"^",13))=I_"^"_1
  1.  .I $P($G(^IBT(356.2,+I,0)),"^",15) S ARRAY(+$P(^IBT(356.2,+I,0),"^",15),+$P(^IBT(356.2,+I,0),"^",16))=I_"^"_2
  1. ARRAYQ Q
  1.  ;
  1. HELP(IBTRC) ; -- dd help for dates authorized and denied.
  1.  ;
  1.  N ARRAY,IBCNS D ARRAY(IBTRC)
  1.  D WRITE
  1.  Q
  1.  ;
  1. WRITE ; -- write extended help
  1.  ;
  1.  Q:$D(ZTQUEUED)
  1.  N M,N,X W !
  1.  I '$D(ARRAY) W !,"No Authorized or Denied Days on file for this Visit!",!! Q
  1.  ;
  1.  W !,"For Insurance Company ",$P($G(^DIC(36,+IBCNS,0)),"^"),": "
  1.  I $G(ARRAY) W !,"Care Authorized for entire Admission on ",$$FMTE^XLFDT(+$G(^IBT(356.2,+ARRAY,0))),"."
  1.  I $G(ARRAY(0)) W !,"Care Denied for entire Admission on ",$$FMTE^XLFDT(+$G(^IBT(356.2,+ARRAY(0),0))),"."
  1.  ;
  1.  S M=0 F  S M=$O(ARRAY(M)) Q:'M  S N="" F  S N=$O(ARRAY(M,N)) Q:N=""  D
  1.  .W !,"Care ",$S($P(ARRAY(M,N),"^",2)=1:"Authorized",1:"Denied    "),"  from ",$$FMTE^XLFDT(M),"  to  ",$S('N:"Unspecified",1:$$FMTE^XLFDT(N))
  1.  .W ?57," on ",$$FMTE^XLFDT(+$G(^IBT(356.2,+ARRAY(M,N),0))),"."
  1.  W ! Q