source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTU.m@ 1128

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

initial load of FOIAVistA 6/30/08 version
File size: 9.6 KB
Line 
1DGMTU ;ALB/RMO,LBD,BRM,EG - Means Test Utilities ; 02/08/2005 07:10 AM
2 ;;5.3;Registration;**4,33,182,277,290,374,358,420,426,411,332,433,456,476,519,451,630**;Aug 13, 1993
3 ;
4LST(DFN,DGDT,DGMTYPT) ;Last means test for a patient
5 ; Input -- DFN Patient IEN
6 ; DGDT Date/Time (Optional- default today@2359)
7 ; DGMTYPT Type of Test (Optional - if not defined
8 ; Means Test will be assumed)
9 ; Output -- Annual Means Test IEN^Date of Test
10 ; ^Status Name^Status Code^Source of Test
11 N DGIDT,DGMTFL1,DGMTI,DGNOD,Y I '$D(DGMTYPT) S DGMTYPT=1
12 S DGIDT=$S($G(DGDT)>0:-DGDT,1:-DT) S:'$P(DGIDT,".",2) DGIDT=DGIDT_.2359
13 F S DGIDT=+$O(^DGMT(408.31,"AID",DGMTYPT,DFN,DGIDT)) Q:'DGIDT!$G(DGMTFL1) D
14 .F DGMTI=0:0 S DGMTI=+$O(^DGMT(408.31,"AID",DGMTYPT,DFN,DGIDT,DGMTI)) Q:'DGMTI!$G(DGMTFL1) D
15 ..S DGNOD=$G(^DGMT(408.31,DGMTI,0)) I DGNOD,$G(^("PRIM"))!(DGMTYPT=4) S DGMTFL1=1,Y=DGMTI_"^"_$P(^(0),"^")_"^"_$$MTS(DFN,+$P(^(0),"^",3))_"^"_$P(DGNOD,"^",23) ; chk for primary MT
16 Q $G(Y)
17 ;
18LVMT(DFN,DGDT) ;Last valid means test (status other than required)
19 ; Input -- DFN Patient IEN
20 ; DGDT Date (Optional - default today)
21 ; Output -- Annual Means Test IEN^Date of Test^Status Name
22 ; ^Status Code
23 N DGMT,DGMTL
24 S:'$D(DGDT) DGDT=DT S DGMTL=$$LST^DGMTU(DFN,DGDT)
25 I $P(DGMTL,"^",4)="R" F S DGMT=$$LST^DGMTU(DFN,DGDT) Q:DGMT']""!($P(DGMT,U,4)'="R") S DGDT=$P(DGMT,U,2)-1
26 Q $S($G(DGMT)]"":DGMT,1:$G(DGMTL))
27 ;
28NVMT(DFN,DGDT) ;Next valid means test (status other than required)
29 ; Input -- DFN Patient IEN
30 ; DGDT Date (Required)
31 ; Output -- Annual Means Test IEN^Date of Test^Status Name
32 ; ^Status Code
33 N DGDTE,DGMT,DGMT0,DGMTI,DGMTPR,DGMTS
34 S DGDTE=DGDT
35 F S DGDTE=$O(^DGMT(408.31,"AD",1,DFN,DGDTE)) Q:'DGDTE!$G(DGMT) D
36 .F DGMTI=0:0 S DGMTI=$O(^DGMT(408.31,"AD",1,DFN,DGDTE,DGMTI)) Q:'DGMTI S DGMT0=$G(^DGMT(408.31,DGMTI,0)),DGMTS=+$P(DGMT0,"^",3),DGMTPR=$G(^("PRIM")) I +DGMT0,DGMTS'=1,DGMTPR S DGMT=DGMTI_"^"_+DGMT0_"^"_$$MTS^DGMTU(DFN,DGMTS) Q
37 Q $G(DGMT)
38 ;
39MTS(DFN,DGMTS) ;Means test status -- default current
40 ; Input -- DFN Patient IEN
41 ; DGMTS Means Test Status IEN (Optional)
42 ; Output -- Status Name^Status Code
43 N Y
44 S DGMTS=$S($G(DGMTS)>0:DGMTS,1:$P($G(^DPT(DFN,0)),"^",14))
45 I DGMTS S Y=$P($G(^DG(408.32,DGMTS,0)),"^",1,2)
46 Q $G(Y)
47 ;
48DIS(DFN) ;Display patients current means test status,
49 ; eligibility for care, deductible information,
50 ; date of test and date of completion
51 ; Input -- DFN Patient IEN
52 ; Output -- None
53 N DGCS,DGDED,DGMTI,DGMT0
54 S DGCS=$P($G(^DPT(DFN,0)),"^",14) G DISQ:DGCS=""
55 S DGMTI=+$$LST^DGMTU(DFN),DGMT0=$G(^DGMT(408.31,DGMTI,0))
56 S MTSIG=$P(DGMT0,"^",29)
57 W !,"Means Test Signed?: ",$S(MTSIG=1:"YES",MTSIG=0:"NO",MTSIG=9:"DELETED",1:"")
58 I DGCS=1 W !!,"Patient Requires a Means Test"
59 I DGCS=2 W !!,"Patient's Means Test is Pending Adjudication for "_$$PA^DGMTUTL(DGMTI)
60 I DGCS=3 W !!,"Means Test Not Required"
61 I ("^4^5^6^16^")[("^"_DGCS_"^") W !!,"Patient's status is ",$$GETNAME^DGMTH(DGCS)," based on primary means test"
62 I $D(^DG(408.32,DGCS,"MSG")) W !,^("MSG")
63 I DGCS=6 S DGDED=$P(DGMT0,"^",11) W ! W:DGDED]"" "Has",$S(DGDED:"",1:" not")," agreed to pay the deductible"
64 S Y=$P(DGMT0,"^") X ^DD("DD") W !,"Primary Means Test ",$S(DGCS=1:"Required from",1:"Last Applied")," '",Y,"'"
65 I ("^2^4^5^6^16^")[("^"_DGCS_"^") S Y=$P(DGMT0,"^",7) X ^DD("DD") W " (COMPLETED: ",Y,")"
66 I DGCS=3 S Y=$P(DGMT0,"^",17) X ^DD("DD") W " (NO LONGER REQUIRED: ",Y,")"
67DISQ Q
68 ;
69EDT(DFN,DGDT) ;Display patients current means test information and provide
70 ; the user with the option of proceeding with a required
71 ; means test or editing an existing means test
72 ; Input -- DFN Patient IEN
73 ; DGDT Date/Time
74 ; Output -- None
75 ;
76 ; obtain lock used to synchronize local MT/CT options with income test upload
77 I $$LOCK^DGMTUTL(DFN)
78 ;
79 D DIS(DFN)
80 S DGMTI=+$$LST(DFN,DGDT) G EDTQ:'DGMTI!(DGMTI'=+$$LST^DGMTU(DFN))
81 S DGMT0=$G(^DGMT(408.31,DGMTI,0)),DGMTDT=+DGMT0,DGMTS=$P(DGMT0,"^",3)
82 S DIR("A")="Do you wish to "_$S(DGMTS=1:"proceed with",1:"edit")_" the means test at this time"
83 S DIR("B")=$S(DGMTS=1:"YES",1:"NO"),DIR(0)="Y"
84 W ! D ^DIR G EDTQ:$D(DTOUT)!($D(DUOUT))
85 I Y S DGMTYPT=1,DGMTACT="EDT",DGMTROU="EDTQ^DGMTU" G EN^DGMTSC
86EDTQ K DGMT0,DGMTACT,DGMTDT,DGMTI,DGMTROU,DGMTS,DIR,DTOUT,DUOUT,Y
87 ;
88 ; release lock
89 D UNLOCK^DGMTUTL(DFN)
90 ;
91 Q
92 ;
93CMTS(DFN) ;Get Current Means Test Status - query HEC if necessary
94 ;
95 ; Input: DFN=patient ien
96 ; Output: MT IEN^Date of Test^Status Name
97 ; ^Status Code^Source of Test
98 ;
99 N X,Y,DGMTDATA,DGQSENT,DGDOD,NODE0,DGRET,DGMFLG,DGTAG,DGMTYPT
100 D CHKPT^DGMTU4(DFN)
101 S DGMTYPT=1,DGMTDATA=$$LST(DFN,"",DGMTYPT)
102 ;Next line checks to see if patient has expired, if so, Query not initiated
103 S DGDOD=$P($G(^DPT(DFN,.35)),U)
104 I +DGDOD Q DGMTDATA
105 ;Next line checks to see if current test exists, if not, Query not initiated
106 I '$G(DGMTDATA) Q DGMTDATA
107 D:+$$QFLG(DGMTDATA)
108 .I $G(IVMZ10)'="UPLOAD IN PROGRESS",'$$OPEN^IVMCQ2(DFN),'$$SENT^IVMCQ2(DFN),$G(DGMFLG)'=0 D
109 ..I $$LOCK^DGMTUTL(DFN)
110 ..D QRYQUE2^IVMCQ2(DFN,$G(DUZ),0,$G(XQY)) S DGQSENT=1
111 ..I '$D(ZTQUEUED),'$G(DGMSGF),$G(DGQSENT) W !!,"Financial query queued to be sent to HEC...",! H .5
112 ..D UNLOCK^DGMTUTL(DFN)
113 .S DGMTDATA=$$LST(DFN,"",DGMTYPT)
114 D:+$$MFLG(DGMTDATA)
115 .S DGMFLG=$$MFLG(DGMTDATA)
116 .S DGTAG=$S(DGMFLG=1:"MSG"_DGMFLG,DGMFLG=2:"MSG"_DGMFLG,1:0)
117 .I DGTAG["MSG",'$G(DGMSGF) D @DGTAG
118 Q DGMTDATA ;return most current MT data
119MFLG(DGMTDATA) ;Set up appropriate informational message flag for user's
120 ;benefit.
121 ;Input - DGMTDATA as defined by $$LST function.
122 ;Output - DGRETV
123 ; 1 = Current Test is REQUIRED
124 ; 2 = Test is > 365 days old and is in a status of
125 ; other than REQUIRED or NO LONGER REQUIRED
126 ; 2 = Pend Adj for GMT, test date is 10/6/99 or
127 ; greater and agreed to the deductible
128 ; 0 = CAT C/Pend Adj for MT, test date is 10/6/99
129 ; or greater and agreed to the deductible.
130 ; OR 0 = Cat C, declined income info and agreed
131 ; to pay deductible.
132 ; OR 0 = Has a future dated Means Test
133 N DGRETV,FTST,DGMT0
134 S DGRETV=0 I '$G(DGMTDATA) Q DGRETV
135 S DGMT0=$G(^DGMT(408.31,+DGMTDATA,0))
136 I $P(DGMTDATA,U,4)="R" S DGRETV=1
137 I $$OLD^DGMTU4($P(DGMTDATA,U,2)),($P(DGMTDATA,U,4)'="N")&($P(DGMTDATA,U,4)'="R") S DGRETV=2
138 I ($P(DGMTDATA,U,4)="C")!($P(DGMTDATA,U,4)="P"&($P(DGMT0,U,12)'<$P(DGMT0,U,27))),$P(DGMTDATA,U,2)>2991005,$P(DGMT0,U,11)=1 S DGRETV=0
139 I ($P(DGMTDATA,U,4)="C"),+$P(DGMT0,U,14),+$P(DGMT0,U,11) S DGRETV=0
140 D DOM^DGMTR I $G(DGDOM) S DGRETV=0
141 S FTST=$$FUT(DFN)
142 I DGRETV,FTST,$P(^DGMT(408.31,+FTST,0),U,19)=1 S DGRETV=0
143 Q DGRETV
144MSG1 ;Informational message 1
145 N NODE0,Y
146 S NODE0=$G(^DGMT(408.31,+DGMTDATA,0))
147 W !!,$C(7),?15,"*** Patient Requires a Means Test ***",!
148 S Y=$P(NODE0,U) X ^DD("DD") W !,?14,"Primary Means Test Required from "_Y,!
149 I $G(IOST)["C-" R !!,"Enter <RETURN> to continue.",DGRET:DTIME
150 Q
151MSG2 ;Informational message 2
152 N NODE0,Y
153 S NODE0=$G(^DGMT(408.31,+DGMTDATA,0))
154 W !!,$C(7),?17,"*** Patient Requires a Means Test ***",!
155 S Y=$P(NODE0,U) X ^DD("DD") W !,?10,"Patient's Test dated "_Y_" is "_$P(DGMTDATA,U,3)_"."_" The test"
156 W !,?10,"date is greater than 365 days old. Please update."
157 I $G(IOST)["C-" R !!,"Enter <RETURN> to continue.",DGRET:DTIME
158 Q
159QFLG(DGMTDATA) ;
160 ;INPUT - DGMTDATA
161 ;OUTPUT- IVMQFLG 1 if query is necessary 0 if not
162 N IVMQFLG,DGMT0
163 S IVMQFLG=0 I '$G(DGMTDATA) Q IVMQFLG
164 S DGMT0=$G(^DGMT(408.31,+DGMTDATA,0))
165 ;Set flag to 1 if Means test is Required.
166 I $P(DGMTDATA,U,4)="R" S IVMQFLG=1
167 ;Set flag to 1 if Means test older than 365 days and status is not
168 ;NO LONGER REQUIRED and not REQUIRED.
169 I $$OLD^DGMTU4($P(DGMTDATA,U,2)),($P(DGMTDATA,U,4)'="N")&($P(DGMTDATA,U,4)'="R") S IVMQFLG=1
170 ;If Cat C/Pend Adj for MT, older than 365 days, agreed to pay, test
171 ;date > 10/5/99 reset flag to 0 - no query is necessary.
172 I ($P(DGMTDATA,U,4)="C")!($P(DGMTDATA,U,4)="P"&($P(DGMT0,U,12)'<$P(DGMT0,U,27))),$P(DGMTDATA,U,2)>2991005,$P(DGMT0,U,11)=1 S IVMQFLG=0
173 ;If patient is Cat C, declined to provide income but has agreed to
174 ;pay deductible, no query necessary - reset flag to 0
175 I ($P(DGMTDATA,U,4)="C"),+$P(DGMT0,U,14),+$P(DGMT0,U,11) S DGRETV=0
176 ;If patient is on a DOM ward, don't initiate query
177 D DOM^DGMTR I $G(DGDOM) S IVMQFLG=0
178 Q IVMQFLG
179 ;
180FUT(DFN,DGDT,DGMTYPT) ; Future Means Tests for a patient
181 ;DFN Patient IEN
182 ;DGDT Date (Optional- default to today)
183 ;DGMTYPT Type of Test (Optional - default to MT)
184 ;Return
185 ;If a DCD test was performed it will be returned, else the
186 ;current future dated test for the Income Year.
187 ;MT IEN^Date of Test^Status Name^Status Code^Source
188 ;
189 N DGIDT,Y,MTIEN,SRCE,DONE,MTNOD,ARR,LAST,TYPTST
190 S:'$D(DGMTYPT) DGMTYPT=1
191 ;no future LTC eg 02/15/2005
192 I ($G(DGMTYPT)=4) Q ""
193 S TYPTST=$S(DGMTYPT=2:"AF",1:"AE")
194 S DGIDT=$S($G(DGDT)>0:DGDT,1:DT),DONE=0
195 S (ARR,LAST,Y)=""
196 S:$P(DGIDT,".",2) DGIDT=$P(DGIDT,".")
197 F S DGIDT=$O(^IVM(301.5,TYPTST,DFN,DGIDT)) Q:'DGIDT!(DONE) D
198 .S MTIEN=0
199 .F S MTIEN=$O(^IVM(301.5,TYPTST,DFN,DGIDT,MTIEN)) Q:'MTIEN!(DONE) D
200 ..Q:'$D(^DGMT(408.31,MTIEN,0))
201 ..S MTNOD=^DGMT(408.31,MTIEN,0),SRCE=$P(MTNOD,U,23)
202 ..I SRCE'=1 S DONE=1,Y=MTIEN_U_$P(MTNOD,U)_U_$$MTS^DGMTU(DFN,+$P(MTNOD,U,3))_U_$P(MTNOD,U,23) Q
203 ..I 'DONE,'$D(ARR($P(MTNOD,U),MTIEN)) S ARR($P(MTNOD,U),MTIEN)=MTIEN_U_$P(MTNOD,U)_U_$$MTS^DGMTU(DFN,+$P(MTNOD,U,3))_U_$P(MTNOD,U,23)
204 I 'DONE S LAST=$O(ARR(""),-1) I LAST S Y=ARR(LAST,$O(ARR(LAST,""),-1))
205 Q $G(Y)
Note: See TracBrowser for help on using the repository browser.