- IBAECB1 ;WOIFO/AAT - LTC BILLING CLOCK INQUIRY ; 21-FEB-02
- ;;2.0;INTEGRATED BILLING;**171,176,729**;21-MAR-94;Build 8
- ;;Per VA Directive 6402, 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,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 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,?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))_": "
- ;
- 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 3969 printed Jan 18, 2025@03:07:10 Page 2
- IBAECB1 ;WOIFO/AAT - LTC BILLING CLOCK INQUIRY ; 21-FEB-02
- +1 ;;2.0;INTEGRATED BILLING;**171,176,729**;21-MAR-94;Build 8
- +2 ;;Per VA Directive 6402, 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,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 DOB
- SET IBDOB=$PIECE(IBPTZ,U,3)
- +13 ; Veteran type code
- SET IBVET=+$PIECE($GET(^DPT(IBDFN,"TYPE")),U,1)
- +14 ; Veteran type name
- SET IBVET=$SELECT(IBVET:$PIECE($GET(^DG(391,IBVET,0)),U),1:"")
- +15 ; Write caption
- +16 WRITE IBNAM,?48," ",$$DAT1(IBDOB),?62,IBVET
- +17 WRITE !
- DO LINE("=",80)
- +18 ;
- +19 ; The body of report
- +20 SET IBFTN=$PIECE(IBZ,U)
- +21 ;; W !,$$FRM("Facility Clock Number"),IBFTN
- +22 SET IBSTA=$PIECE(IBZ,U,5)
- +23 IF 0
- WRITE !,$$FRM("LTC Copay Clock Status"),$$EXTERNAL^DILFD(351.81,.05,"",IBSTA)
- +24 WRITE !,$$FRM("LTC Copay Clock Start Date"),$$DAT2($PIECE(IBZ,U,3))
- +25 IF 1
- WRITE ?56," Clock Status: ",$$EXTERNAL^DILFD(351.81,.05,"",IBSTA)
- +26 WRITE !,$$FRM("LTC Copay Clock End Date "),$$DAT2($PIECE(IBZ,U,4))
- +27 IF '$$SCR()
- WRITE !
- +28 ;;W !,$$FRM("Current Events Date"),$S($P(IBZ,U,7):$$DAT2($P(IBZ,U,7)),1:"none")
- +29 ;;I '$$SCR() W !
- +30 WRITE !,$$FRM("Free Days Remaining"),+$PIECE(IBZ,U,6)
- +31 ; Not used yet
- IF $ORDER(^IBA(351.81,IBCLK,1,0))
- +32 DO FRDAYS
- if IBQUIT
- QUIT
- +33 WRITE !
- DO CHKPAUSE
- if IBQUIT
- QUIT
- +34 WRITE !,$$FRM("User Added Entry "),$$PERS($PIECE(IBN4,U,1))
- DO CHKPAUSE
- if IBQUIT
- QUIT
- +35 IF 0
- WRITE !,$$FRM("Date Entry Added")
- +36 IF '$TEST
- WRITE ?55
- +37 WRITE $$DAT2($PIECE(IBN4,U,2))
- DO CHKPAUSE
- if IBQUIT
- QUIT
- +38 WRITE !,$$FRM("User Last Updated"),$$PERS($PIECE(IBN4,U,3))
- DO CHKPAUSE
- if IBQUIT
- QUIT
- +39 IF 0
- WRITE !,$$FRM("Date Last Updated")
- +40 IF '$TEST
- WRITE ?55
- +41 WRITE $$DAT2($PIECE(IBN4,U,4))
- +42 QUIT
- +43 ;
- +44 ;
- +45 ; 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 ;
- 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-"