source: WorldVistAEHR/trunk/r/WOMENS_HEALTH-WV/WVUTL9.m@ 1042

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

initial load of WorldVistAEHR

File size: 5.4 KB
Line 
1WVUTL9 ;HCIOFO/FT-Women's Health Utility Routine; ;3/18/03 15:44
2 ;;1.0;WOMEN'S HEALTH;**3,7,9,10,17**;Sep 30, 1998
3 ;
4 ; This routine uses the following IAs:
5 ; #10035 - ^DPT references (supported)
6 ; #10056 - ^DIC(5 references (supported)
7 ; #10061 - ^VADPT calls (supported)
8 ; #10103 - ^XLFDT calls (supported)
9 ;
10DCM(SITE) ; Default case manager check
11 ; If there is a default case manager return 1 else 0.
12 I 'SITE Q 0
13 I $P($G(^WV(790.02,SITE,0)),U,2) Q 1
14 Q 0
15 ;
16NODCM ; No Default Case Manager message
17 W !,"Sorry, but a DEFAULT CASE MANAGER must be assigned for your facility"
18 W !,"before a patient can be entered into the Women's Health database.",!
19 W !,"Please use the EDIT SITE PARAMETERS option on the FILE MAINTENANCE"
20 W !,"menu to designate a DEFAULT CASE MANAGER.",!
21 D DIRZ^WVUTL3
22 Q
23 ;
24AGE(DFN) ;EP
25 ;---> YIELD PATIENT'S AGE IN YEARS.
26 ;---> REQUIRED VARIABLE: DFN=IEN PATIENT FILE
27 ; Different from AGE^WVUTL1. This EP returns age at date of death.
28 N X,X1,X2
29 Q:'$G(DFN) "NO PATIENT"
30 S X2=$$DOB^WVUTL1(DFN)
31 Q:'+X2 "UNKNOWN"
32 S X1=DT
33 I $$DECEASED^WVUTL1(DFN) S X1=+^DPT(DFN,.35)
34 D ^%DTC
35 Q $P(X/365.25,".")_"y/o"
36 ;
37GAPPT(DFN) ; Get future appointments from SDA^VADPT
38 ; Returns ^UTILITY("VASD",$J,#,"I") <-internal values
39 ; ^UTILITY("VASD",$J,#,"E") <-external vlaues
40 ; piece 1: appointment date/time
41 ; 2: clinic
42 ; 3: status
43 ; 4: type
44 Q:'$G(DFN)
45 N VASD,VAERR
46 S VASD("F")=$$NOW^XLFDT,VASD("W")=1 ;get active/kept appts
47 D SDA^VADPT
48 Q
49KAPPT(DFN) ; Kill APPOINTMENTS multiple
50 Q:'$G(DFN)
51 N DA,DIK
52 S DA=0,DA(1)=DFN
53 F S DA=$O(^WV(790,DFN,2,DA)) Q:'DA D
54 .S DIK="^WV(790,"_DFN_",2,"
55 .D ^DIK
56 .Q
57 Q
58SAPPT(DFN) ; Set APPOINTMENTS multiple
59 Q:'$G(DFN)
60 Q:'$D(^WV(790,DFN))
61 N DA,DIC,DLAYGO,LOOP,X
62 S LOOP=0,DIC="^WV(790,"_DFN_",2,",DIC(0)="L",DA(1)=DFN,DLAYGO=790
63 I '$D(^UTILITY("VASD",$J)) D Q ;no appts passed from SDA^VADPT
64 .S X="No Future Appointments"
65 .D ^DIC
66 .Q
67 F S LOOP=$O(^UTILITY("VASD",$J,LOOP)) Q:'LOOP D
68 .S X=$G(^UTILITY("VASD",$J,LOOP,"E"))
69 .Q:X=""
70 .S X=$P(X,U,1)_" Clinic: "_$P(X,U,2)
71 .D ^DIC
72 .Q
73 Q
74KILLUG ; Kill Utility Global created by SDA^VADPT call
75 K ^UTILITY("VASD",$J)
76 Q
77IEN(WVFILE,WVALUE) ; Return ien of entry
78 ; input: WVFILE - File number
79 ; WVALUE - value of the .01 field
80 I 'WVFILE!(WVALUE="") Q 0
81 Q +$O(^WV(WVFILE,"B",WVALUE,0))
82 ;
83GADD(DFN) ; Get COMPLETE ADDRESS with ADD^VADPT
84 ; Returns VAPA array
85 Q:'$G(DFN)
86 D ADD^VADPT
87 Q
88KADD(DFN) ; Kill COMPLETE ADDRESS multiple
89 Q:'$G(DFN)
90 N DA,DIK
91 S DA=0,DA(1)=DFN
92 F S DA=$O(^WV(790,DFN,3,DA)) Q:'DA D
93 .S DIK="^WV(790,"_DFN_",3,"
94 .D ^DIK
95 .Q
96 Q
97SADD(DFN) ; Set COMPLETE ADDRESS multiple
98 Q:'$G(DFN)
99 Q:'$D(^WV(790,DFN))
100 N DA,DIC,DLAYGO,LOOP,WVERR,WVSTATE,X
101 S LOOP=0,DIC="^WV(790,"_DFN_",3,",DIC(0)="L",DA(1)=DFN,DLAYGO=790
102 I '$D(VAPA) D Q ;no address passed from ADD^VADPT
103 .S X="No Address on file"
104 .D ^DIC
105 .Q
106 ; look for confidential address
107 I $G(VAPA(12))'=1 D RA Q ;no confidential address, use regular address
108 I $P($G(VAPA(22,2)),U,3)="Y" D CC Q ;category 2 - appointments
109 I $P($G(VAPA(22,4)),U,3)="Y" D CC Q ;category 4 - medical records
110 D RA
111 Q
112RA ; get regular address
113 F LOOP=1,2,3 D
114 .S X=$G(VAPA(LOOP))
115 .Q:X=""
116 .S:$E(X)'?1N X=" "_X
117 .D ^DIC
118 .Q
119 S WVSTATE=""
120 I $P(VAPA(5),U,1) D
121 .S WVSTATE=$$GET1^DIQ(5,$P(VAPA(5),U,1),1,"E","","WVERR")
122 .Q
123 S X=VAPA(4)_", "_WVSTATE_" "_VAPA(6)
124 Q:X=", "
125 D ^DIC
126 Q
127CC ; get Confidential Communication address
128 F LOOP=13,14,15 D
129 .S X=$G(VAPA(LOOP))
130 .Q:X=""
131 .S:$E(X)'?1N X=" "_X
132 .D ^DIC
133 .Q
134 S WVSTATE=""
135 I $P(VAPA(17),U,1) D
136 .S WVSTATE=$$GET1^DIQ(5,$P(VAPA(17),U,1),1,"E","","WVERR")
137 .Q
138 S X=$P(VAPA(16),U,1)_", "_WVSTATE_" "_$P(VAPA(18),U,1)
139 Q:X=", "
140 D ^DIC
141 Q
142KVAR ; Kill off VADPT variables used
143 D KVAR^VADPT
144 Q
145ELIG(WVDFN) ; Get patient's eligibilty code.
146 ; Input: patient DFN
147 ; Output: internal^external values
148 N DFN,I,VAEL,VAERR,X,Y
149 S DFN=WVDFN
150 D ELIG^VADPT ;get elibility code
151 Q $G(VAEL(1)) ;VAEL(1)=internal^external
152 ;
153HELP(WVDA,WVA,WVB) ; Display message for eligiblity codes
154 ; WVDA - the FILE 790.02 ien
155 ; WVA - the node number where the eligibilty codes are stored
156 ; WVB - the package name associated with those eligibility codes
157 Q:'$O(^WV(790.02,WVDA,WVA,0)) ;no eligibility codes for lab data
158 N WVMSG
159 S WVMSG(1)="The ELIGIBILITY CODE(S) defined for "_WVB_" will be deleted when you"
160 S WVMSG(2)="exit and save your changes."
161 D HLP^DDSUTL(.WVMSG)
162 Q
163DELETE(WVDA) ; Delete eligibility codes, if necessary
164 ; task as a background job?
165 Q:'WVDA
166 N WVLAV,WVLSP,WVNODE,WVRAV,WVRSP,X,Y
167 S WVNODE=$G(^WV(790.02,WVDA,0))
168 Q:WVNODE=""
169 S WVRSP=$P(WVNODE,U,10) ;import mams from radiology
170 S WVRAV=$P(WVNODE,U,25) ;include all non-veterans (rad)
171 S WVLSP=$P(WVNODE,U,24) ;import tests from lab
172 S WVLAV=$P(WVNODE,U,26) ;include all non-veterans (lab)
173 ; Delete eligibility codes related to radiology if
174 ; 1) import mams from radiology = YES, or
175 ; 2) include all non-veterans (rad) = YES, or
176 ; 3) include all non-veterans (rad) = null
177 I WVRSP'=1!(WVRAV=1)!(WVRAV="") D
178 .N DA,DIK
179 .S DA(1)=WVDA,DA=0,DIK="^WV(790.02,DA(1),5,"
180 .F S DA=$O(^WV(790.02,DA(1),5,DA)) Q:'DA D ^DIK
181 .Q
182 ; Delete eligibility codes related to laboratory if
183 ; 1) import tests from lab = YES, or
184 ; 2) include all non-veterans (lab) = YES, or
185 ; 3) include all non-veterans (lab) = null
186 I WVLSP'=1!(WVLAV=1)!(WVLAV="") D
187 .N DA,DIK
188 .S DA(1)=WVDA,DA=0,DIK="^WV(790.02,DA(1),6,"
189 .F S DA=$O(^WV(790.02,DA(1),6,DA)) Q:'DA D ^DIK
190 .Q
191 Q
Note: See TracBrowser for help on using the repository browser.