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

IBAECB1.m

Go to the documentation of this file.
  1. IBAECB1 ;WOIFO/AAT - LTC BILLING CLOCK INQUIRY ; 21-FEB-02
  1. ;;2.0;INTEGRATED BILLING;**171,176,729**;21-MAR-94;Build 8
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. Q
  1. ;
  1. ; Printing the report to the current device
  1. ; Input:
  1. ; IBCLK - LTC Billing Clock IEN
  1. ; IOST,IOSL,IOF Must be defined
  1. ; Output: IBQUIT=1 if user entered "^"
  1. REPORT ;Print the report to the current device
  1. N IBZ,IBN4,IBDFN,IBPTZ,IBNAM,IBDOB,IBVET,IBFTN,IBTAB,IBDT1,IBDT2,IBSTA
  1. N:'$D(IBQUIT) IBQUIT
  1. S IBQUIT=0
  1. ;
  1. ; Define required data
  1. ;
  1. S IBZ=$G(^IBA(351.81,IBCLK,0)) I IBZ="" W !,"Data not found..." Q
  1. S IBDFN=+$P(IBZ,U,2) I 'IBDFN W !,"No patient data..." Q
  1. S IBPTZ=$G(^DPT(IBDFN,0)) I IBPTZ="" W !,"Patient data not found... (",IBDFN,")" Q
  1. S IBN4=$G(^IBA(351.81,IBCLK,4)) ; Node 4
  1. S IBNAM=$P(IBPTZ,U) ; Patient name
  1. S IBDOB=$P(IBPTZ,U,3) ; Patient DOB
  1. S IBVET=+$P($G(^DPT(IBDFN,"TYPE")),U,1) ; Veteran type code
  1. S IBVET=$S(IBVET:$P($G(^DG(391,IBVET,0)),U),1:"") ; Veteran type name
  1. ; Write caption
  1. W IBNAM,?48," ",$$DAT1(IBDOB),?62,IBVET
  1. W ! D LINE("=",80)
  1. ;
  1. ; The body of report
  1. S IBFTN=$P(IBZ,U)
  1. ;; W !,$$FRM("Facility Clock Number"),IBFTN
  1. S IBSTA=$P(IBZ,U,5)
  1. I 0 W !,$$FRM("LTC Copay Clock Status"),$$EXTERNAL^DILFD(351.81,.05,"",IBSTA)
  1. W !,$$FRM("LTC Copay Clock Start Date"),$$DAT2($P(IBZ,U,3))
  1. I 1 W ?56," Clock Status: ",$$EXTERNAL^DILFD(351.81,.05,"",IBSTA)
  1. W !,$$FRM("LTC Copay Clock End Date "),$$DAT2($P(IBZ,U,4))
  1. I '$$SCR() W !
  1. ;;W !,$$FRM("Current Events Date"),$S($P(IBZ,U,7):$$DAT2($P(IBZ,U,7)),1:"none")
  1. ;;I '$$SCR() W !
  1. W !,$$FRM("Free Days Remaining"),+$P(IBZ,U,6)
  1. I $O(^IBA(351.81,IBCLK,1,0)) ; Not used yet
  1. D FRDAYS Q:IBQUIT
  1. W ! D CHKPAUSE Q:IBQUIT
  1. W !,$$FRM("User Added Entry "),$$PERS($P(IBN4,U,1)) D CHKPAUSE Q:IBQUIT
  1. I 0 W !,$$FRM("Date Entry Added")
  1. E W ?55
  1. W $$DAT2($P(IBN4,U,2)) D CHKPAUSE Q:IBQUIT
  1. W !,$$FRM("User Last Updated"),$$PERS($P(IBN4,U,3)) D CHKPAUSE Q:IBQUIT
  1. I 0 W !,$$FRM("Date Last Updated")
  1. E W ?55
  1. W $$DAT2($P(IBN4,U,4))
  1. Q
  1. ;
  1. ;
  1. ; Fotmatting row labels
  1. FRM(IBLBL,IBCUT) ;
  1. I $G(IBCUT,1) S IBLBL=$E(IBLBL,1,26)
  1. Q " "_IBLBL_": " ;;;$J("",26-$L(IBLBL))_": "
  1. ;
  1. DAT1(IBDAT) ;FM -> External date, like 12/25/2000
  1. Q $$FMTE^XLFDT(IBDAT,"5PMZ")
  1. ;
  1. DAT2(IBDAT) ;FM -> External date, like OCT 25, 2001
  1. Q $$FMTE^XLFDT(IBDAT,"1PMZ")
  1. ;
  1. ; Draw a line, of characters IBC, length IBN
  1. LINE(IBC,IBN) N IBL
  1. I $L($G(IBC))'=1 S IBC="="
  1. I +$G(IBN)=0 S IBN=80
  1. S $P(IBL,IBC,IBN+1)=""
  1. W IBL
  1. Q
  1. ; Person
  1. PERS(IBIEN) ;
  1. I '$G(IBIEN) Q ""
  1. Q $P($G(^VA(200,IBIEN,0)),U)
  1. ;
  1. ; Input:
  1. ; IBCLK - LBC Billing Clock IEN
  1. ; IBQUIT - if defined, pauses will be made at the bottom of screen ("C-" devices only!)
  1. ; Output:
  1. ; IBQUIT=1 if user pressed "^". Only if IBQUIT was defined initially!
  1. FRDAYS ; Write the list of exempt days
  1. N IBZ,IBV,IBC,IBI,IBA,IBN
  1. S IBZ=$G(^IBA(351.81,IBCLK,0)) I IBZ="" W !,"Corrupted record of LTC clock ",IBCLK Q
  1. S IBC=0 ; Counter of free days
  1. ; Collect an array of free days:
  1. S IBI=0 F S IBI=$O(^IBA(351.81,IBCLK,1,IBI)) Q:'IBI D:$P(^(IBI,0),U,2)
  1. . S IBC=IBC+1
  1. . S IBA(IBC)=$P(^IBA(351.81,IBCLK,1,IBI,0),U,2)
  1. ;I '$$SCR() W !,$$FRM("Days free of LTC copay")
  1. ;E
  1. W !,$$FRM("Days Not Subject To LTC Copay",0)
  1. I 'IBC W "none" Q
  1. S IBV=IBC\3 I IBC#3 S IBV=IBV+1
  1. F IBI=1:1:IBV D Q:$G(IBQUIT)
  1. . D:$D(IBQUIT) CHKPAUSE
  1. . S IBN=IBI W !?5,$J(IBN,2),?10,$$FMTE^XLFDT(IBA(IBN))
  1. . S IBN=IBI+IBV I $G(IBA(IBN)) W ?30,$J(IBN,2),?35,$$FMTE^XLFDT(IBA(IBN))
  1. . S IBN=IBI+(2*IBV) I $G(IBA(IBN)) W ?55,$J(IBN,2),?60,$$FMTE^XLFDT(IBA(IBN))
  1. Q
  1. ;
  1. PAUSE Q:'$$SCR() ;Screen only
  1. N IBJ,DIR,DIRUT,DTOUT,DUOUT,DIROUT,Y,IOSL2
  1. S IOSL2=$S(IOSL>24:24,1:IOSL)
  1. F IBJ=$Y:1:(IOSL2-4) W !
  1. S DIR(0)="E" D ^DIR K DIR I $G(DUOUT) S IBQUIT=1
  1. Q
  1. ;
  1. CHKPAUSE ;Check pause
  1. I $Y>(IOSL-5) D PAUSE Q:IBQUIT W @IOF D LINE("-",80) W !
  1. Q
  1. ;
  1. SCR() Q $E(IOST,1,2)="C-" ; Screen