source: WorldVistAEHR/trunk/r/WOMENS_HEALTH-WV/WVUTL1A.m@ 1096

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

initial load of WorldVistAEHR

File size: 5.9 KB
Line 
1WVUTL1A ;HCIOFO/JR,FT-Continuation of ^WVUTL1 (Utilities) ;4/10/01 11:29
2 ;;1.0;WOMEN'S HEALTH;**4,7,14**;Sep 30, 1998
3 ;
4 ; This routine uses the following IAs:
5 ; #1252 - $$OUTPTPR^SDUTL3 (supported)
6 ; #2483 - FILE 2, Field 1901 (private)
7 ; #2716 - $$GETSTAT^DGMSTAPI (supported)
8 ; #10035 - ^DPT(DFN,.104 (supported)
9 ; #10060 - FILE 200 fields (supported)
10 ; #10090 - FILE 4 fields (supported)
11 ;
12PRIOR() ;EP
13 ;---> CALLED FROM WV NOTIF-EDITBLK-1 TO GET VALUE AND TEXT OF
14 ;---> NOTIFICATION PRIORITY AND RESULT/REMINDER, FROM PURPOSE OF
15 ;---> NOTIFICATION WHEN FIRST DISPLAYING SCREEN.
16 ;---> REQUIRED VARIABLE: DA=IEN OF NOTIFICATION.
17 N X
18 Q:'$D(DA) "UNKNOWN"
19 Q:'$D(^WV(790.4,DA,0)) "UNKNOWN"
20 S X=$P(^WV(790.4,DA,0),U,4)
21 Q:'X "UNKNOWN"
22 Q $$PRIOR1
23 ;
24PRIOR1() ;EP
25 ;---> CALLED FROM WV NOTIF-EDITBLK-1 TO GET VALUE AND TEXT OF
26 ;---> NOTIFICATION PRIORITY FROM PURPOSE OF NOTIFICATION AS AN
27 ;---> ACTION WHEN EDITING PURPOSE OF NOTIFICATION. ALSO DISPLAY
28 ;---> WHETHER PURPOSE IS A RESULT OR A REMINDER.
29 ;---> REQUIRED VARIABLE: X=IEN IN NOTIFICATION PURPOSE FILE.
30 N R,Y,Z
31 Q:'$D(X) "UNDEFINED"
32 Q:'X "UNKNOWN"
33 Q:'$D(^WV(790.404,X,0)) "UNKNOWN"
34 S Y=$P(^WV(790.404,X,0),U,2) D
35 .I 'Y S R="UNKNOWN" Q
36 .I '$$VFIELD^DILFD(790.404,.02) S R="^DD MISSING"
37 .S R=$$EXTERNAL^DILFD(790.404,.02,"",Y)
38 S Z=$P(^WV(790.404,X,0),U,6)
39 Q:Z="" R
40 Q:Z R_", RESULT"
41 Q R_", REMINDER"
42 ;
43 ;
44NTPROC() ;EP
45 ;---> CALLED FROM WV NOTIF-EDITBLK-1(?) BLOCK TO DISPLAY PROCEDURE
46 ;---> NAME, BASED ON ACCESSION# PTR, WHEN FIRST DISPLAYING SCREEN.
47 ;---> REQUIRED VARIABLE: X=ACCESSION# OF PROCEDURE
48 N X
49 S X=$P(^WV(790.4,DA,0),U,6)
50 Q $$PROC
51 ;
52PROC() ;EP
53 ;---> DISPLAY PROCEDURE TYPE OF THIS PROCEDURE.
54 ;---> REQUIRED VARIABLE: X=IEN OF PROCEDURE IN PROC FILE #790.1.
55 N WVY,WVYY,Y,Z S WVYY="INVALID ACC# OR PTR"
56 Q:X']"" ""
57 Q:'$D(^WV(790.1,X,0)) WVYY
58 S WVY=$P(^WV(790.1,X,0),U,4)
59 Q:'WVY WVYY
60 Q:'$D(^WV(790.2,WVY,0)) WVYY
61 S Z=$P(^WV(790.2,WVY,0),U)
62 ;---> IF UNILATERAL AND LEFT/RIGHT HAS A VALUE, REPLACE "UNILATERAL"
63 ;---> WITH LEFT OR RIGHT.
64 S Y=$P(^WV(790.1,X,0),U,9)
65 S Y=$S(Y="l":"LEFT",Y="r":"RIGHT",1:"")
66 Q:Y="" Z
67 Q $P(Z," ")_" "_Y
68 ;
69PROC1() ;EP
70 ;---> DISPLAY PROCEDURE TYPE OF THIS PROCEDURE, USING DA.
71 ;---> CALLED BY WV PROC-HEADER-1, WHICH CANNOT USE X.
72 ;---> REQUIRED VARIABLE: DA=IEN OF PROCEDURE IN PROC FILE #790.1.
73 N X S X=DA
74 Q $$PROC
75PROVI(DFN) ;
76 ;---> RETURNS THE PRIMARY CARE PROVIDER
77 ;---> REQUIRED VARIABLE: DFN
78 Q:$G(DFN)'>0 "UNKNOWN"
79 N X S X=$P($G(^DPT(DFN,.104)),U)
80 S X=$S(X>0:$$GET1^DIQ(200,X,.01,"E"),1:"")
81 I X="" S X=$P($$OUTPTPR^SDUTL3(DFN),U,2)
82 S:X="" X="UNKNOWN"
83 Q X
84SCR(X) ;
85 Q:$G(X)'>0 0
86 S WVJX=$S(X>0:$P($G(^WV(790.07,X,0)),U,2),1:0)
87 Q WVJX
88QUAD(X) ;
89 Q:$TR(X,"ULR,")'="" 0
90 N TEST,CN,CNT,WVJX S WVJX=X,CN=""
91 S (CN("LL"),CN("UL"),CN("UR"),CN("LR"))="",TEST=1
92 F S CN=$O(CN(CN)) Q:CN="" I $P(WVJX,CN,2,5)[CN S WVJX=$P(WVJX,CN,1,2)_$P(WVJX,CN,3)
93 F CN=1:1:11 I $E(WVJX,CN)=","&($E(WVJX,CN+1)=",") S WVJX=$E(WVJX,1,CN)_$E(WVJX,CN+2,11) S CN=CN-1
94 F CN=1:1:4 S CNT=$P(X,",",CN) I CNT'="" I '$D(CN(CNT)) S TEST=0 Q
95 S:$E(WVJX,$L(WVJX))="," WVJX=$E(WVJX,1,$L(WVJX)-1)
96 S:$E(WVJX,1)="," WVJX=$E(WVJX,2,11)
97 S:TEST>0 TEST=TEST_"^"_WVJX
98 Q TEST
99REF ;
100 N X,Y,B,L
101 Q:$G(DA)="" S X=DA
102 S Y=X,X=$P($G(^WV(790.07,X,0)),U)
103 S L="abcdefghijklmnopqrstuvwxyz"
104 S B="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
105 S X=$TR($E(X,1,$L(X)),L,B)
106 I WVACT="SET" S ^WV(790.07,"C",X,Y)=""
107 I WVACT="KIL" K ^WV(790.07,"C",X,Y)
108 K WVACT Q
109FAC N X,Y
110 S WVJBFAC="",WVJCFAC="",WVJPCP=""
111 Q:$G(WVDFN)'>0
112 S X=$G(^WV(790,WVDFN,0))
113 S WVJBFAC=$P(X,U,25),WVJCFAC=$P(X,U,26),WVJPCP=$$PROVI(WVDFN)
114 S:WVJBFAC>0 WVJBFAC=$E($$GET1^DIQ(4,WVJBFAC,.01,"E"),1,18)
115 S:WVJCFAC>0 WVJCFAC=$E($$GET1^DIQ(4,WVJCFAC,.01,"E"),1,18)
116 Q
117RAXS(DA) ;
118 I $G(DA)'>0 Q 0
119 S WVJJ0=$G(^WV(790.1,DA,0))
120 I '$D(WVJJ0) Q 0
121 I "^BU^MB^MU^MS^"'[$E(WVJJ0,1,2) Q 0
122 I $P(WVJJ0,U,15)="" Q 0
123 Q 1
124FACIL(DFN,TYP) ;Gets Treatment Facility, if typ="C" for Cervix, "B" for Breast
125 N X,Y
126 S Y=""
127 I $G(DFN)'>0 Q Y
128 S X=$G(^WV(790,DFN,0))
129 S:TYP="B" Y=$P(X,U,25) S:TYP="C" Y=$P(X,U,26)
130 S:Y>0 Y=$E($$GET1^DIQ(4,Y,.01,"E"),1,18)
131 Q Y
132MST(WVDFN) ;Gets Military Sexual Trauma
133 I $G(WVDFN)'>0 Q ""
134 N X,WVMST
135 S WVMST=$$GETSTAT^DGMSTAPI(WVDFN)
136 S WVMST=$S($P(WVMST,U,6)]"":$P(WVMST,U,6),1:"")
137 S:WVMST="" WVMST="Unknown, not screened"
138 I $E($$VET(WVDFN))'="Y" S WVMST="<N/A Not a Veteran>"
139 Q WVMST
140 ;
141SC(WVJ) ;Screen called from File 790.02 to elim. inactive from selectable
142 I $G(XQY0)["WV ADD/EDIT CASE MANAGERS" Q 1
143 I $G(WVJOPEN)>0 Q 1
144 N WVINACT
145 S WVINACT=$P($G(^WV(790.01,+WVJ,0)),U,2) ;date inactivated
146 I WVINACT>0,WVINACT<$G(DT) Q 0
147 Q 1
148LOOK(WVJ) ;Display select fields with lookup on 790, not file#2 Identif.
149 Q:WVJ'>0
150 N DIC,DA,DR,DIQ,Y
151 S DIC="^WV(790,",DA=WVJ,DIQ="WVJAR(",DIQ(0)="E"
152 S DR=".06;.1;.16" D EN^DIQ1
153 S WVJ=WVJAR(790,WVJ,.06,"E")_" "_WVJAR(790,WVJ,.1,"E")
154 K WVJAR
155 Q WVJ
156LOOKL(WVJ) ;
157 N Y,WVX,WVP,WVY,WVDT,WVP,X,WVDTS,WVMARK
158 S X1=DT,X2=-30 D C^%DTC S WVDTS=X
159 S WVX="" F S WVX=$O(^WV(790.3,"C",+WVJ,WVX)) Q:WVX'>0 D
160 .S WVY=$G(^WV(790.3,WVX,0)),WVDT=+WVY,WVP=$P(WVY,U,3)
161 .Q:WVDT'>WVDTS S WVMARK=1
162 .S Y=WVDT D DD^%DT S WVDT=Y
163 .;S WVP=$S(WVP'>0:"",1:$P($G(^WV(790.1,WVP,0)),U,4))
164 .S:WVP'="" WVP=$P($G(^WV(790.2,WVP,0)),U)
165 .W !?32,WVDT,?47,WVP
166 W:$G(WVMARK)=1 !
167 Q
168RUNDT(WVY) ;Get and format run date for various reports
169 ; Center when WVY="C"
170 N Y,WVJ
171 I $D(WVJRNOW) Q WVJRNOW
172 D NOW^%DTC S Y=% D DD^%DT
173 S Y=$E(Y,1,12)_" "_$E(Y,14,18)
174 S:$L(Y)'>10 Y=""
175 S (WVJRNOW,WVJ)="Run Date: "_Y
176 I $G(WVY)="C" S (WVJ,WVJRNOW)=" "_WVJRNOW
177 Q WVJ
178 ;
179LINE ; Called from the WV LINE FOR MENUS option. That option is merely a
180 ; place holder in the menu and used for visual purposes. This is
181 ; entry point does nothing.
182 Q
183VET(DFN) ; Check if patient is a veteran.
184 N WVETERAN
185 S WVETERAN=$$GET1^DIQ(2,DFN,1901,"I")
186 Q $S(WVETERAN="Y":"Yes",WVETERAN="N":"No",1:"Unknown")
187 ;
188CST(WVDFN) ; Return Civilian Sexual Trauma value
189 Q $$GET1^DIQ(790,+WVDFN,.28,"E")
190 ;
Note: See TracBrowser for help on using the repository browser.