source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBAECP.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 6.9 KB
Line 
1IBAECP ;WOIFO/AAT-LTC SINGLE PATIENT PROFILE ; 20-FEB-02
2 ;;2.0;INTEGRATED BILLING;**171,176,199**;21-MAR-94
3 ;; Per VHA Directive 10-93-142, this routine should not be modified
4 ;
5 S:'$D(DTIME) DTIME=300 D HOME^%ZIS
6 ;
7 ;
8 N IBQUIT,POP
9 F S IBQUIT=0 D Q:IBQUIT
10 . N IBDFN,IBCLK,IBDT1,IBDT2,%DT,X,Y,DIC,IBOFD,IBOEV
11 . W !
12 . S IBDFN=$$ASKPAT() I IBDFN=-1 S IBQUIT=1 Q
13 . ; Enter required clock (if more than one)
14 . S IBCLK=$$ASKCLK(IBDFN) I IBCLK<1 Q S IBQUIT=1
15 . ; Ask about beginning and ending date and perform action
16 . ; No default valies provided
17 . ; W !,"The report is not available at the patch IB*2.0*171" Q
18 . D DATE I IBDT1<0 Q S IBQUIT=1 Q ;Enter date range (defaults are begin/end of the clock)
19 . D ASKOFD I IBOFD<0 Q S IBQUIT=1 Q ;Option - print free days
20 . D ASKOEV I IBOEV<0 Q S IBQUIT=1 Q ;Option - print event history
21 . D ASKDEV
22 Q
23 ;
24ASKDEV ; Ask about output device and print the report (or run task)
25 N %ZIS
26 S %ZIS="QM"
27 W ! D ^%ZIS Q:POP ; Quit and ask for patient again. Otherwise Set IBSTOP=1
28 ; If it was queued
29 I $D(IO("Q")) D RUNTASK Q
30 U IO D REPORT^IBAECP1 ; Generate report directly
31 D ^%ZISC ; Close the device
32 Q
33 ;
34 ;
35RUNTASK ; Start Taskman job
36 N ZTRTN,ZTSK,IBVAR,ZTSAVE,ZTDESC
37 S ZTRTN="REPORT^IBAECP1",ZTDESC="LTC SINGLE PATIENT BILLING PROFILE"
38 F IBVAR="IBDFN","IBCLK","IBDT1","IBDT2","IBOFD","IBOEV" S ZTSAVE(IBVAR)=""
39 D ^%ZTLOAD
40 K IO("Q")
41 D HOME^%ZIS W !
42 Q
43 ;
44 ; User's interface for LTC Billing Clock
45 ; If the user has only one clock - doesn't ask, only shows brief info.
46 ; Parameters:
47 ; IBDFN - patient IEN
48 ; IBSHOW - if 1, the list of clocks will be printed
49 ; Returns: LTC Clock IEN (or -1, if canceled, or 0, if the user doesn't has any clocks)
50ASKCLK(IBDFN,IBSHOW) N IBDT,IBDT2,IBX,IBZ,IBCNT,IBCL,DIRUT,Y,DIR,IBI,IBY,IBCLK
51 I '$D(^IBA(351.81,"AE",IBDFN)) D Q 0 ; No data for the patient
52 . W !,"The user doesn't have LTC Billing Clock created"
53 ; Collect all data in IBCL array IBCL(DATE)=IEN,IBCL=<Number of clocks>
54 S IBCL=0
55 S IBCLK=0,IBDT=0 F S IBDT=$O(^IBA(351.81,"AE",IBDFN,IBDT)) Q:'IBDT D
56 . S IBX=0 F S IBX=$O(^IBA(351.81,"AE",IBDFN,IBDT,IBX)) Q:'IBX D
57 .. S IBCL(IBDT)=IBX
58 .. S IBCL=IBCL+1
59 ;
60 ; If there is only one clock - no need to ask, just show
61 I IBCL=1 S IBCLK=IBCL($O(IBCL(""))) D LSTCLK W ! Q IBCLK
62 K Y
63 F D Q:$D(DIRUT) Q:$D(IBCL(Y)) W " ??"
64 . ;Choose one
65 . I $D(Y)!($G(IBSHOW)) W ! D LSTCLK W ! ; Bad enter - list options
66 . K DIR,DIRUT
67 . S DIR(0)="FE"
68 . S DIR("A")="Choose LTC BILLING CLOCK (1-"_IBCL_")"
69 . S DIR("B")=$$FMTE^XLFDT(+$O(IBCL(""),-1),"1D")
70 . S DIR("?")="Enter date of the required LTC BILLING CLOCK. Enter '??' for clocks list."
71 . S DIR("??")="^D LSTCLK^IBAECP"
72 . D ^DIR Q:$D(DIRUT)
73 . ; User may enter just number
74 . I Y=+Y,Y>0,Y'>IBCL D I IBY S Y=IBY Q
75 .. S IBY="" F IBI=1:1:Y S IBY=$O(IBCL(IBY)) Q:IBY=""
76 . S %DT="" D ^%DT ; Convert external to internal format
77 I $D(DIRUT) Q -1
78 W " (",$$FMTE^XLFDT(Y),")"
79 Q IBCL(Y)
80 ;
81 ; Ask begin/end dates, with default values
82 ; Input: IBCLK - LTC Clock IEN
83 ; Output: IBDT1,IBDT2 - begin/end dates
84DATE N %DT,Y,IBDT,IBNOW
85DATAGN ;Loop entry point
86 S (IBDT1,IBDT2)=-1
87 ; Get beginning date
88 S IBDT=$P($G(^IBA(351.81,IBCLK,0)),U,3)
89 S IBDT1=$$ASKDT("Start with DATE: ",IBDT)
90 I IBDT1<1 Q
91 ; Get ending date
92 S IBDT=$P($G(^IBA(351.81,IBCLK,0)),U,4)
93 S IBNOW=$$NOW()
94 I 'IBDT S IBDT=IBNOW
95 E I IBDT>IBNOW S IBDT=IBNOW
96 S IBDT2=$$ASKDT("Go to DATE: ",IBDT)
97 I IBDT2<1 S IBDT1=-1 Q
98 I IBDT2<IBDT1 W !,"Ending date must follow start date!",! G DATAGN
99 Q
100 ;
101 ;Returns today's date in FM format
102NOW() N %,%H,%I,X
103 D NOW^%DTC
104 Q X
105 ;
106 ; Ask - print free days or not?
107 ; Input: none
108 ; Output: IBOFD (bool) IBOFD=-1 if cancelled
109ASKOFD ; Default - YES
110 N DIR,Y,DUOUT
111 S DIR(0)="Y",DIR("A")="Include DAYS NOT SUBJECT TO LTC COPAY on this report",DIR("B")="YES"
112 D ^DIR
113 S IBOFD=$S($G(DUOUT)!$G(DUOUT)!(Y="^"):-1,1:Y)
114 Q
115 ; Ask - print LTC events or not?
116 ; Input: none
117 ; Output: IBOEV (bool) IBOEV=-1 if cancelled
118ASKOEV ; Default - YES
119 N DIR,Y,DUOUT
120 S DIR(0)="Y",DIR("A")="Include LTC EVENTS on this report",DIR("B")="YES"
121 D ^DIR
122 S IBOEV=$S($G(DUOUT)!$G(DTOUT)!(Y="^"):-1,1:Y)
123 Q
124 ; Double question mark action - for the "enter clock" dialog
125 ; Input:
126 ; IBCL=<Number of clocks>
127 ; IBCL(<Clock date>)=<Clock IEN> local array - list of clocks
128 ; IBDFN= IEN of the patient
129LSTCLK N IBZ,IBDT,IBCNT,IBDT2
130 W !,$P(^DPT(IBDFN,0),U)," has the following LTC Copay Clock",$S(IBCL>1:"s",1:""),!
131 S IBCNT=0
132 S IBDT=0 F S IBDT=$O(IBCL(IBDT)) Q:'IBDT D
133 . S IBX=IBCL(IBDT)
134 . S IBZ=^IBA(351.81,IBX,0),IBCNT=IBCNT+1
135 . W !?10,IBCNT,?15,$$FMTE^XLFDT(IBDT)
136 . S IBDT2=$P(IBZ,U,4)
137 . I IBDT2 W ?28," - ",$$FMTE^XLFDT(IBDT2)
138 . W ?48,$$EXTERNAL^DILFD(351.81,.05,"",$P(IBZ,"^",5))
139 Q
140 ;
141 ; Input: prompt, default value (FM format)
142 ; Output: date (FM) or -1, if cancelled
143ASKDT(IBPRMT,IBDFLT) ;Date input
144 N DIR,Y,Y0,X,DIROUT,DIRUT
145 I $G(IBPRMT)'="" S DIR("A")=IBPRMT
146 I $G(IBDFLT)'="" S DIR("B")=$$FMTE^XLFDT(IBDFLT,"1D")
147 S DIR(0)="DA"
148 D ^DIR I $D(DIRUT) Q -1
149 W " (",$$FMTE^XLFDT(Y),")"
150 Q Y
151 ;
152 ;Enter PATIENT NAME (LTC Patients, having a clock only!)
153 ;Customized dialog (added more explanation on '??' input)
154ASKPAT() N DIR,DIC,Y,X,IBDFN
155 F D Q:$D(DIRUT) Q:Y>0
156 . S DIR("A")="Select PATIENT NAME"
157 . S DIR(0)="FO"
158 . S DIR("?")="Enter '??' to list all LTC Patients"
159 . S DIR("?",1)="Enter a name of LTC Patient"
160 . S DIR("?",2)="Answer with PATIENT NAME, or SOCIAL SECURITY NUMBER, or last 4 digits"
161 . S DIR("?",3)="of SOCIAL SECURITY NUMBER, or first initial of last name with last"
162 . S DIR("?",4)="4 digits of SOCIAL SECURITY NUMBER"
163 . S DIR("?",5)=""
164 . S DIR("??")="^D ASKPATQQ^IBAECP"
165 . D ^DIR Q:$D(DIRUT)
166 . S X=Y
167 . I X?3N1"-"2N1"-"4N.3A S X=$TR(X,"-","") ; Remove dashes from SSN
168 . S DIC="^DPT(",DIC(0)="QME"
169 . S DIC("S")="I $D(^IBA(351.81,""AE"",Y))"
170 . S DIC("W")="D WRTPAT^IBAECP(+Y)"
171 . N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
172 . D ^DIC Q:Y<1 ; Patient code
173 . S Y=+$G(Y)
174 . ;W " " D WRTPAT(Y)
175 I $D(DIRUT) Q -1
176 Q +Y
177 ;
178ASKPATQQ N DIC,X,Y,IBDFN,IBI,DIR,DIRUT,DIROUT,DTOUT,DUOUT,IBCNT
179 D ASKPHD
180 S IBI=7,IBCNT=0
181 ;S DIC="^DPT",DIC(0)="F",X="??" D ^DIC
182 S IBDFN=0 F S IBDFN=$O(^IBA(351.81,"AE",IBDFN)) Q:'IBDFN D Q:$D(DIRUT)
183 . W ! S IBI=IBI+1
184 . I IBI>IOSL S DIR(0)="E" D ^DIR W ! Q:$D(DIRUT) W ! S IBI=3 ; D ASKPHD S IBI=4
185 . ; S IBCNT=IBCNT+1
186 . ; W $J(IBCNT,4)," ",?6
187 . D WRTPAT(IBDFN)
188 Q
189 ;
190ASKPHD ;Header
191 N IBI
192 W !,"Choose an LTC Patient:",!
193 Q
194 ;W !," LTC PATIENT NAME",?30,"BIRTH DATE",?45,"SSN",?55,"STATUS",?68,"CLK DATE"
195 ;W ! F IBI=1:1:80 W "-"
196 ;Q
197WRTPAT(IBDFN) ; Write patient's data
198 N IBZ,IBVET,IBSC
199 S IBZ=$G(^DPT(IBDFN,0)) Q:IBZ="" ""
200 S IBSC=($P($G(^DPT(IBDFN,3)),U)="Y")
201 S IBVET=($P($G(^DPT(IBDFN,"VET")),U)="Y")
202 W $P(IBZ,U)
203 W " ",?30,$$FMTE^XLFDT($P($P(IBZ,U,3),"."),"5MZ")
204 W " ",?42,$$SSN($$EXTERNAL^DILFD(2,.09,"",$P(IBZ,U,9)))
205 W " ",?55,$S(IBVET:$S(IBSC:"S/C",1:"NSC")_" VETERAN",1:"")
206 W " ",?68,$$FMTE^XLFDT($P($O(^IBA(351.81,"AE",IBDFN,""),-1),"."),"5MZ")
207 Q
208 ;
209SSN(IBN) ;Format SSN Value
210 I $L(+IBN)<7 Q IBN
211 Q $E(IBN,1,3)_"-"_$E(IBN,4,5)_"-"_$E(IBN,6,255)
Note: See TracBrowser for help on using the repository browser.