source: FOIAVistA/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/ECPRVMUT.m@ 1770

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

initial load of FOIAVistA 6/30/08 version
File size: 8.5 KB
Line 
1ECPRVMUT ;ALB/JAM - Event Capture Multiple Provider Utilities ;24 Aug 05
2 ;;2.0; EVENT CAPTURE ;**72**;8 May 96
3 ;
4GETPRV(ECIEN,OUTARR) ;Returns providers associated with an encounter
5 ;*** This recall replaces GET^ECPRVUTL to allow for multiple providers
6 ; instead of three.
7 ; Input: ECIEN - IEN entry in file 721/^ECH(
8 ;
9 ; Output: OUTARR - output array with providers
10 ; ^ECH IEN^provider ien^provider description^
11 ; Primary/Secondary code^Primary/Secondary description
12 ; returns 0 if successful or 1 if unsuccessful
13 ;
14 I $G(ECIEN)="" Q 1 ;IEN not define.
15 I '$D(^ECH(ECIEN)) Q 1 ;IEN does not exist in file 721/^ECH(
16 I $O(^ECH(ECIEN,"PRV",0))="" Q 1 ;No provider on file for entry
17 N PRV,IEN,ECERR,SEQ,TYP,TYD,TMPARR,PRI,CNT,PRVARY
18 S PRI=0
19 D GETS^DIQ(721,ECIEN,"42*","IE","PRVARY","ECERR")
20 I $D(ECERR) Q 1 ;Error looking up entry
21 S SEQ="" F S SEQ=$O(PRVARY(721.042,SEQ)) Q:SEQ="" D
22 . S IEN=$G(PRVARY(721.042,SEQ,.01,"I")) I IEN="" Q
23 . S PRV=$G(PRVARY(721.042,SEQ,.01,"E")) I PRV="" S PRV="Unknown"
24 . S TYP=$G(PRVARY(721.042,SEQ,.02,"I")) I TYP="" S TYP="Ukn"
25 . S TYD=$G(PRVARY(721.042,SEQ,.02,"E")) I TYD="" S TYD="Unknown"
26 . I 'PRI,TYP="P" S PRI=1_U_$P(SEQ,",")
27 . I $P(SEQ,",")'="" S TMPARR($P(SEQ,","))=IEN_U_PRV_U_TYP_U_TYD
28 ;set primary provider as first subscript
29 S CNT=1,PRI=$S(PRI:$P(PRI,U,2),1:$O(TMPARR(0))),OUTARR(CNT)=TMPARR(PRI)
30 K TMPARR(PRI)
31 S IEN=0 F S IEN=$O(TMPARR(IEN)) Q:'IEN D
32 . S CNT=CNT+1,OUTARR(CNT)=TMPARR(IEN)
33 Q $S($D(OUTARR):0,1:1)
34 ;
35GETPPRV(ECIEN,ECPPROV) ;returns primary provider associated with an encounter
36 ; Input: ECIEN - IEN entry in file 721/^ECH(
37 ;
38 ; Output: ECPPROV - primary provider
39 ; provider ien^provider description
40 ; returns 0 if successful or 1 if unsuccessful
41 ;
42 I $G(ECIEN)="" Q 1 ;IEN not define.
43 I '$D(^ECH(ECIEN)) Q 1 ;IEN does not exist in file 721/^ECH(
44 I $O(^ECH(ECIEN,"PRV",0))="" Q 1 ;No provider on file for entry
45 N PRVARY,PRV,IEN,ECERR,SEQ,ECOUT,TYP
46 S ECOUT=0
47 D GETS^DIQ(721,ECIEN,"42*","IE","PRVARY","ECERR")
48 I $D(ECERR) Q 1 ;Error looking up entry
49 S SEQ="" F S SEQ=$O(PRVARY(721.042,SEQ)) Q:SEQ="" D I ECOUT Q
50 . S IEN=$G(PRVARY(721.042,SEQ,.01,"I")) I IEN="" Q
51 . S PRV=$G(PRVARY(721.042,SEQ,.01,"E")) I PRV="" S PRV="Unknown"
52 . S TYP=$G(PRVARY(721.042,SEQ,.02,"I")) I TYP="" S TYD="Unknown"
53 . I TYP="P" S ECPPROV=IEN_U_PRV,ECOUT=1
54 Q $S($D(ECPPROV):0,1:1)
55 ;
56FILPRV(ECIEN,ECPRVARY,ECOUT) ;File multiple providers for an encounter
57 ; Input: ECIEN - IEN entry in file 721/^ECH(
58 ; ECPRVARY - array with providers
59 ; ECOUT - Error flag (1/0)
60 ;
61 ; Output: returns 1 if successful or 0 if unsuccessful
62 ;
63 I $G(ECIEN)="" Q 0 ;IEN not define.
64 I '$D(^ECH(ECIEN)) Q 0 ;IEN does not exist in file 721/^ECH(
65 I '$O(ECPRVARY(0)) Q 0 ;No entry in provider array
66 N SIEN,ECERR,ERR,ECPRVDA,ECDATA,DA,DIK
67 ;delete old entries
68 S DA(1)=ECIEN,DIK="^ECH("_DA(1)_",""PRV"",",DA=0
69 F S DA=$O(^ECH(DA(1),"PRV",DA)) Q:'DA D ^DIK
70 S SIEN=0,ERR=""
71 F S SIEN=$O(ECPRVARY(SIEN)) Q:SIEN="" D
72 .K ECPRVDA,ECERR
73 .S ECDATA=ECPRVARY(SIEN)
74 .S ECPRVDA(721,"?1,",.01)=ECIEN
75 .S ECPRVDA(721.042,"+2,?1,",.01)=$P(ECDATA,U)
76 .S ECPRVDA(721.042,"+2,?1,",.02)=$P(ECDATA,U,3)
77 .D UPDATE^DIE("","ECPRVDA","","ECERR")
78 .I $D(ECERR) S ERR=ERR_SIEN_";"
79 Q $S(ERR="":1,1:"0^"_ERR)
80 ;
81DSPPRV ;Display providers
82 N ECX,ECDAT,ECW
83 W "Encounter Providers"
84 S ECX=0 F S ECX=$O(ECPRVARY(ECX)) Q:'ECX D
85 .S ECDAT=ECPRVARY(ECX)
86 .W !,?3,$P(ECDAT,U),?15,$P(ECDAT,U,2) I $P(ECDAT,U,3)="P" W " (Primary)"
87 Q
88ASKPRV(ECIEN,ECDT,ECPRVARY,ECOUT) ;ask provider question (primary and multiple secondary)
89 ; Variables: ECIEN - IEN entry in file 721/^ECH(
90 ; ECDT - date/time of encounter
91 ; ECPRVARY - array with providers
92 ; ECOUT - Error flag (1/0)
93 ;
94 ; Output: returns 1 if successful or 0 if unsuccessful
95 N ECINF
96 K ECPRVARY,ECPRV,ECPRVN
97 ;get providers
98 I $G(ECIEN)'="" D
99 .S ECINF=$$GETPRV(ECIEN,.ECPRVARY)
100 .S ECINF=$$GETPPRV(ECIEN,.ECPRVN) I 'ECINF S ECPRV=$P(ECPRVN,U),ECPRVN=$P(ECPRVN,U,2)
101 ;display providers
102 I $O(ECPRVARY(""))'="" D DSPPRV
103 ;ask for primary provider
104 D PPRV I $G(ECOUT) Q
105 ;ask for secondary provider
106 D SPRV
107 Q
108PPRV ;Ask primary provider
109 ; Variables: ECPRV = Primary provider ien
110 ; ECPRVN = Primary provider descript, default if define
111 ; ECPRVARY= Array with providers
112 ; subscript=provider IEN,
113 ; data=(P)rimary_^_provider description
114 ; ECOUT = Error flag (1/0)
115 ;
116 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,ECW,X,Y,IEN
117 S ECPRV=$G(ECPRV),ECPRVN=$G(ECPRVN)
118 S DIR(0)="P^VA(200,:AEZQM",DIR("A")="Primary Provider"
119 S DIR("?")="Enter the provider responsible for providing primary care for this encounter."
120 I ECPRV'="" S DIR("B")=$$DICLK^ECPRVUTL(ECPRV)
121 ;get provider with active person class
122 S DIR("S")="I +$$GET^XUA4A72(+Y,$G(ECDT,DT))>0"
123 D ^DIR
124 I +Y>0 D Q
125 .;check if provider exist as secondary and remove.
126 .S IEN=0
127 .F S IEN=$O(ECPRVARY(IEN)) Q:'IEN I $P(ECPRVARY(IEN),U,3)'="P" D
128 ..I +ECPRVARY(IEN)=+Y D
129 ...W !?25,"*** (Provider removed as secondary.) ***" K ECPRVARY(IEN)
130 .S ECW=$$CLASS^ECPRVUTL(+Y,$G(ECDT,DT))
131 .S ECPRV=+Y,ECPRVN=Y(0,0),ECPRVARY(1)=ECPRV_"^"_Y(0,0)_"^P^PRIMARY"
132 S ECOUT=1 Q
133 Q
134SPRV ;Ask secondary provider(s)
135 ; Variables: ECPRV = Primary provider ien, default if define
136 ; ECPRVARY= Array with providers
137 ; subscript=provider IEN,
138 ; data=(S)econdary_^_provider description
139 ;
140 N Y,X,DEF,DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,CNT,X,Y
141 ;create "B" xref and subscript by provider ien in array ECPRVARY
142 ;set last provider as default
143 S DEF="",IEN=$O(ECPRVARY(""),-1),CNT=+IEN+1 I IEN D
144 .I $P(ECPRVARY(IEN),U)'=$G(ECPRV) S DEF=$P(ECPRVARY(IEN),U)
145 S IEN=0
146 F S IEN=$O(ECPRVARY(IEN)) Q:'IEN I $P(ECPRVARY(IEN),U,3)'="P" D
147 .S ECPRVARY("B",+ECPRVARY(IEN))=IEN
148 S:DEF'="" DIR("B")=$$DICLK^ECPRVUTL(DEF) ;DIR("B")="`"_DEF
149 S DIR(0)="PO^VA(200,:AEZQM",DIR("A")="Secondary Provider"
150 S DIR("?")="^D PRVHLP^ECPRVMUT"
151 ;get providers with active person class
152 S DIR("S")="I +$$GET^XUA4A72(+Y,$G(ECDT,DT))>0"
153 F D ^DIR S:$D(DUOUT) ECOUT=1 Q:(X="")!($D(DTOUT))!($D(DUOUT)) D
154 .I +Y>0,+Y=$G(ECPRV) W " Provider already entered as primary." Q
155 .I +Y=DEF K DIR("B") S DEF="" Q
156 .I X="@",DEF'="" D Q
157 ..I DEF=$G(ECPRV) W " Provider flag as primary. Can't delete." Q
158 ..W " "_$$GET1^DIQ(200,DEF,.01)_"...deleted"
159 ..K ECPRVARY(ECPRVARY("B",DEF)),ECPRVARY("B",DEF),DIR("B")
160 .Q:+Y<0 I $D(ECPRVARY("B",+Y)) S DEF=+Y,DIR("B")=$$DICLK^ECPRVUTL(DEF) Q
161 .S ECW=$$CLASS^ECPRVUTL(+Y,$G(ECDT,DT))
162 .S ECPRVARY("B",+Y)=CNT,ECPRVARY(CNT)=+Y_"^"_Y(0,0)_"^S^SECONDARY"
163 .S DEF="",CNT=CNT+1 K DIR("B")
164 K ECPRVARY("B")
165 Q
166PRVHLP ;Help for Provider Code
167 N DIC,PRV,D
168 I $D(ECPRVARY) D
169 .W !?1,"Provider Already Entered:" S PRV=0
170 .F S PRV=$O(ECPRVARY(PRV)) Q:'PRV D
171 ..W !,?3,$P(ECPRVARY(PRV),U),?15,$P(ECPRVARY(PRV),U,2)
172 ..I $P(ECPRVARY(PRV),U,3)="P" W " (Primary)"
173 W !?1,"You may enter a new Provider, if you wish. Enter the secondary Provider"
174 W !?1,"for this procedure."
175 Q
176 ;
177COMP(ECUX,ECDTX) ;get provider information, similar to COMP^ECPRVUTL
178 ;Input: ECUX = IEN in file #200
179 ; ECDTX = Date of encounter
180 ;
181 ;Output: ECUX = ien in file #200^name^compress person class info
182 ;
183 I $G(ECUX)="" Q
184 S ECDTX=$G(ECDTX,DT)
185 ;build ECUX=ien in file #200^name^person class ien^occupation^specialty^
186 ; subspecialty^etc.
187 S ECUX=+ECUX_"^"_$$GET1^DIQ(200,+ECUX,.01)_"^"_$$GET^XUA4A72(+ECUX,ECDTX)
188 D COMP^ECPRVUTL(.ECUX,ECDTX)
189 Q
190DSP1416(ECPRVARY) ;Display providers for data entry options
191 N ECI,ECDAT,ECUP,CNT
192 S (ECI,CNT)=0 F S ECI=$O(ECPRVARY(ECI)) Q:'ECI D
193 .S ECDAT=ECPRVARY(ECI),CNT=CNT+1
194 .W !,"Provider"_$S(CNT=1:"",1:" #"_CNT)_":",?14,$P(ECDAT,U,2)
195 .I +$P(ECDAT,U) S ECUP=+$P(ECDAT,U) D COMP(.ECUP,$G(ECDT,DT)) D
196 ..W !?16,$P(ECUP,"^",3)
197 Q
198DSP1442(ECPRVARY) ;Display providers for data entry options
199 N ECI,ECDAT,ECUP,CNT
200 S (ECI,CNT)=0 F S ECI=$O(ECPRVARY(ECI)) Q:'ECI D
201 .S ECDAT=ECPRVARY(ECI),CNT=CNT+1
202 .W !,"Provider"_$S(CNT=1:"",1:" #"_CNT)_":",?14,$E($P(ECDAT,U,2),1,24)
203 .I +$P(ECDAT,U) S ECUP=+$P(ECDAT,U) D COMP^ECPRVMUT(.ECUP,$G(ECDT,DT)) D
204 ..W ?42,$E($P(ECUP,U,3),1,36)
205 Q
206DSP1444(ECPRVARY) ;Display providers for data entry options
207 N ECI,ECDAT,ECUP,CNT
208 S (ECI,CNT)=0 F S ECI=$O(ECPRVARY(ECI)) Q:'ECI D
209 .S ECDAT=ECPRVARY(ECI),CNT=CNT+1
210 .W !,"Provider"_$S(CNT=1:"",1:" #"_CNT)_":",?14,$E($P(ECDAT,U,2),1,24)
211 .I +$P(ECDAT,U) S ECUP=+$P(ECDAT,U) D COMP^ECPRVMUT(.ECUP,$G(ECDT,DT)) D
212 ..W ?44,$E($P(ECUP,U,3),1,34)
213 Q
Note: See TracBrowser for help on using the repository browser.