source: WorldVistAEHR/trunk/r/WOMENS_HEALTH-WV/WVPROC.m@ 724

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

initial load of WorldVistAEHR

File size: 6.4 KB
Line 
1WVPROC ;HCIOFO/FT,JR - WV ADD/EDIT WV PROCEDURE; ;5/10/99 10:22
2 ;;1.0;WOMEN'S HEALTH;**3,6**;Sep 30, 1998
3 ;; Original routine created by IHS/ANMC/MWR
4 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
5 ;; CALLED BY VARIOUS OPTIONS TO ADD/EDIT PROCEDURES.
6 ;
7 ;
8ADDNEW ;EP
9 ;---> CALLED BY OPTION: "WV ADD A NEW PROCEDURE".
10 D SETVARS^WVUTL5 S WVPOP1=0
11 N DA,DIC,DIE,Y
12 F D Q:WVPOP1
13 .D NEW
14 .Q:WVPOP
15 .D EDIT2^WVPROC1(DA,.WVPOP)
16 .Q:WVPOP
17 .D PCDVARS^WVUTL3(DA,1)
18 .D NORMAL^WVPROC1
19 D EXIT
20 Q
21 ;
22EXIT ;EP
23 D KILLALL^WVUTL8
24 Q
25 ;
26 ;
27NEW ;EP
28 ;---> SELECT A PATIENT.
29 D SETVARS^WVUTL5 K DIC
30 D TITLE^WVUTL5("ADD A NEW PROCEDURE")
31NEWNT ;EP
32 ;---> ENTER NEW WITHOUT A TITLE (ALLOWS OTHER TITLES, E.G., HISTORICAL)
33 ;---> LOOKUP AND SELECT PATIENT FROM WV PATIENT FILE.
34 ; Quit if no default case manager
35 I '$$DCM^WVUTL9(DUZ(2)) D NODCM^WVUTL9 S (WVPOP,WVPOP1)=1 Q
36 D PATLKUP^WVUTL8(.Y,"ADD")
37 I Y<0 S (WVPOP,WVPOP1)=1 Q
38 S WVDFN=+Y
39 ;
40NEW1 ;EP
41 ;---> ADD A NEW PROCEDURE.
42 ;---> PATIENT SELECTED ALREADY BUT NOT PROCEDURE.
43 ;---> REQUIRED VARIABLE: WVDFN
44 ;
45 ;---> NOW SELECT PROCEDURE TYPE FROM WV PROCEDURE TYPE FILE.
46 N A,WVPCDN,S
47 S A=" Select PROCEDURE: "
48 ;---> SCREEN: ACTIVE FIELD CAN BE "YES" OR NULL, BUT NOT "NO".
49 S S="I $P($G(^WV(790.02,DUZ(2),Y)),U)'=0"
50 D DIC^WVFMAN(790.2,"QEMA",.Y,A,"PAP SMEAR",S,"",.WVPOP)
51 Q:Y<0
52 ;---> WVPCDN=IEN OF PROCEDURE TYPE, FILE 790.2.
53 S WVPCDN=+Y
54 ;
55 ;---> IF IT'S A UNILATERAL MAMMOGRAM, PROMPT FOR LEFT OR RIGHT.
56 S WVLFRT=""
57 I WVPCDN=26 D I $D(DIRUT) S WVPOP=1 Q
58 .N DIR
59 .S DIR("?")=" Select LEFT or RIGHT for this Unilateral Mammogram."
60 .S DIR(0)="SAM^l:LEFT;r:RIGHT",DIR("A")=" LEFT OR RIGHT: "
61 .D ^DIR K DIR
62 .Q:$D(DIRUT)
63 .S WVLFRT=Y
64 ;
65 ;---> IF IT'S A COLPOSCOPY, PROMPT FOR PAP THAT INITIATED IT.
66 S WVPPAP=""
67 I WVPCDN=2 D Q:WVPOP
68 .W !!?3,"Select the PAP Smear that initiated this Colposcopy."
69 .N A,S
70 .S DIC("?",1)="If a previous abnormal PAP Smear was the reason for"
71 .S DIC("?")="this Colposcopy, enter the Accession# of that PAP here."
72 .S A=" PAP Smear: ",S="D PAPSCRN^WVUTL2"
73 .D DIC^WVFMAN(790.1,"QEMA",.Y,A,"",S,"",.WVPOP)
74 .Q:Y<0
75 .;---> WVPPAP=IEN OF PREVIOUS PAP IN WV PROCEDURE FILE 790.1.
76 .S WVPPAP=+Y
77 ;
78 ;---> ASK DATE, CHECK FOR DUPLICATE PROCEDURE ON SAME DATE.
79 D DATECHK Q:WVPOP
80 D NEW2(WVDFN,WVPCDN,WVPCDT,"",WVPPAP,.DA,.WVERROR)
81 Q
82 ;
83NEW2(DFN,PCDIEN,DATE,DRSTRG,PREVPAP,DA,ERROR) ;EP
84 ;---> ADD A NEW PROCEDURE.
85 ;---> PATIENT AND PROCEDURE ALREADY SELECTED.
86 ;---> NOW GENERATE ACCESSION# FOR WV PROCEDURE FILE ENTRY.
87 ;---> REQUIRED VARIABLES: DFN=IEN IN WV PATIENT FILE
88 ;---> PCDIEN=IEN OF PROCEDURE TYPE (#790.2).
89 ;
90 S X=$$ACCSSN^WVUTL5(PCDIEN) N DIC
91 I X']"" D Q
92 .S ERROR=-1
93 .Q:$D(ZTQUEUED) ;quit if a background (tasked) job
94 .W !!?5,*7,"UNABLE TO GENERATE ACCESSION#. CONTACT YOUR SITE MANAGER."
95 .D DIRZ^WVUTL3
96 .Q
97 ;
98 I $G(DRSTRG)']"" D
99 .;---> DEFAULTS: DATE OF PROCEDURE IS TODAY, STATUS IS OPEN.
100 .S DRSTRG=".02////"_DFN_";.04////"_PCDIEN
101 .S DRSTRG=DRSTRG_";.09///"_$S($D(WVLFRT):WVLFRT,1:"")_";.12///"_DATE
102 .S DRSTRG=DRSTRG_";.14///o"
103 .S DRSTRG=DRSTRG_";.18////"_DUZ_";.19///T;.3////"_$G(PREVPAP)
104 .S DRSTRG=DRSTRG_";.34////"_$G(DUZ(2))
105 ;
106 D FILE^WVFMAN(790.1,DRSTRG,"ML",X,790,.Y)
107 ;---> IF Y<0, CHECK PERMISSIONS.
108 I Y<0 D Q
109 .S ERROR=Y
110 .Q:$D(ZTQUEUED) ;quit if a background (tasked) job
111 .W !?5,*7,"UNABLE TO CREATE NEW PROCEDURE."
112 .D DIRZ^WVUTL3 S WVPOP=1
113 .Q
114 S DA=+Y
115 Q
116 ;
117 ;
118EDIT ;EP
119 ;---> CALLED BY OPTION: "WV EDIT PROCEDURE".
120 ;---> EDIT AN EXISTING PROCEDURE.
121 D TITLE^WVUTL5("EDIT A PROCEDURE")
122 D LKUPPCD(.Y)
123 Q:Y<0
124LT ; Called from WVLABADD routine to immediately edit a procedure created
125 ; from a lab test.
126 ;---> DA=IEN OF PROCEDURE IN PROCEDURE FILE 790.1.
127 S DA=+Y
128 I $P($G(^WV(790.1,+DA,0)),U,15)]"" D ^WVRADWP
129 I $P($G(^WV(790.1,+DA,2)),U,17)]"" D
130 .D ^WVLABWP
131 .Q:'$D(^TMP("WVLAB",$J))
132 .S WVLOOP=0
133 .F S WVLOOP=$O(^TMP("WVLAB",$J,WVLOOP)) Q:WVLOOP'>0 D
134 ..S ^WV(790.1,DA,9,WVLOOP,0)=$G(^TMP("WVLAB",$J,WVLOOP,0)) S WVLOOP(1)=WVLOOP
135 ..Q
136 .S ^WV(790.1,DA,9,0)="^^"_$G(WVLOOP(1))_"^"_$G(WVLOOP(1))
137 .K ^TMP("WVLAB",$J)
138 .Q
139 D EDIT2^WVPROC1(DA,.WVPOP) Q:WVPOP!($D(WVNOFOL))
140 D EX^WVRADWP
141 D PCDVARS^WVUTL3(DA,1)
142 D NORMAL^WVPROC1
143 D EXIT
144 Q
145 ;
146 ;
147HISTORIC ;EP
148 ;---> CALLED BY OPTION: "WV ADD AN HISTORICAL PROCEDURE".
149 ;---> ADD HISTORICAL PROCEDURES (NO PROVIDER, WARD/CLINIC, FACILITY).
150 D SETVARS^WVUTL5 S WVPOP1=0 N DA,DIE,Y
151 F D Q:WVPOP1
152 .D TITLE^WVUTL5("ENTER HISTORICAL DATA")
153 .D NEWNT W !
154 .Q:(WVPOP!('$G(DA)))
155 .S WVPN=$P(^WV(790.1,DA,0),U,4)
156 .S DR=".05;.08;.1;.14////c"
157 .D DIE^WVFMAN(790.1,DR,DA,.WVPOP)
158 D EXIT
159 Q
160 ;
161 ;
162LABEDIT ;EP
163 ;---> CALLED BY OPTION: "WV LAB EDIT PROCEDURE".
164 S WVNOFOL=1 D EDIT,EXIT
165 Q
166 ;
167 ;
168RADMOD(DA) ;EP
169 ;---> MODIFY A PROCEDURE THAT WAS IMPORTED FROM RADIOLOGY AND
170 ;---> HAS BEEN CHANGED.
171 ;---> DA=IEN OF PROCEDURE IN WV PROCEDURE FILE #790.1.
172 Q:'$G(DA)
173 S DR=".13////"_DT_";.14////o"
174 D DIE^WVFMAN(790.1,DR,DA,.WVPOP)
175 Q
176 ;
177 ;
178LKUPPCD(Y) ;EP
179 ;---> LOOKUP A PROCEDURE.
180 N A
181 D SETVARS^WVUTL5
182 S A="Select ACCESSION# or PATIENT NAME: "
183 D DIC^WVFMAN(790.1,"QEMA",.Y,A,"","","",.WVPOP)
184 Q
185 ;
186DATECHK ;EP
187 ;---> PROMPT FOR DATE, CHECK FOR DUPLICATE PROCEDURE ON SAME DATE.
188 N WVNEW,DIR,DIRUT,N,Y S WVPOP=0
189 S DIR("?",1)=" Enter the date on which this procedure was performed:"
190 S DIR("?")=" (NOTE: Dates in the future may NOT be entered.)"
191 S DIR(0)="DA^0:DT:EX",DIR("A")=" Select DATE: ",DIR("B")="TODAY"
192 D ^DIR K DIR
193 I Y<1 S WVPOP=1 Q
194 S WVPCDT=Y D DD^%DT W " ",Y
195 S N=0,WVNEW=0
196 F S N=$O(^WV(790.1,"C",WVDFN,N)) Q:('N)!(WVPOP)!(WVNEW) D
197 .S Y=^WV(790.1,N,0)
198 .;---> QUIT IF NOT THE SAME PROCEDURE TYPE.
199 .Q:$P(Y,U,4)'=WVPCDN
200 .;---> QUIT IF NOT THE SAME PROCEDURE DATE.
201 .Q:$P(Y,U,12)'=WVPCDT
202 .;---> QUIT IF THIS PROCEDURE HAS A RESULT/DIAG OF "ERROR/DISREGARD".
203 .Q:$P(Y,U,5)=8
204 .N WVPN S WVPN=$P(^WV(790.2,$P(Y,U,4),0),U)
205 .W !!?5,"A ",WVPN," already exists for this patient on this date,"
206 .W !?5,"with an Accession# of ",$P(Y,U)
207 .W ". You may edit that procedure by"
208 .W !?5,"calling up ",$P(Y,U)," under the ""Edit a Procedure"" option."
209 .W !?5,"Or you may enter another ",WVPN," for this patient"
210 .W !?5,"on this date."
211 .W !!?5,"Do you REALLY want to add another ",WVPN," for this patient"
212 .W !?5,"on this date?"
213 .S DIR("?")=" Enter NO to avoid adding another "_WVPN
214 .S DIR("?")=DIR("?")_" on this date."
215 .S DIR(0)="Y",DIR("A")=" Enter Yes or No",DIR("B")="NO"
216 .D ^DIR K DIR
217 .I $D(DIRUT)!('Y) S WVPOP=1 Q
218 .S WVNEW=1
219 Q
220 ;
221ERROR1 ;EP
222 W !!?10,*7,"NEW PROCEDURE ENTRY FOR THIS PATIENT FAILED."
223 Q
Note: See TracBrowser for help on using the repository browser.