source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBAECB1.m@ 1259

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1IBAECB1 ;WOIFO/AAT-LTC BILLING CLOCK INQUIRY ; 21-FEB-02
2 ;;2.0;INTEGRATED BILLING;**171,176**;21-MAR-94
3 ;; Per VHA Directive 10-93-142, this routine should not be modified
4 ;
5 Q
6 ;
7 ; Printing the report to the current device
8 ; Input:
9 ; IBCLK - LTC Billing Clock IEN
10 ; IOST,IOSL,IOF Must be defined
11 ; Output: IBQUIT=1 if user entered "^"
12REPORT ;Print the report to the current device
13 N IBZ,IBN4,IBDFN,IBPTZ,IBNAM,IBSSN,IBDOB,IBVET,IBFTN,IBTAB,IBDT1,IBDT2,IBSTA
14 N:'$D(IBQUIT) IBQUIT
15 S IBQUIT=0
16 ;
17 ; Define required data
18 ;
19 S IBZ=$G(^IBA(351.81,IBCLK,0)) I IBZ="" W !,"Data not found..." Q
20 S IBDFN=+$P(IBZ,U,2) I 'IBDFN W !,"No patient data..." Q
21 S IBPTZ=$G(^DPT(IBDFN,0)) I IBPTZ="" W !,"Patient data not found... (",IBDFN,")" Q
22 S IBN4=$G(^IBA(351.81,IBCLK,4)) ; Node 4
23 S IBNAM=$P(IBPTZ,U) ; Patient name
24 S IBSSN=$P(IBPTZ,U,9) ; Patient SSN
25 S IBDOB=$P(IBPTZ,U,3) ; Patient DOB
26 S IBVET=+$P($G(^DPT(IBDFN,"TYPE")),U,1) ; Veteran type code
27 S IBVET=$S(IBVET:$P($G(^DG(391,IBVET,0)),U),1:"") ; Veteran type name
28 ; Write caption
29 W IBNAM,?32," ",$$SSN(IBSSN),?48," ",$$DAT1(IBDOB),?62,IBVET
30 W ! D LINE("=",80)
31 ;
32 ; The body of report
33 S IBFTN=$P(IBZ,U)
34 ;; W !,$$FRM("Facility Clock Number"),IBFTN
35 S IBSTA=$P(IBZ,U,5)
36 I 0 W !,$$FRM("LTC Copay Clock Status"),$$EXTERNAL^DILFD(351.81,.05,"",IBSTA)
37 W !,$$FRM("LTC Copay Clock Start Date"),$$DAT2($P(IBZ,U,3))
38 I 1 W ?56," Clock Status: ",$$EXTERNAL^DILFD(351.81,.05,"",IBSTA)
39 W !,$$FRM("LTC Copay Clock End Date "),$$DAT2($P(IBZ,U,4))
40 I '$$SCR() W !
41 ;;W !,$$FRM("Current Events Date"),$S($P(IBZ,U,7):$$DAT2($P(IBZ,U,7)),1:"none")
42 ;;I '$$SCR() W !
43 W !,$$FRM("Free Days Remaining"),+$P(IBZ,U,6)
44 I $O(^IBA(351.81,IBCLK,1,0)) ; Not used yet
45 D FRDAYS Q:IBQUIT
46 W ! D CHKPAUSE Q:IBQUIT
47 W !,$$FRM("User Added Entry "),$$PERS($P(IBN4,U,1)) D CHKPAUSE Q:IBQUIT
48 I 0 W !,$$FRM("Date Entry Added")
49 E W ?55
50 W $$DAT2($P(IBN4,U,2)) D CHKPAUSE Q:IBQUIT
51 W !,$$FRM("User Last Updated"),$$PERS($P(IBN4,U,3)) D CHKPAUSE Q:IBQUIT
52 I 0 W !,$$FRM("Date Last Updated")
53 E W ?55
54 W $$DAT2($P(IBN4,U,4))
55 Q
56 ;
57 ;
58 ; Fotmatting row labels
59FRM(IBLBL,IBCUT) ;
60 I $G(IBCUT,1) S IBLBL=$E(IBLBL,1,26)
61 Q " "_IBLBL_": " ;;;$J("",26-$L(IBLBL))_": "
62 ;
63SSN(IBSSN) I IBSSN?9N Q $E(IBSSN,1,3)_"-"_$E(IBSSN,4,5)_"-"_$E(IBSSN,6,9)
64 Q IBSSN
65 ;
66DAT1(IBDAT) ;FM -> External date, like 12/25/2000
67 Q $$FMTE^XLFDT(IBDAT,"5PMZ")
68 ;
69DAT2(IBDAT) ;FM -> External date, like OCT 25, 2001
70 Q $$FMTE^XLFDT(IBDAT,"1PMZ")
71 ;
72 ; Draw a line, of characters IBC, length IBN
73LINE(IBC,IBN) N IBL
74 I $L($G(IBC))'=1 S IBC="="
75 I +$G(IBN)=0 S IBN=80
76 S $P(IBL,IBC,IBN+1)=""
77 W IBL
78 Q
79 ; Person
80PERS(IBIEN) ;
81 I '$G(IBIEN) Q ""
82 Q $P($G(^VA(200,IBIEN,0)),U)
83 ;
84 ; Input:
85 ; IBCLK - LBC Billing Clock IEN
86 ; IBQUIT - if defined, pauses will be made at the bottom of screen ("C-" devices only!)
87 ; Output:
88 ; IBQUIT=1 if user pressed "^". Only if IBQUIT was defined initially!
89FRDAYS ; Write the list of exempt days
90 N IBZ,IBV,IBC,IBI,IBA,IBN
91 S IBZ=$G(^IBA(351.81,IBCLK,0)) I IBZ="" W !,"Corrupted record of LTC clock ",IBCLK Q
92 S IBC=0 ; Counter of free days
93 ; Collect an array of free days:
94 S IBI=0 F S IBI=$O(^IBA(351.81,IBCLK,1,IBI)) Q:'IBI D:$P(^(IBI,0),U,2)
95 . S IBC=IBC+1
96 . S IBA(IBC)=$P(^IBA(351.81,IBCLK,1,IBI,0),U,2)
97 ;I '$$SCR() W !,$$FRM("Days free of LTC copay")
98 ;E
99 W !,$$FRM("Days Not Subject To LTC Copay",0)
100 I 'IBC W "none" Q
101 S IBV=IBC\3 I IBC#3 S IBV=IBV+1
102 F IBI=1:1:IBV D Q:$G(IBQUIT)
103 . D:$D(IBQUIT) CHKPAUSE
104 . S IBN=IBI W !?5,$J(IBN,2),?10,$$FMTE^XLFDT(IBA(IBN))
105 . S IBN=IBI+IBV I $G(IBA(IBN)) W ?30,$J(IBN,2),?35,$$FMTE^XLFDT(IBA(IBN))
106 . S IBN=IBI+(2*IBV) I $G(IBA(IBN)) W ?55,$J(IBN,2),?60,$$FMTE^XLFDT(IBA(IBN))
107 Q
108 ;
109PAUSE Q:'$$SCR() ;Screen only
110 N IBJ,DIR,DIRUT,DTOUT,DUOUT,DIROUT,Y,IOSL2
111 S IOSL2=$S(IOSL>24:24,1:IOSL)
112 F IBJ=$Y:1:(IOSL2-4) W !
113 S DIR(0)="E" D ^DIR K DIR I $G(DUOUT) S IBQUIT=1
114 Q
115 ;
116CHKPAUSE ;Check pause
117 I $Y>(IOSL-5) D PAUSE Q:IBQUIT W @IOF D LINE("-",80) W !
118 Q
119 ;
120SCR() Q $E(IOST,1,2)="C-" ; Screen
Note: See TracBrowser for help on using the repository browser.