source: FOIAVistA/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/ECMLMP.m@ 812

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

initial load of FOIAVistA 6/30/08 version
File size: 7.2 KB
Line 
1ECMLMP ;ALB/ESD - Multiple procedure dates and procedures ;22 AUG 1997 11:11
2 ;;2.0; EVENT CAPTURE ;**5,18,47**;8 May 96
3 ;
4EN ;- ListMan entry point
5 ;
6 D EN^VALM("EC MUL PROCEDURES")
7 Q
8 ;
9HDR ;- Display location, provider #1, DSS Unit, and Category as header
10 ;
11 S VALMHDR(1)=" Location: "_$G(ECLN)_" ("_$G(ECL)_")"
12 S VALMHDR(1)=$$SETSTR^VALM1("Provider #1: "_$P(ECU(1),"^",2),VALMHDR(1),40,30)
13 S VALMHDR(2)=" DSS Unit: "_$P(ECDSSU,"^",2)
14 S VALMHDR(2)=$$SETSTR^VALM1(" Category: "_$P(ECCAT,"^",2),VALMHDR(2),40,30)
15 ;
16 Q
17 ;
18INIT ;- Initialize variables and call BLD which does processing
19 ;
20 N BL,ECPCNT,IC,IW,DC,DW,NC,NW,PC,PW,RC,RW,VC,VW,X,MC,MW
21 D CLEAN^VALM10
22 K ^TMP("ECM",$J),^TMP("ECMP",$J),^TMP("ECMPIDX",$J)
23 ;K XQORNOD,%B
24 ;
25 S (VALMCNT,ECPCNT)=0
26 S BL="",$P(BL," ",30)=""
27 S X=VALMDDF("INDEX"),IC=$P(X,"^",2),IW=$P(X,"^",3)
28 S X=VALMDDF("PROC DT"),DC=$P(X,"^",2),DW=$P(X,"^",3)
29 S X=VALMDDF("PROC NUM"),NC=$P(X,"^",2),NW=$P(X,"^",3)
30 S X=VALMDDF("PROCEDURE"),PC=$P(X,"^",2),PW=$P(X,"^",3)
31 S X=VALMDDF("VOL"),VC=$P(X,"^",2),VW=$P(X,"^",3)
32 S X=VALMDDF("REASON"),RC=$P(X,"^",2),RW=$P(X,"^",3)
33 S X=VALMDDF("MODIFIER"),MC=$P(X,"^",2),MW=$P(X,"^",3)
34 ;
35 D BLD
36 S $P(^TMP("ECMP",$J,0),"^",4)=VALMCNT
37 Q
38 ;
39BLD ;- Combine arrays and build lines with data for display
40 ;
41 D COMBINE
42 ;
43 N ECPD,ECNT,ECX
44 S ECPD=0 F S ECPD=$O(^TMP("ECM",$J,ECPD)) Q:'ECPD D
45 . S ECNT=0 F S ECNT=$O(^TMP("ECM",$J,ECPD,ECNT)) Q:'ECNT D BLDLM
46 ;
47 Q
48 ;
49BLDLM ;- Build each line for display and create ^TMP("ECMPIDX",$J) array
50 ;
51 N ECPR,ECCPT K ECX
52 S ECPCNT=ECPCNT+1,ECX="",$P(ECX," ",VALMWD+1)=""
53 S ECX=$E(ECX,1,IC-1)_$E(ECPCNT_BL,1,IW)_$E(ECX,IC+IW+1,VALMWD)
54 S ECX=$E(ECX,1,DC-1)_$E($$FTIME^VALM1(ECPD)_BL,1,DW)_$E(ECX,DC+DW+1,VALMWD)
55 S ECX=$E(ECX,1,NC-1)_$E($P($P(^TMP("ECM",$J,ECPD,ECNT),"^"),";")_BL,1,NW)_$E(ECX,NC+NW+1,VALMWD)
56 S ECCPT=$P(^TMP("ECM",$J,ECPD,ECNT),"^")
57 S ECCPT=$S(ECCPT["ICPT":+ECCPT,1:$P($G(^EC(725,+ECCPT,0)),"^",5))
58 I ECCPT'="" S ECCPT=$P($$CPT^ICPTCOD(ECCPT,ECPD),U,2)
59 S ECPR=$S(ECCPT'="":ECCPT_" ",1:ECCPT)_$P(^TMP("ECM",$J,ECPD,ECNT),"^",2)
60 S ECX=$E(ECX,1,PC-1)_$E($E(ECPR,1,30)_BL,1,PW)_$E(ECX,PC+PW+1,VALMWD)
61 S ECX=$E(ECX,1,VC-1)_$E($P(^TMP("ECM",$J,ECPD,ECNT),"^",5)_BL,1,VW)_$E(ECX,VC+VW+1,VALMWD)
62 ;
63 D SET(ECX)
64 ;
65 S ^TMP("ECMPIDX",$J,ECPCNT)=VALMCNT_"^"_ECPD_"^"_$P(^TMP("ECM",$J,ECPD,ECNT),"^")_"^"_$P(^TMP("ECM",$J,ECPD,ECNT),"^",2)_"^"_$P(^TMP("ECM",$J,ECPD,ECNT),"^",3)_"^"_$P(^TMP("ECM",$J,ECPD,ECNT),"^",4)_"^"_$P(^TMP("ECM",$J,ECPD,ECNT),"^",5)
66 ;
67 I $D(^TMP("ECM",$J,ECPD,ECNT,"MOD")) D K MOD
68 . S MOD="",ECX=$E(BL,1,26)_"Modifier:"
69 . F S MOD=$O(^TMP("ECM",$J,ECPD,ECNT,"MOD",MOD)) Q:MOD="" D
70 . . S ECX=$E(ECX,1,MC-1)_" - "_MOD_" "_$E($P(^TMP("ECM",$J,ECPD,ECNT,"MOD",MOD),"^")_BL,1,MW)_$E(ECX,MC+MW+1,VALMWD)
71 . . D SET(ECX) K ECX S ECX=BL_" "
72 . M ^TMP("ECMPIDX",$J,ECPCNT,"MOD")=^TMP("ECM",$J,ECPD,ECNT,"MOD")
73 ;
74 K ECX
75 S ECX=" "
76 S ECX=$E(ECX,1,RC-1)_"Procedure Reason: "_$E($P(^TMP("ECM",$J,ECPD,ECNT),"^",4)_BL,1,RW)_$E(ECX,RC+RW+1,VALMWD)
77 D SET(ECX)
78 K ECX S ECX=BL D SET(ECX)
79 Q
80 ;
81 ;
82SET(X) ;- Create display array ^TMP("ECMP",$J)
83 ;
84 S VALMCNT=VALMCNT+1,^TMP("ECMP",$J,VALMCNT,0)=X
85 S ^TMP("ECMP",$J,"IDX",VALMCNT,ECPCNT)=""
86 Q
87 ;
88HLPS ;- Brief help
89 ;
90 S X="?" D DISP^XQORM1 W !!
91 Q
92HELP ;- Help for list
93 S ECZ=""
94 I $D(X),X'["??" D HLPS,PAUSE^VALM1 G HLPQ
95 D CLEAR^VALM1
96 F I=1:1 S ECZ=$P($T(HELPTXT+I),";",3,99) Q:ECZ="$END" D PAUSE^VALM1:ECZ="$PAUSE" Q:'Y W !,$S(ECZ["$PAUSE":"",1:ECZ)
97 W !,"Possible actions are the following:"
98 D HLPS,PAUSE^VALM1 S VALMBCK="R"
99HLPQ K ECZ,Y,I Q
100 ;
101EXIT ;- Clean up and exit
102 ;
103 K ^TMP("ECPRDT",$J),^TMP("ECPROC",$J)
104 K ^TMP("ECM",$J),^TMP("ECMP",$J)
105 K VALMDDF
106 D CLEAN^VALM10,CLEAR^VALM1
107 Q
108 ;
109COMBINE ;- Combine proc date array and procedure array
110 ;
111 N ECNT,ECPDT,ECPR,ECX,ECY
112 S (ECNT,ECPDT,ECX,ECY)=0,ECPR=""
113 F S ECX=$O(^TMP("ECPRDT",$J,ECX)) Q:'ECX D
114 . S ECY=0 F S ECY=$O(^TMP("ECPROC",$J,(ECY))) Q:'ECY D
115 .. S ECPR=$G(^TMP("ECPROC",$J,(ECY)))
116 .. S ECNT=ECNT+1,^TMP("ECM",$J,ECX,ECNT)=$P(ECPR,"^")_"^"_$P(ECPR,"^",2)_"^"_$P(ECPR,"^",3)_"^"_$P(ECPR,"^",4)_"^"_$P(ECPR,"^",5)
117 .. M ^TMP("ECM",$J,ECX,ECNT,"MOD")=^TMP("ECPROC",$J,ECY,"MOD")
118 Q
119 ;
120 ;
121PRDTDEL ;- Entry point for EC MUL DEL PROCDT protocol
122 ;
123 N ECDATE,ECFND,ECSEL,ECDP,VALMY
124 S VALMBCK=""
125 D FULL^VALM1
126 D EN^VALM2(XQORNOD(0))
127 S (ECFND,ECSEL)=0
128 F S ECSEL=$O(VALMY(ECSEL)) Q:'ECSEL D
129 . I $D(^TMP("ECMPIDX",$J,ECSEL)) K ECDAT S ECDAT=^(ECSEL) D
130 .. S ECDATE=$P(ECDAT,"^",2)
131 .. S ECDP=0 F S ECDP=$O(^TMP("ECPRDT",$J,ECDP)) Q:'ECDP!(ECFND) D
132 ... I ECDATE=ECDP S ECFND=1 K ^TMP("ECPRDT",$J,ECDP)
133 .. I ECFND=0 W !!,*7,">>> This procedure date could not be found. <<<" D PAUSE^VALM1 Q
134 I '$D(^TMP("ECPRDT",$J)) K ^TMP("ECPROC",$J)
135 I ECFND=1 D INIT^ECMLMP
136 S VALMBCK="R"
137 K ECDAT
138PRDTDLQ Q
139 ;
140 ;
141PRDEL ;- Entry point for EC MUL PROC DEL protocol
142 ;
143 N ECDP,ECFND,ECSEL,VALMY
144 S VALMBCK=""
145 D FULL^VALM1
146 D EN^VALM2(XQORNOD(0))
147 S (ECFND,ECSEL)=0
148 F S ECSEL=$O(VALMY(ECSEL)) Q:'ECSEL D
149 . I $D(^TMP("ECMPIDX",$J,ECSEL)) K ECI S ECI=^(ECSEL) D
150 .. S ECDP=0 F S ECDP=$O(^TMP("ECPROC",$J,ECDP)) Q:'ECDP!(ECFND) K ECN S ECN=^(ECDP) D
151 ... I ($P(ECI,"^",3)=$P(ECN,"^")),($P(ECI,"^",4)=$P(ECN,"^",2)),($P(ECI,"^",5)=$P(ECN,"^",3)),($P(ECI,"^",6)=$P(ECN,"^",4)),($P(ECI,"^",7)=$P(ECN,"^",5)) D
152 .... S ECFND=1 K ^TMP("ECPROC",$J,ECDP)
153 .. I ECFND=0 W !!,*7,">>> This procedure could not be found. <<<" D PAUSE^VALM1 Q
154 I '$D(^TMP("ECPROC",$J)) K ^TMP("ECPRDT",$J)
155 I ECFND=1 D INIT^ECMLMP
156 S VALMBCK="R"
157 K ECI,ECN
158PRDELQ Q
159 ;
160 ;
161PRDTADD ;- Entry point for EC MUL ADD PROCDT protocol
162 ;
163 N ECADD
164 S ECADD=0,VALMBCK=""
165 D FULL^VALM1
166 S ECADD=$$ASKPRDT^ECMUTL(+$P(ECDSSU,"^"),1)
167 I 'ECADD W !!,*7,">>> No Procedure Date entered. <<<" D PAUSE^VALM1 G PRDTADQ
168 I ECADD=1,'$D(^TMP("ECPROC",$J)) D ASKPRO^ECMUTL(ECL,+$P(ECDSSU,"^"),+$P(ECCAT,"^"),-99)
169 I ECADD=1,$D(^TMP("ECPROC",$J)) D INIT^ECMLMP
170 ;
171PRDTADQ S VALMBCK="R"
172 Q
173 ;
174 ;
175PRADD ;- Entry point for EC MUL ADD PROC protocol
176 ;
177 N ECAP
178 S VALMBCK=""
179 D FULL^VALM1
180 S ECAP="",ECAP=$O(^TMP("ECPROC",$J,ECAP),-1)
181 I ECAP>0 D
182 . D ASKPRO^ECMUTL(ECL,+$P(ECDSSU,"^"),+$P(ECCAT,"^"),(ECAP+1))
183 . D INIT^ECMLMP
184 I 'ECAP,('$D(^TMP("ECPRDT",$J))) W !!,*7,">>> At least one procedure date must exist before adding a procedure.",!," Please add a procedure date first. <<<" D PAUSE^VALM1
185 S VALMBCK="R"
186PRADDQ Q
187 ;
188 ;
189HELPTXT ; -- help text
190 ;;Enter actions(s) by typing the name(s), or abbreviation(s).
191 ;;
192 ;;ACTION DEFINITIONS:
193 ;; AD - Add a Procedure Date allows the user to add a procedure date
194 ;; to procedures previously entered
195 ;; DD - Delete a Procedure Date allows the user to delete a procedure
196 ;; date from procedures previously entered
197 ;; PA - Add a Procedure allows the user to add a procedure to all
198 ;; procedure dates previously entered
199 ;; PD - Delete a Procedure allows the user to delete a procedure
200 ;; from all procedure dates previously entered
201 ;; MP - Multiple Patients allows the user to enter the patients
202 ;; for the indicated procedure dates and procedures
203 ;;
204 ;; NOTE: After the user has entered procedures and date/times, he or
205 ;; she will need to use the 'MP' Action to add patients for the
206 ;; entered procedures and date/times.
207 ;;------------------------------------------------------------------------------
208 ;;$PAUSE
209 ;;$END
Note: See TracBrowser for help on using the repository browser.