source: WorldVistAEHR/trunk/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCEDT4.m@ 1006

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

initial load of WorldVistAEHR

File size: 8.8 KB
Line 
1GMRCEDT4 ;SLC/DCM,JFR - UTILITIES FOR EDITING FIELDS ;6/25/03 11:42
2 ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,15,22,33**;DEC 27, 1997
3 ;
4 ; This routine invokes IA #3991
5 ;
6 Q
7EDITFLD(GMRCO) ;edit field in file 123.
8 ;GMRCO=IEN of consult record in file 123
9 N DIR,X,Y,GMRCSS,GMRCPROC,GMRCPROC,GMRCURG,GMRCPL,GMRCREND,GMRCY,GMRCX
10 N GMRCMSG,GMRCTAG
11 I $S($P(^GMR(123,GMRCO,0),"^",12)'=13:1,$D(GMRCRSUB):1,1:0) D Q
12 .S GMRCMSG="This consult is no longer editable." D EXAC^GMRCADC(GMRCMSG)
13 S GMRCMSG=$$EDRESOK^GMRCEDT2(GMRCO)
14 I '+GMRCMSG D EXAC^GMRCADC($P(GMRCMSG,U,2)) Q
15 I $$PDOK(GMRCO)
16 S DIR(0)="LAO^1:8",DIR("A")="Select the fields to edit: "
17 D ^DIR I $D(DIRUT) Q
18 I $P(Y,",")<1 Q
19 S GMRCY=Y
20 F GMRCX=1:1:8 S GMRCTAG=$P(GMRCY,",",GMRCX) Q:'GMRCTAG D
21 . D SETUP
22 . D @GMRCTAG
23 . K DIROUT,DIRUT,DTOUT,DUOUT
24 . D EN^GMRCEDT1(+GMRCO),INIT^GMRCEDIT
25 Q
26SETUP ;get info needed for edit (save global reads)
27 S:$D(GMRCEDT(1)) GMRCSS=GMRCEDT(1)
28 I '$D(GMRCSS) S GMRCSS=$P(^GMR(123,+GMRCO,0),U,5),GMRCSS=GMRCSS_U_$P(^GMR(123.5,GMRCSS,0),U)
29 S:$D(GMRCED(1)) GMRCPROC=GMRCED(1)
30 I '$D(GMRCPROC) S GMRCPROC=+$P(^GMR(123,+GMRCO,0),U,8),GMRCPROC=GMRCPROC_U_$$GET1^DIQ(123.3,+GMRCPROC,.01)
31 S:$D(GMRCED(2)) GMRCREND=GMRCED(2)
32 I '$D(GMRCREND) S GMRCREND=$P(^GMR(123,GMRCO,0),U,18),GMRCREND=GMRCREND_U_$S(GMRCREND="I":"In",1:"Out")_"patient"
33 S:$D(GMRCED(3)) GMRCURG=GMRCED(3)
34 I '$D(GMRCURG) S GMRCURG=$P(^GMR(123,+GMRCO,0),U,9),GMRCURG=GMRCURG_U_$$GET1^DIQ(101,+GMRCURG,1)
35 S:$D(GMRCED(4)) GMRCPL=GMRCED(4)
36 I '$D(GMRCPL) S GMRCPL=$P(^GMR(123,+GMRCO,0),U,10),GMRCPL=GMRCPL_U_$$GET1^DIQ(101,+GMRCPL,1)
37 Q
3801 ;edit TO SERVICE
39 N I,PROCSERV,DIR,X,Y
40 I $G(GMRCPROC) D Q:'PROCSERV
41 . N I S I=0,PROCSERV=0 F S I=$O(^GMR(123.3,+GMRCPROC,2,"B",I)) Q:'I D
42 .. S PROCSERV(I)="",PROCSERV=PROCSERV+1
43 . I PROCSERV=1 W !,"Only one SERVICE can perform this procedure.",!
44 S DIR(0)="PA^123.5:EMQ"
45 I $G(PROCSERV) D
46 . I $D(PROCSERV(+GMRCSS)) Q
47 . S DIR("B")=$$GET1^DIQ(123.5,$O(PROCSERV(0)),.01)
48 I '$D(DIR("B")) S DIR("B")=$P(GMRCSS,U,2)
49 S DIR("A")="Select the Service to perform this request: "
50 S DIR("S")="I $P(^(0),U,2)<1"
51 I +$G(GMRCPROC) S DIR("S")=DIR("S")_",$D(PROCSERV(+Y))"
52 S DIR("??")="^D LISTALL^GMRCASV"
53 D ^DIR I $D(DUOUT)!($D(DTOUT)) Q
54 I Y<1!(+Y=+GMRCSS) W !,$$NOCHG,! Q
55 S GMRCEDT(1)=Y,GMRCSS=Y
56 Q
571 ;edit Procedure
58 W !,$C(7),"The procedure associated with a request may not be changed."
59 W !,"Place a new request if a different procedure is desired"
60 H 2
61 Q
622 ;edit service rendered
63 N DIR,X,Y,GMRCURSV,GMRCPLSV,GMRCED4,GMRCED5,RENDED
64 S DIR(0)="S:A^I:Inpatient;O:Outpatient",DIR("B")=$P(GMRCREND,U,2)
65 S DIR("A")="Service to be performed Inpatient or Outpatient: "
66 D ^DIR I $D(DUOUT)!($D(DTOUT)) W !,$$NOCHG,! Q
67 I Y'=$P(GMRCREND,U) S RENDED=Y_U_Y(0)
68 I '$D(RENDED) Q
69 I '$$VALIDUR(GMRCURG,RENDED,+$G(GMRCPROC)) D I '$D(RENDED) Q
70 . N GMRCREND,CHGIO S GMRCREND=RENDED
71 . W $C(7),!!,"The urgency of this request is no longer valid.",!
72 . S GMRCURSV=GMRCURG S:$D(GMRCED(3)) GMRCED3=GMRCED(3)
73 . S CHGREND="" D 3
74 . I '$$VALIDUR(GMRCURG,RENDED,+$G(GMRCPROC)) D Q
75 .. W !,$C(7),"Unable to change the way service is rendered.",!
76 .. K RENDED S GMRCURG=GMRCURSV S:$D(GMRCED3) GMRCED(3)=GMRCED3
77 I '$$VALIDPL(GMRCPL,RENDED) D I '$D(RENDED) Q
78 . N GMRCREND,CHGREND S GMRCREND=RENDED
79 . W $C(7),!!,"The Place of Consultation is no longer valid.",!
80 . S GMRCPLSV=GMRCPL S:$D(GMRCED(4)) GMRCED4=GMRCED(4) S CHGREND="" D 4
81 . I '$$VALIDPL(GMRCPL,RENDED) D Q
82 .. W !,$C(7),"Unable to change the way service is rendered.",!
83 .. K RENDED S GMRCPL=GMRCPLSV S:$D(GMRCED4) GMRCED(4)=GMRCED4
84 .. S:$D(GMRCURSV) GMRCURG=GMRCURSV
85 .. S:$D(GMRCED3) GMRCED(3)=GMRCED3
86 S (GMRCREND,GMRCED(2))=RENDED
87 Q
883 ;edit urgency
89 N X,Y,XQORM
90 I $P(GMRCREND,U)="O" S Y=$$FIND1^DIC(101,"","QX","GMRCURGENCYM - OUTPATIENT")
91 I '$D(Y) D ;inpatient
92 .I '$G(GMRCPROC) S Y=$$FIND1^DIC(101,"","QX","GMRCURGENCYM CSLT - INPATIENT") Q
93 .S Y=$$FIND1^DIC(101,"","QX","GMRCURGENCYM REQ - INPATIENT")
94 I 'Y W !,$C(7),"Unable to change urgency." Q
95 S XQORM=+Y_";ORD(101,",XQORM(0)="1A\",XQORM("A")="Urgency: "
96 S XQORM("^^NO")=0
97 S:'$D(CHGREND) XQORM("B")=$P($G(GMRCURG),U,2)
98 D EN^XQORM
99 Q:Y'>0
100 I $P(Y(1),U,2)'=+GMRCURG D
101 . S GMRCED(3)=$P(Y(1),U,2)_U_$P(Y(1),U,3),GMRCURG=GMRCED(3)
102 Q
1034 ;edit place of CSLT
104 N X,Y,XQORM
105 S Y=$$FIND1^DIC(101,,"QX","GMRCPLACEM - "_$$UP^XLFSTR($P(GMRCREND,U,2))) Q:'Y
106 S XQORM=Y_";ORD(101,"
107 S XQORM(0)="1AR\",XQORM("A")="Place of Consultation: ",XQORM("NO^^")=""
108 S:'$D(CHGREND) XQORM("B")=$P($G(GMRCPL),U,2)
109 D EN^XQORM
110 Q:Y'>0
111 I $P(Y(1),U,2)'=+GMRCPL D
112 . S GMRCED(4)=$P(Y(1),U,2)_U_$P(Y(1),U,3),GMRCPL=GMRCED(4)
113 Q
1145 ;edit ATTN person
115 N X,Y,DIR
116 S DIR(0)="PAO^200:EQM",DIR("A")="Select ATTENTION person: "
117 S DIR("B")=$$GET1^DIQ(200,+$P(^GMR(123,+GMRCO,0),U,11),.01)
118 S:$D(GMRCED(5)) DIR("B")=$P($G(GMRCED(5)),U,2)
119 K:'$L(DIR("B")) DIR("B")
120 D ^DIR I $D(DTOUT)!($D(DUOUT)) Q
121 I $G(DIR("B"))=$P(Y,U,2) Q
122 S GMRCED(5)=$S(Y=-1:"",1:Y)
123 I GMRCED(5)="" W !,?5,"<DELETED>",!
124 Q
1256 ;edit prov. DX
126 N X,Y,DIC,DIR,PRMPT
127 S PRMPT=$$PROVDX^GMRCUTL1(+$P(^GMR(123,+GMRCO,0),U,5))
128 I $P(PRMPT,U,2)="F" D
129 . S DIR(0)="FA^2:180",DIR("A")="Provisional Diagnosis: "
130 . I $P(PRMPT,U)'="R" S $P(DIR(0),U)="FAO"
131 . S:$D(GMRCED(6)) DIR("B")=$P(GMRCED(6),U)
132 . I '$D(DIR("B")) S DIR("B")=$G(^GMR(123,+GMRCO,30))
133 . K:'$L(DIR("B")) DIR("B")
134 . D ^DIR Q:$D(DTOUT)!($D(DUOUT)) Q:Y=$G(DIR("B"))
135 . I '$L(Y) W !,?5,"<DELETED>",!
136 . S GMRCED(6)=Y
137 I $P(PRMPT,U,2)="L" D
138 . N DIR,X,Y,DTOUT,DUOUT,VAL
139 . I $D(GMRCED(6)) D
140 .. I '$L($P(GMRCED(6),U,2)) S DIR("B")=$P(GMRCED(6),U) Q
141 .. S DIR("B")=$P(GMRCED(6),U)_" ("_$P(GMRCED(6),U,2)_")"
142 . I '$D(DIR("B")) S DIR("B")=$G(^GMR(123,GMRCO,30))
143 . K:'$L(DIR("B")) DIR("B")
144 . S DIR("?")="Enter a code or term for the provisional diagnosis."
145 . S DIR("A")="Provisional Diagnosis: "
146 . S DIR(0)="FA"_$S($P(PRMPT,U)'="R":"O",1:"")_"^1:180"
147 . D ^DIR
148 . I $D(DTOUT)!($D(DUOUT)) Q
149 . I '$L(Y) W !,?5,"<DELETED>",! S GMRCED(6)="" Q
150 . I Y=$G(DIR("B")) Q
151 . I $E(Y,1)=" " W !,"Leading space not allowed, no change." Q
152 . S VAL=$$LEXLKUP(Y)
153 . I '$L(VAL),$P(PRMPT,U)="R" W !,"Prov. DX required. No change." Q
154 . I VAL=$G(^GMR(123,GMRCO,30)) W !,"No change." Q
155 . I ($P(VAL,U)_" ("_$P(VAL,U,2)_")")=$G(^GMR(123,GMRCO,30)) D Q
156 .. W !,"No change."
157 . I '$L(VAL) W !,?5,"<DELETED>",!
158 . S GMRCED(6)=VAL
159 Q
160 ;
161LEXLKUP(GMRCX) ; run input through the Lexicon
162 ;
163 N DIC,X,Y,DUOUT,DTOUT
164 D CONFIG^LEXSET("ICD","ICD",DT)
165 S DIC="^LEX(757.01,",DIC(0)="EQM",DIC("B")=GMRCX,X=GMRCX
166 D ^DIC
167 I $D(DTOUT)!($D(DUOUT))!($G(Y)<1) Q ""
168 Q $P(Y,U,2)_U_Y(1)
169 ;
1707 ;edit Reason for Request
171 N DIC,DIWESUB,DWLW,DWPK
172 I $D(^TMP("GMRCED",$J,20)) M ^TMP("GMRCEDSV",$J,20)=^TMP("GMRCED",$J,20)
173 I '$D(^TMP("GMRCED",$J,20)) M ^TMP("GMRCED",$J,20)=^GMR(123,+GMRCO,20)
174 S DIC="^TMP(""GMRCED"",$J,20,",DIWESUB="Reason for Request"
175 W !,"Editing Reason for Request:",!
176 S DWPK=1,DWLW=74 D EN^DIWE
177 I '$$DIFFRFR($D(^TMP("GMRCEDSV",$J,20))) D Q
178 . I $D(^TMP("GMRCEDSV",$J,20)) K ^TMP("GMRCEDSV",$J,20) Q
179 . K ^TMP("GMRCED",$J,20)
180 K ^TMP("GMRCEDSV",$J,20)
181 I '$D(^TMP("GMRCED",$J,20))!('$O(^TMP("GMRCED",$J,20,0))) D
182 . N GMRCMSG
183 . S GMRCMSG="Unable to delete Reason for Request (REQUIRED)"
184 . D EXAC^GMRCADC(GMRCMSG)
185 . K ^TMP("GMRCED",$J,20)
186 Q
1878 ;add comment
188 N DIC,DIWEPSE,DIWESUB,DWLW,DWPK
189 I $D(^TMP("GMRCED",$J,40)) D
190 . W !,"An unsaved comment exists. You may edit this comment.",!
191 . S DIWEPSE=1
192 S DIC="^TMP(""GMRCED"",$J,40,",DIWESUB="New Comment"
193 W !,"Adding new comment:",!
194 S DWPK=1,DWLW=74 D EN^DIWE
195 I '$O(^TMP("GMRCED",$J,40,0)) K ^TMP("GMRCED",$J,40)
196 Q
197DIFFRFR(SAVED) ;edited reason for req same as original?
198 N I,DIFF
199 I SAVED,$P($G(^TMP("GMRCED",$J,20,0)),U,3,4)'=$P($G(^TMP("GMRCEDSV",$J,20,0)),U,3,4) S DIFF=1 Q 1
200 I 'SAVED,$P($G(^TMP("GMRCED",$J,20,0)),U,3,4)'=$P($G(^GMR(123,+GMRCO,20,0)),U,3,4) S DIFF=1 Q 1
201 I SAVED S I=0 F S I=$O(^TMP("GMRCED",$J,20,I)) Q:'I!($D(DIFF)) D
202 . I ^TMP("GMRCED",$J,20,I,0)=$G(^TMP("GMRCEDSV",$J,20,I,0)) Q
203 . S DIFF=1
204 . Q
205 I 'SAVED S I=0 F S I=$O(^TMP("GMRCED",$J,20,I)) Q:'I!($D(DIFF)) D
206 . I ^TMP("GMRCED",$J,20,I,0)'=$G(^GMR(123,+GMRCO,20,I,0)) S DIFF=1
207 . Q
208 Q $G(DIFF)
209VALIDPL(PL,REND) ; place still valid?
210 N PLMENU
211 S PLMENU=$S($P(REND,U)="I":"IN",1:"OUT")
212 S PLMENU="GMRCPLACEM - "_PLMENU_"PATIENT"
213 S PLMENU=$$FIND1^DIC(101,,"QX",PLMENU) Q:PLMENU'>1 0
214 Q $D(^ORD(101,PLMENU,10,"B",+PL))
215VALIDUR(URG,REND,PROC) ;urgency still valid?
216 N URMENU
217 I $P(REND,U)="I" D
218 .I 'PROC S URMENU="GMRCURGENCYM CSLT - INPATIENT" Q
219 .S URMENU="GMRCURGENCYM REQ - INPATIENT" Q
220 I '$D(URMENU) S URMENU="GMRCURGENCYM - OUTPATIENT"
221 S URMENU=$$FIND1^DIC(101,,"QX",URMENU) Q:URMENU<0 0
222 Q $D(^ORD(101,URMENU,10,"B",+URG))
223 Q
224NOCHG() ;no changes made
225 Q "No Changes made!"
226PDOK(GMRCDA) ;check validity of Prov. DX code for active status
227 N MSG
228 I '$L($G(^GMR(123,GMRCDA,30.1))) Q 1
229 I +$$STATCHK^ICDAPIU(^GMR(123,GMRCDA,30.1),DT) Q 1 ;code still active
230 S MSG="The provisional DX code must be edited before this request"
231 S MSG=MSG_" may be resubmitted."
232 D EN^DDIOL(MSG,,"!!")
233 Q 0
Note: See TracBrowser for help on using the repository browser.