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