source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29CA.m@ 619

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

initial load of WorldVistAEHR
File size: 7.9 KB
Line 
1RMPR29CA ;OI-HINES/HNC,SPS -WORK ORDER SUSPENSE RPC;12/27/2004
2 ;;3.0;PROSTHETICS;**75,122,142**;Feb 09, 1996;Build 2
3A1(RMIE68,RMPRDUZ,RMSUSTAT,RMPR6641,RMPRTXT) ;roll and scroll entry point
4 G A2
5EN(RESULTS,RMIE68,RMPRDUZ,RMSUSTAT,RMPR6641,RMPRTXT) ;RPC entry point
6A2 ;
7 S RESULTS(0)="",STP=0
8 K ^TMP($J)
9 ;
10CONT ;RMSUSTAT is status 1=complete or 0=initial note or 2=pending (incomplete)
11 ;3=cancel or 4=cancel and clone
12 S RMIE=0
13 F S RMIE=$O(^RMPR(664.1,RMPR6641,2,RMIE)) Q:RMIE'>0 D Q:STP=1
14 .S RMIE60=$P(^RMPR(664.1,RMPR6641,2,RMIE,0),U,5) Q:'RMIE60
15 .S ^TMP($J,RMIE60)=""
16 .D FD
17 .I STP=1 Q
18 .D UPD
19 I STP=1 G EXIT
20 I RMSUSTAT=1 D CNOTE
21 I RMSUSTAT=0 D INOTE,FD
22 I RMSUSTAT=2 D ONOTE,FD
23 I RMSUSTAT=3 D CANOTE^RMPR29CB
24 I RMSUSTAT=4 D CANOTE^RMPR29CB
25 ;set status
26 G EXIT
27CNOTE ;(#12) COMPLETION NOTE
28 ;set file 668
29 ;^RMPR(668,D0,4,0)=^668.012^^
30 ;if status is close, or 1
31 ;RMPRTXT ;load into field #12
32 ;^RMPR(668,D0,4,D1,0)
33 ;
34 ;Update file 664.1 on Close out
35 I +$P(^RMPR(664.1,RMPR6641,0),U,16)'>0 S $P(^(0),U,16)=DUZ,$P(^(7),U,1)=DT,$P(^(7),U,3)=DUZ
36 S DIE="^RMPR(664.1,",DA=RMPR6641
37 S DR="16////^S X=""C"";22////^S X=DUZ;23///^S X=DT" D ^DIE
38 K DR,DA,DIE
39 S RMIE=0
40 F S RMIE=$O(^RMPR(664.1,RMPR6641,2,RMIE)) Q:RMIE'>0 D
41 .S DIE="^RMPR(664.2,",DA=$P($G(^RMPR(664.1,RMPR6641,2,RMIE,0)),U,6)
42 .Q:DA'>0
43 .S DR="8////^S X=DT;9////^S X=DUZ" D ^DIE
44 .K DA,DR,DIE
45 .S DIE="^RMPR(660,",DA=$P($G(^RMPR(664.1,RMPR6641,2,RMIE,0)),U,5)
46 .Q:DA'>0
47 .S DR="8.4////^S X=DT;10////^S X=DT;50////^S X=DT" D ^DIE
48 .K DA,DR,DIE
49 S DA=RMIE68
50 D NOW^%DTC S RMPREODT=%,GMRCAD=%
51 S DIE="^RMPR(668,"
52 S DR="5////^S X=RMPREODT;6////^S X=DUZ;14///^S X=""C""" D ^DIE
53 N RMPRC
54 S L="",LN=0
55 F S L=$O(RMPRTXT(L)) Q:L="" D
56 . I 'LN D Q:RMPRC="" ;strip leading space from 1st line, ignore blank line
57 .. S RMPRC=$E($TR(RMPRTXT(L)," ","")) ;1st non space char
58 .. S:RMPRC'="" RMPRTXT(L)=$E(RMPRTXT(L),$F(RMPRTXT(L),RMPRC)-1,$L(RMPRTXT(L))) ;extract from 1st non space char to end of line
59 .. Q
60 . S LN=LN+1,^RMPR(668,RMIE68,4,LN,0)=RMPRTXT(L)
61 . Q
62 S $P(^RMPR(668,RMIE68,4,0),"^",3)=LN
63 K L,LN
64 ;S DA=RMIE68,DIK="^RMPR(668," D IX1^DIK
65 I '$P(^RMPR(668,DA,0),U,9) D
66 .S DIE="^RMPR(668,"
67 .S DR="7///^S X=""See Completion Note for Initial Action Taken."""
68 .D ^DIE
69 .S DR="10////^S X=RMPREODT;16////^S X=DUZ" D ^DIE
70 K RMPREODT
71 S GMRCO=$P(^RMPR(668,RMIE68,0),U,15)
72 I GMRCO="" S RESULTS(0)="0^Completed Manual Suspense Action. Suspense status has been updated to CLOSED." Q
73 S RMPRCOM=0
74 F S RMPRCOM=$O(^RMPR(668,RMIE68,4,RMPRCOM)) Q:RMPRCOM="" D
75 .S GMRCOM(RMPRCOM)=^RMPR(668,RMIE68,4,RMPRCOM,0)
76 I $G(GMRCOM)="" S GMRCOM="Not Noted"
77 S GMRCSF="U"
78 S GMRCA=10
79 S GMRCALF="N"
80 S GMRCATO=""
81 S (GMRCORNP,GMRCDUZ)=DUZ
82 S BDC=$$SFILE^GMRCGUIB(.GMRCO,.GMRCA,.GMRCSF,.GMRCORNP,.GMRCDUZ,.GMRCOM,.GMRCALF,.GMRCATO,.GMRCAD)
83 I +BDC=1 S RESULTS(0)=1_"^"_$P(BDC,U,2)
84 K GMRCO,GMRCA,GMRCSF,GMRCORNP,GMRCDUZ,GMRCOM,GMRCALF,GMRCATO,GMRCAD
85 I RESULTS(0)="" S RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult. Suspense status has been updated to CLOSED."
86 Q
87ONOTE ;Other note
88 ;set file 668
89 ;^RMPR(668,D0,4,0)=^668.012^^
90 ;if status is pending, and already initial action note or 0
91 ;^RMPR(668,D0,1,D1,0)= (#.01) ACTION DATE [1D]
92 ;RMPRTXT ;load into field #11, #1
93 ;^RMPR(668,D0,1,D1,1,0)=^668.111^^
94 ;
95 S RMPRDA1=RMIE68,DA(1)=RMIE68,DA=RMIE68
96 D NOW^%DTC S X=%,GMRCWHN=%
97 S DIC="^RMPR(668,"_RMIE68_",1,"
98 S DIC(0)="CQL"
99 S DIC("P")="668.011DA"
100 S DLAYGO=668
101 D ^DIC
102 I Y=-1 S RESULTS(0)="1^Error Modifying Record!" Q
103 S (DA,RMPRDA2)=+Y
104 K DIE,DR,Y
105 N RMPRC
106 S L="",LN=0
107 F S L=$O(RMPRTXT(L)) Q:L="" D
108 . I 'LN D Q:RMPRC="" ;strip leading space from 1st line, ignore blank line
109 .. S RMPRC=$E($TR(RMPRTXT(L)," ","")) ;1st non space char
110 .. S:RMPRC'="" RMPRTXT(L)=$E(RMPRTXT(L),$F(RMPRTXT(L),RMPRC)-1,$L(RMPRTXT(L))) ;extract from 1st non space char to end of line
111 .. Q
112 . S LN=LN+1,^RMPR(668,RMIE68,1,RMPRDA2,1,LN,0)=RMPRTXT(L)
113 . Q
114 S $P(^RMPR(668,RMIE68,1,RMPRDA2,1,0),"^",3)=LN
115 K L,LN
116 S GMRCO=$P(^RMPR(668,RMIE68,0),U,15)
117 I GMRCO="" S RESULTS(0)="0^Completed Manual Suspense Action. Suspense status has not changed." Q
118 S RMPRCOM=0
119 F S RMPRCOM=$O(^RMPR(668,RMIE68,1,RMPRDA2,1,RMPRCOM)) Q:RMPRCOM="" D
120 .S GMRCOM(RMPRCOM)=^RMPR(668,RMIE68,1,RMPRDA2,1,RMPRCOM,0)
121 D CMT^GMRCGUIB(.GMRCO,.GMRCOM,"",GMRCWHN,DUZ)
122 K DA,RMPRDA1,RMPRDA2,RMPRCOM,GMRCOM,GMRCO,GMRCWHN
123 S RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult. Suspense status has not changed."
124 Q
125INOTE ;initial action note
126 ;set file 668
127 ;^RMPR(668,D0,3,0)=^668.07^^
128 ;if status is pending, or 0
129 ;RMPRTXT ;load into field #7
130 ;^RMPR(668,D0,3,0)=^668.07^^
131 ;
132 I $D(^RMPR(668,RMIE68,3,1,0)) S RESULTS(0)="1^Initial Action Note Already Posted!" Q
133 D NOW^%DTC S RMPREODT=%
134 N RMPRC
135 S ^RMPR(668,RMIE68,3,0)="^^^"_DT_"^"
136 S L="",LN=0
137 F S L=$O(RMPRTXT(L)) Q:L="" D
138 . I 'LN D Q:RMPRC="" ;strip leading space from 1st line, ignore blank line
139 .. S RMPRC=$E($TR(RMPRTXT(L)," ","")) ;1st non space char
140 .. S:RMPRC'="" RMPRTXT(L)=$E(RMPRTXT(L),$F(RMPRTXT(L),RMPRC)-1,$L(RMPRTXT(L))) ;extract from 1st non space char to end of line
141 .. Q
142 . S LN=LN+1,^RMPR(668,RMIE68,3,LN,0)=RMPRTXT(L)
143 . Q
144 S $P(^RMPR(668,RMIE68,3,0),"^",3)=LN
145 K L,LN
146 S DIE="^RMPR(668,"
147 S DA=RMIE68
148 S DR="10////^S X=RMPREODT;16////^S X=DUZ;14///^S X=""P"""
149 D ^DIE
150 S GMRCO=$P(^RMPR(668,RMIE68,0),U,15)
151 I GMRCO="" S RESULTS(0)="0^Completed Manual Suspense Action. Suspense status has been updated to PENDING" Q
152 S RMPRCMT=0
153 F S RMPRCMT=$O(^RMPR(668,RMIE68,3,RMPRCMT)) Q:RMPRCMT="" D
154 .S GMRCMT(RMPRCMT)=^RMPR(668,RMIE68,3,RMPRCMT,0)
155 D CMT^GMRCGUIB(GMRCO,.GMRCMT,DUZ,RMPREODT,DUZ)
156 K RMPREODT,GMRCO,RMGMRCO,GMRCMT,RMPRCMT
157 S RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult. Suspense status has changed to PENDING."
158 Q
159 ;
160FD ;file date
161 N DIE,DIC,I,J,Y,RMDFN,RMI,RMDATE,RM680,RM6810,RMERROR,RM60L,RC
162 N RMERR,RMCHK,DLAYGO,X,DR,RM668,RM60DAT,RMSTATUS
163 N RM68CNT,RM60CNT,RMREQU,RMSI,RMSAMIS,RM68IEN,RM60IEN,RMSUS60,RMSUS68,RMD
164 N RM68DATA,RM60TYP,RM68D,RM68TRAN,RMPRPRC,RM60IT,RMENTSUS,RMQUIT
165 ;
166 S RMERR=0
167 S:RMSUSTAT="" RMSUSTAT=0
168 L +^RMPR(660,RMIE60):2
169 I $T=0 S RESULTS(0)="1^Someone else is Editing this entry! If this problem persists contact your IRM to clear the Lock Table",STP=1 Q
170 S RM680=$G(^RMPR(668,RMIE68,0))
171 S RM688=$G(^RMPR(668,RMIE68,8))
172 S RM6810=$G(^RMPR(668,RMIE68,10))
173 S RMAMIS=$P($G(^RMPR(660,RMIE60,"AMS")),U,1)
174 ;code here for 668 fields
175 S RMDATE=$P(RM680,U,1)
176 S RMCODT=$P(RM680,U,5)
177 S RMINDT=$P(RM680,U,9)
178 S RMPRCO=$P(RM680,U,15)
179 S RMDWRT=$P(RM680,U,16)
180 S RMSTAT=$P(RM680,U,7)
181 S RMTRES=$P(RM680,U,8)
182 S RMTYRE=$S(RMTRES=1:"ROUTINE",RMTRES=2:"EYEGLASS",RMTRES=3:"CONTACT LENS",RMTRES=4:"OXYGEN",RMTRES=5:"MANUAL",RMTRES=11:"LAB",1:"")
183 S RMREQU=$P(RM680,U,11)
184 S RMSERV=""
185 I $G(RMREQU) D GETS^DIQ(200,RMREQU,"29","E","RMAA") S RMSERV=RMAA(200,RMREQU_",",29,"E")
186 S RMPRDI=$E($P(RM688,U,2),1,16)
187 S RMICD9=$P(RM688,U,3)
188 ;
189 S RMDAT(660,RMIE60_",",8.1)=RMDATE
190 S RMDAT(660,RMIE60_",",8.2)=RMDWRT
191 S RMDAT(660,RMIE60_",",8.3)=RMINDT
192 S RMDAT(660,RMIE60_",",8.4)=RMCODT
193 S RMDAT(660,RMIE60_",",8.5)=RMTYRE
194 S RMDAT(660,RMIE60_",",8.6)=RMREQU
195 S RMDAT(660,RMIE60_",",8.61)=RMSERV
196 S RMDAT(660,RMIE60_",",8.7)=RMPRDI
197 S RMDAT(660,RMIE60_",",8.8)=RMICD9
198 S RMDAT(660,RMIE60_",",8.9)=RMPRCO
199 S RMDAT(660,RMIE60_",",8.11)=RMSTAT
200 I RMSUSTAT=2 S RMDAT(660,RMIE60_",",8.14)=0
201 I RMSUSTAT'=2 S RMDAT(660,RMIE60_",",8.14)=RMSUSTAT
202 D FILE^DIE("","RMDAT","RMERROR")
203 L -^RMPR(660,RMIE60)
204 I $D(RMERROR) S RMERR=1,STP=1 G ERR
205 ;
206 Q
207UPD ;update file 668 with 2319 records
208 K DD,DO
209 S DA(1)=RMIE68
210 S DIC="^RMPR(668,"_DA(1)_","_"10,"
211 S DIC(0)="L",DLAYGO=668,X=RMIE60
212 D FILE^DICN
213 K X,DD,DO
214 S DA(1)=RMIE68
215 S DIC="^RMPR(668,"_DA(1)_","_"11,"
216 S X=RMAMIS
217 D FILE^DICN
218 K DIC,X,DLAYGO,DO
219 Q
220A3 G A4
221EN1(RESULTS,DA) ;Broker entry to kill WO
222 ;DA is passed
223 S DIK="^RMPR(664.1," D ^DIK
224 K DIK
225A4 ;
226 Q
227ERR ;exit on error
228 S RESULTS(0)="1^ERROR WAS "_RMERROR("DIERR",1,"TEXT",1)
229EXIT ;
230 K %,BDC,RM688,RMAA,RMAMIS,RMCODT,RMDAT,RMDWRT,RMICD9,RMIE,RMIE60,RMINDT
231 K RMPRCO,RMPRDI,RMSERV,RMSTAT,RMTRES,RMTYRE,STP
232 Q
Note: See TracBrowser for help on using the repository browser.