IBAECB1 ;WOIFO/AAT-LTC BILLING CLOCK INQUIRY ; 21-FEB-02
;;2.0;INTEGRATED BILLING;**171,176**;21-MAR-94
;; Per VHA Directive 10-93-142, this routine should not be modified
;
Q
;
; Printing the report to the current device
; Input:
; IBCLK - LTC Billing Clock IEN
; IOST,IOSL,IOF Must be defined
; Output: IBQUIT=1 if user entered "^"
REPORT ;Print the report to the current device
N IBZ,IBN4,IBDFN,IBPTZ,IBNAM,IBSSN,IBDOB,IBVET,IBFTN,IBTAB,IBDT1,IBDT2,IBSTA
N:'$D(IBQUIT) IBQUIT
S IBQUIT=0
;
; Define required data
;
S IBZ=$G(^IBA(351.81,IBCLK,0)) I IBZ="" W !,"Data not found..." Q
S IBDFN=+$P(IBZ,U,2) I 'IBDFN W !,"No patient data..." Q
S IBPTZ=$G(^DPT(IBDFN,0)) I IBPTZ="" W !,"Patient data not found... (",IBDFN,")" Q
S IBN4=$G(^IBA(351.81,IBCLK,4)) ; Node 4
S IBNAM=$P(IBPTZ,U) ; Patient name
S IBSSN=$P(IBPTZ,U,9) ; Patient SSN
S IBDOB=$P(IBPTZ,U,3) ; Patient DOB
S IBVET=+$P($G(^DPT(IBDFN,"TYPE")),U,1) ; Veteran type code
S IBVET=$S(IBVET:$P($G(^DG(391,IBVET,0)),U),1:"") ; Veteran type name
; Write caption
W IBNAM,?32," ",$$SSN(IBSSN),?48," ",$$DAT1(IBDOB),?62,IBVET
W ! D LINE("=",80)
;
; The body of report
S IBFTN=$P(IBZ,U)
;; W !,$$FRM("Facility Clock Number"),IBFTN
S IBSTA=$P(IBZ,U,5)
I 0 W !,$$FRM("LTC Copay Clock Status"),$$EXTERNAL^DILFD(351.81,.05,"",IBSTA)
W !,$$FRM("LTC Copay Clock Start Date"),$$DAT2($P(IBZ,U,3))
I 1 W ?56," Clock Status: ",$$EXTERNAL^DILFD(351.81,.05,"",IBSTA)
W !,$$FRM("LTC Copay Clock End Date "),$$DAT2($P(IBZ,U,4))
I '$$SCR() W !
;;W !,$$FRM("Current Events Date"),$S($P(IBZ,U,7):$$DAT2($P(IBZ,U,7)),1:"none")
;;I '$$SCR() W !
W !,$$FRM("Free Days Remaining"),+$P(IBZ,U,6)
I $O(^IBA(351.81,IBCLK,1,0)) ; Not used yet
D FRDAYS Q:IBQUIT
W ! D CHKPAUSE Q:IBQUIT
W !,$$FRM("User Added Entry "),$$PERS($P(IBN4,U,1)) D CHKPAUSE Q:IBQUIT
I 0 W !,$$FRM("Date Entry Added")
E W ?55
W $$DAT2($P(IBN4,U,2)) D CHKPAUSE Q:IBQUIT
W !,$$FRM("User Last Updated"),$$PERS($P(IBN4,U,3)) D CHKPAUSE Q:IBQUIT
I 0 W !,$$FRM("Date Last Updated")
E W ?55
W $$DAT2($P(IBN4,U,4))
Q
;
;
; Fotmatting row labels
FRM(IBLBL,IBCUT) ;
I $G(IBCUT,1) S IBLBL=$E(IBLBL,1,26)
Q " "_IBLBL_": " ;;;$J("",26-$L(IBLBL))_": "
;
SSN(IBSSN) I IBSSN?9N Q $E(IBSSN,1,3)_"-"_$E(IBSSN,4,5)_"-"_$E(IBSSN,6,9)
Q IBSSN
;
DAT1(IBDAT) ;FM -> External date, like 12/25/2000
Q $$FMTE^XLFDT(IBDAT,"5PMZ")
;
DAT2(IBDAT) ;FM -> External date, like OCT 25, 2001
Q $$FMTE^XLFDT(IBDAT,"1PMZ")
;
; Draw a line, of characters IBC, length IBN
LINE(IBC,IBN) N IBL
I $L($G(IBC))'=1 S IBC="="
I +$G(IBN)=0 S IBN=80
S $P(IBL,IBC,IBN+1)=""
W IBL
Q
; Person
PERS(IBIEN) ;
I '$G(IBIEN) Q ""
Q $P($G(^VA(200,IBIEN,0)),U)
;
; Input:
; IBCLK - LBC Billing Clock IEN
; IBQUIT - if defined, pauses will be made at the bottom of screen ("C-" devices only!)
; Output:
; IBQUIT=1 if user pressed "^". Only if IBQUIT was defined initially!
FRDAYS ; Write the list of exempt days
N IBZ,IBV,IBC,IBI,IBA,IBN
S IBZ=$G(^IBA(351.81,IBCLK,0)) I IBZ="" W !,"Corrupted record of LTC clock ",IBCLK Q
S IBC=0 ; Counter of free days
; Collect an array of free days:
S IBI=0 F S IBI=$O(^IBA(351.81,IBCLK,1,IBI)) Q:'IBI D:$P(^(IBI,0),U,2)
. S IBC=IBC+1
. S IBA(IBC)=$P(^IBA(351.81,IBCLK,1,IBI,0),U,2)
;I '$$SCR() W !,$$FRM("Days free of LTC copay")
;E
W !,$$FRM("Days Not Subject To LTC Copay",0)
I 'IBC W "none" Q
S IBV=IBC\3 I IBC#3 S IBV=IBV+1
F IBI=1:1:IBV D Q:$G(IBQUIT)
. D:$D(IBQUIT) CHKPAUSE
. S IBN=IBI W !?5,$J(IBN,2),?10,$$FMTE^XLFDT(IBA(IBN))
. S IBN=IBI+IBV I $G(IBA(IBN)) W ?30,$J(IBN,2),?35,$$FMTE^XLFDT(IBA(IBN))
. S IBN=IBI+(2*IBV) I $G(IBA(IBN)) W ?55,$J(IBN,2),?60,$$FMTE^XLFDT(IBA(IBN))
Q
;
PAUSE Q:'$$SCR() ;Screen only
N IBJ,DIR,DIRUT,DTOUT,DUOUT,DIROUT,Y,IOSL2
S IOSL2=$S(IOSL>24:24,1:IOSL)
F IBJ=$Y:1:(IOSL2-4) W !
S DIR(0)="E" D ^DIR K DIR I $G(DUOUT) S IBQUIT=1
Q
;
CHKPAUSE ;Check pause
I $Y>(IOSL-5) D PAUSE Q:IBQUIT W @IOF D LINE("-",80) W !
Q
;
SCR() Q $E(IOST,1,2)="C-" ; Screen
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAECB1 4115 printed Apr 09, 2024@21:10:40 Page 2
IBAECB1 ;WOIFO/AAT-LTC BILLING CLOCK INQUIRY ; 21-FEB-02
+1 ;;2.0;INTEGRATED BILLING;**171,176**;21-MAR-94
+2 ;; Per VHA Directive 10-93-142, this routine should not be modified
+3 ;
+4 QUIT
+5 ;
+6 ; Printing the report to the current device
+7 ; Input:
+8 ; IBCLK - LTC Billing Clock IEN
+9 ; IOST,IOSL,IOF Must be defined
+10 ; Output: IBQUIT=1 if user entered "^"
REPORT ;Print the report to the current device
+1 NEW IBZ,IBN4,IBDFN,IBPTZ,IBNAM,IBSSN,IBDOB,IBVET,IBFTN,IBTAB,IBDT1,IBDT2,IBSTA
+2 if '$DATA(IBQUIT)
NEW IBQUIT
+3 SET IBQUIT=0
+4 ;
+5 ; Define required data
+6 ;
+7 SET IBZ=$GET(^IBA(351.81,IBCLK,0))
IF IBZ=""
WRITE !,"Data not found..."
QUIT
+8 SET IBDFN=+$PIECE(IBZ,U,2)
IF 'IBDFN
WRITE !,"No patient data..."
QUIT
+9 SET IBPTZ=$GET(^DPT(IBDFN,0))
IF IBPTZ=""
WRITE !,"Patient data not found... (",IBDFN,")"
QUIT
+10 ; Node 4
SET IBN4=$GET(^IBA(351.81,IBCLK,4))
+11 ; Patient name
SET IBNAM=$PIECE(IBPTZ,U)
+12 ; Patient SSN
SET IBSSN=$PIECE(IBPTZ,U,9)
+13 ; Patient DOB
SET IBDOB=$PIECE(IBPTZ,U,3)
+14 ; Veteran type code
SET IBVET=+$PIECE($GET(^DPT(IBDFN,"TYPE")),U,1)
+15 ; Veteran type name
SET IBVET=$SELECT(IBVET:$PIECE($GET(^DG(391,IBVET,0)),U),1:"")
+16 ; Write caption
+17 WRITE IBNAM,?32," ",$$SSN(IBSSN),?48," ",$$DAT1(IBDOB),?62,IBVET
+18 WRITE !
DO LINE("=",80)
+19 ;
+20 ; The body of report
+21 SET IBFTN=$PIECE(IBZ,U)
+22 ;; W !,$$FRM("Facility Clock Number"),IBFTN
+23 SET IBSTA=$PIECE(IBZ,U,5)
+24 IF 0
WRITE !,$$FRM("LTC Copay Clock Status"),$$EXTERNAL^DILFD(351.81,.05,"",IBSTA)
+25 WRITE !,$$FRM("LTC Copay Clock Start Date"),$$DAT2($PIECE(IBZ,U,3))
+26 IF 1
WRITE ?56," Clock Status: ",$$EXTERNAL^DILFD(351.81,.05,"",IBSTA)
+27 WRITE !,$$FRM("LTC Copay Clock End Date "),$$DAT2($PIECE(IBZ,U,4))
+28 IF '$$SCR()
WRITE !
+29 ;;W !,$$FRM("Current Events Date"),$S($P(IBZ,U,7):$$DAT2($P(IBZ,U,7)),1:"none")
+30 ;;I '$$SCR() W !
+31 WRITE !,$$FRM("Free Days Remaining"),+$PIECE(IBZ,U,6)
+32 ; Not used yet
IF $ORDER(^IBA(351.81,IBCLK,1,0))
+33 DO FRDAYS
if IBQUIT
QUIT
+34 WRITE !
DO CHKPAUSE
if IBQUIT
QUIT
+35 WRITE !,$$FRM("User Added Entry "),$$PERS($PIECE(IBN4,U,1))
DO CHKPAUSE
if IBQUIT
QUIT
+36 IF 0
WRITE !,$$FRM("Date Entry Added")
+37 IF '$TEST
WRITE ?55
+38 WRITE $$DAT2($PIECE(IBN4,U,2))
DO CHKPAUSE
if IBQUIT
QUIT
+39 WRITE !,$$FRM("User Last Updated"),$$PERS($PIECE(IBN4,U,3))
DO CHKPAUSE
if IBQUIT
QUIT
+40 IF 0
WRITE !,$$FRM("Date Last Updated")
+41 IF '$TEST
WRITE ?55
+42 WRITE $$DAT2($PIECE(IBN4,U,4))
+43 QUIT
+44 ;
+45 ;
+46 ; Fotmatting row labels
FRM(IBLBL,IBCUT) ;
+1 IF $GET(IBCUT,1)
SET IBLBL=$EXTRACT(IBLBL,1,26)
+2 ;;;$J("",26-$L(IBLBL))_": "
QUIT " "_IBLBL_": "
+3 ;
SSN(IBSSN) IF IBSSN?9N
QUIT $EXTRACT(IBSSN,1,3)_"-"_$EXTRACT(IBSSN,4,5)_"-"_$EXTRACT(IBSSN,6,9)
+1 QUIT IBSSN
+2 ;
DAT1(IBDAT) ;FM -> External date, like 12/25/2000
+1 QUIT $$FMTE^XLFDT(IBDAT,"5PMZ")
+2 ;
DAT2(IBDAT) ;FM -> External date, like OCT 25, 2001
+1 QUIT $$FMTE^XLFDT(IBDAT,"1PMZ")
+2 ;
+3 ; Draw a line, of characters IBC, length IBN
LINE(IBC,IBN) NEW IBL
+1 IF $LENGTH($GET(IBC))'=1
SET IBC="="
+2 IF +$GET(IBN)=0
SET IBN=80
+3 SET $PIECE(IBL,IBC,IBN+1)=""
+4 WRITE IBL
+5 QUIT
+6 ; Person
PERS(IBIEN) ;
+1 IF '$GET(IBIEN)
QUIT ""
+2 QUIT $PIECE($GET(^VA(200,IBIEN,0)),U)
+3 ;
+4 ; Input:
+5 ; IBCLK - LBC Billing Clock IEN
+6 ; IBQUIT - if defined, pauses will be made at the bottom of screen ("C-" devices only!)
+7 ; Output:
+8 ; IBQUIT=1 if user pressed "^". Only if IBQUIT was defined initially!
FRDAYS ; Write the list of exempt days
+1 NEW IBZ,IBV,IBC,IBI,IBA,IBN
+2 SET IBZ=$GET(^IBA(351.81,IBCLK,0))
IF IBZ=""
WRITE !,"Corrupted record of LTC clock ",IBCLK
QUIT
+3 ; Counter of free days
SET IBC=0
+4 ; Collect an array of free days:
+5 SET IBI=0
FOR
SET IBI=$ORDER(^IBA(351.81,IBCLK,1,IBI))
if 'IBI
QUIT
if $PIECE(^(IBI,0),U,2)
Begin DoDot:1
+6 SET IBC=IBC+1
+7 SET IBA(IBC)=$PIECE(^IBA(351.81,IBCLK,1,IBI,0),U,2)
End DoDot:1
+8 ;I '$$SCR() W !,$$FRM("Days free of LTC copay")
+9 ;E
+10 WRITE !,$$FRM("Days Not Subject To LTC Copay",0)
+11 IF 'IBC
WRITE "none"
QUIT
+12 SET IBV=IBC\3
IF IBC#3
SET IBV=IBV+1
+13 FOR IBI=1:1:IBV
Begin DoDot:1
+14 if $DATA(IBQUIT)
DO CHKPAUSE
+15 SET IBN=IBI
WRITE !?5,$JUSTIFY(IBN,2),?10,$$FMTE^XLFDT(IBA(IBN))
+16 SET IBN=IBI+IBV
IF $GET(IBA(IBN))
WRITE ?30,$JUSTIFY(IBN,2),?35,$$FMTE^XLFDT(IBA(IBN))
+17 SET IBN=IBI+(2*IBV)
IF $GET(IBA(IBN))
WRITE ?55,$JUSTIFY(IBN,2),?60,$$FMTE^XLFDT(IBA(IBN))
End DoDot:1
if $GET(IBQUIT)
QUIT
+18 QUIT
+19 ;
PAUSE ;Screen only
if '$$SCR()
QUIT
+1 NEW IBJ,DIR,DIRUT,DTOUT,DUOUT,DIROUT,Y,IOSL2
+2 SET IOSL2=$SELECT(IOSL>24:24,1:IOSL)
+3 FOR IBJ=$Y:1:(IOSL2-4)
WRITE !
+4 SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $GET(DUOUT)
SET IBQUIT=1
+5 QUIT
+6 ;
CHKPAUSE ;Check pause
+1 IF $Y>(IOSL-5)
DO PAUSE
if IBQUIT
QUIT
WRITE @IOF
DO LINE("-",80)
WRITE !
+2 QUIT
+3 ;
SCR() ; Screen
QUIT $EXTRACT(IOST,1,2)="C-"
