source: WorldVistAEHR/trunk/r/QUASAR-ACKQ/ACKQASU4.m@ 949

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

initial load of WorldVistAEHR
File size: 7.9 KB
RevLine 
[613]1ACKQASU4 ;HCIOFO/AG - New/Edit Visit Utilities ; 04/01/99
2 ;;3.0;QUASAR;;Feb 11, 2000
3 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
4 ;
5 ;
6COPYPCE(ACKVIEN,ACKPCENO) ; Copies the visit data from given PCE Visit
7 ; inputs:- ACKVIEN - QUASAR Visit ien to receive data
8 ; ACKPCENO - PCE Visit ien to copy from
9 ; outputs:- 0^ - everything ok
10 ; n^ - n errors found
11 ; errors filed in ^TMP("ACKQASU4",$J,"COPYPCE","ERROR",n)=field^int^ext^message
12 ; NB. In the validation of Dx and CPT codes, the Visit Stop Code (A,S,
13 ; AT or ST) is read from the Qsr Visit record. For this validation to
14 ; work therefore, the Visit Stop Code must already be filed on the Qsr
15 ; visit.
16 N ACKERR,ACKARR,ACKVELG,ACKI,ACKICD,ACKE,ACKTMP,ACKPRIM,ACKSTUD
17 N ACKSC,ACKAO,ACKIR,ACKEC,ACKREC,ACKPRV,ACKTYP,ACKCPT,ACKQTY,ACKVTME
18 N ACKDPRIM,ACKQPRV,ACKPRVCK
19 K ^TMP("ACKQASU4",$J,"COPYPCE") ; initialise return array
20 S ACKERR=0 ; error counter
21 ;
22 ; get the PCE Visit data - returned in ^TMP("PXKENC",$J,pce ien,...)
23 D ENCEVENT^PXAPI(ACKPCENO,"")
24 ;
25 ; Get Diagnostic codes
26 S ACKI="",ACKDPRIM=""
27 F S ACKI=$O(^TMP("PXKENC",$J,ACKPCENO,"POV",ACKI)) Q:ACKI="" D
28 . S ACKICD=$P($G(^TMP("PXKENC",$J,ACKPCENO,"POV",ACKI,0)),U,1) ; icd ien
29 . I ACKDPRIM="",$P($G(^TMP("PXKENC",$J,ACKPCENO,"POV",ACKI,0)),U,12)="P" S ACKDPRIM=1
30 . ; add to visit
31 . S ACKE=$$SETDIAG^ACKQASU5(ACKVIEN,ACKICD,ACKDPRIM)
32 . I ACKDPRIM S ACKDPRIM="0"
33 . ; if error returned then file
34 . I 'ACKE D Q
35 . . S ACKTMP="Diagnosis"_U_ACKICD_U_$$GET1^DIQ(80,ACKICD,.01,"E")_U_$P(ACKE,U,2)
36 . . D ADDERR
37 . ; if successful then ensure Diagnosis is added to Patient Diagnostic history
38 . D DIAGHIST
39 ;
40 ; get all the providers and file
41 S ACKI="",ACKPRIM="",ACKSTUD=""
42 F S ACKI=$O(^TMP("PXKENC",$J,ACKPCENO,"PRV",ACKI)) Q:ACKI="" D
43 . S ACKREC=$G(^TMP("PXKENC",$J,ACKPCENO,"PRV",ACKI,0))
44 . S ACKPRV=$P(ACKREC,U,1) ; provider ien
45 . S ACKTYP=$P(ACKREC,U,4) ; primary/secondary
46 . I ACKTYP="P" D COPYPRIM Q ; copy primary provider
47 . I ACKTYP="S" D COPYSCND Q ; copy secondary provider
48 ;
49 ; Get procedure codes
50 S ACKI=""
51 F S ACKI=$O(^TMP("PXKENC",$J,ACKPCENO,"CPT",ACKI)) Q:ACKI="" D
52 . S ACKREC=$G(^TMP("PXKENC",$J,ACKPCENO,"CPT",ACKI,0))
53 . S ACKCPT=$P(ACKREC,U,1),ACKQTY=$P(ACKREC,U,16) ; unpack cpt and volume
54 . ; Get Procedure Provider
55 . S ACKPRV=$P($G(^TMP("PXKENC",$J,ACKPCENO,"CPT",ACKI,12)),U,4)
56 . S ACKQPRV=$$PROVCHK(ACKPRV)
57 . I ACKPRV'="" D
58 . . S ACKPRVCK=$$STACT^ACKQUTL(ACKQPRV,ACKVD)
59 . . I ACKPRVCK'="0",ACKPRVCK'="-6" D
60 . . . S ACKTMP="Provider"_U_ACKPRV_U_$$GET1^DIQ(200,ACKPRV_",",.01,"E")_U
61 . . . S ACKTMP=ACKTMP_"Invalid Procedure Provider"
62 . . . D ADDERR
63 . . . S ACKQPRV=""
64 . ; add to visit
65 . S ACKE=$$SETPROC^ACKQASU5(ACKVIEN,ACKCPT,ACKQTY,ACKQPRV)
66 . ; if error returned then file
67 . I 'ACKE D Q
68 . . S ACKTMP="Procedure"_U_ACKCPT_U_$$GET1^DIQ(81,ACKCPT,.01,"E")_U_$P(ACKE,U,2)
69 . . D ADDERR
70 . ; if successful then do the modifiers for this procedure
71 . S ACKM=0,ACKPIEN=+ACKE ; ACKPIEN=procedure ien from visit file
72 . F S ACKM=$O(^TMP("PXKENC",$J,ACKPCENO,"CPT",ACKI,1,ACKM)) Q:'ACKM D
73 . . S ACKMOD=$P($G(^TMP("PXKENC",$J,ACKPCENO,"CPT",ACKI,1,ACKM,0)),U,1)
74 . . ; add to visit
75 . . S ACKE=$$SETMDFR^ACKQASU5(ACKVIEN,ACKPIEN,ACKMOD)
76 . . ; if error returned then file
77 . . I '+ACKE D Q
78 . . . S ACKTMP="Modifier"_U_ACKMOD_U_$$GET1^DIQ(81.3,ACKMOD_",",.01,"E")_U_$P(ACKE,U,2)
79 . . . D ADDERR
80 ;
81 ; now file header items
82 K ACKARR,ACKPRV
83 ;
84 ; If PCE visit has an eligibility write to a&sp visit file
85 S ACKVELG=$P($G(^TMP("PXKENC",$J,ACKPCENO,"VST",ACKPCENO,0)),U,21)
86 I ACKVELG'="" S ACKARR(509850.6,ACKVIEN_",",80)=ACKVELG
87 ;
88 ; Get service connected,Agent Orange,Radiation and Environmental
89 ; Contaminents from PCE file and set them to the Visit file.
90 S ACKREC=$G(^TMP("PXKENC",$J,ACKPCENO,"VST",ACKPCENO,800))
91 S ACKSC=$P(ACKREC,U,1) ; service connected
92 S ACKAO=$P(ACKREC,U,2) ; agent orange
93 S ACKIR=$P(ACKREC,U,3) ; ionizing radiation
94 S ACKEC=$P(ACKREC,U,4) ; environmental contaminants
95 S ACKARR(509850.6,ACKVIEN_",",20)=$S(+ACKSC:1,ACKSC=0:0,1:"")
96 S ACKARR(509850.6,ACKVIEN_",",25)=$S(+ACKAO:1,ACKAO=0:0,1:"")
97 S ACKARR(509850.6,ACKVIEN_",",30)=$S(+ACKIR:1,ACKIR=0:0,1:"")
98 S ACKARR(509850.6,ACKVIEN_",",35)=$S(+ACKEC:1,ACKEC=0:0,1:"")
99 ;
100 ; Update QUASAR visit record
101 D FILE^DIE("","ACKARR")
102 K ACKARR
103 ;
104COPYPCEX ; Exit point
105 K ^TMP("PXKENC",$J) ; Clear PCE data
106 I ACKERR S ^TMP("ACKQASU4",$J,"COPYPCE","ERROR")=ACKERR ; final error count
107 Q ACKERR_U ; return error count
108 ;
109 ;
110COPYPRIM ; Copy the primary provider to QUASAR
111 ;
112 ; If we haven't successfully filed a primary then attempt to
113 I ACKPRIM="" D Q ;
114 . S ACKQPRV=$$PROVCHK(ACKPRV)
115 . S ACKE=$$SETPRIM^ACKQASU6(ACKVIEN,ACKQPRV) ; Attempt to add to visit
116 . I +ACKE S ACKPRIM=ACKQPRV ; Record that we now have a primary
117 . I '+ACKE D ; error occurred
118 . . S ACKTMP="Provider"_U_ACKPRV_U_$$GET1^DIQ(200,ACKPRV_",",.01,"E")_U
119 . . S ACKTMP=ACKTMP_$P(ACKE,U,2)
120 . . D ADDERR
121 ;
122 ; if we already have a primary then add an error message
123 S ACKTMP="Provider"_U_ACKPRV_U_$$GET1^DIQ(200,ACKPRV_",",.01,"E")_U
124 S ACKTMP=ACKTMP_"Visit already has a Primary Provider"
125 D ADDERR
126 ;
127 ; return to provider loop
128 Q
129 ;
130COPYSCND ; copy a secondary provider to QUASAR
131 ;
132 ; determine the Quasar classification for this provider
133 S ACKQPRV=$$PROVCHK(ACKPRV)
134 S ACKTYPQ=$$GET1^DIQ(509850.3,$S(ACKQPRV="":" ",1:ACKQPRV)_",",.02,"I")
135 ;
136 ; if they are a student and we haven't one already,
137 ; then attempt to file as student
138 I ACKTYPQ="S",ACKSTUD="" D Q ; student
139 . S ACKE=$$SETSTUD^ACKQASU6(ACKVIEN,ACKQPRV)
140 . I +ACKE S ACKSTUD=ACKQPRV Q ; record that we now have a student
141 . I '+ACKE D ; Error occurred
142 . . S ACKTMP="Student"_U_ACKPRV_U_$$GET1^DIQ(200,ACKPRV_",",.01,"E")_U
143 . . S ACKTMP=ACKTMP_$P(ACKE,U,2)
144 . . D ADDERR
145 ;
146 ; if they are a student and we already have one then set error
147 I ACKTYPQ="S",ACKSTUD'="" D Q
148 . S ACKTMP="Student"_U_ACKPRV_U_$$GET1^DIQ(200,ACKPRV_",",.01,"E")_U
149 . S ACKTMP=ACKTMP_"Visit already has a Student"
150 . D ADDERR
151 ;
152 ; if they are a regular provider, and we do not already have
153 ; a secondary provider then attempt to file
154 I (ACKTYPQ="C")!(ACKTYPQ="F")!(ACKTYPQ="O") D Q
155 . S ACKE=$$SETSCND^ACKQASU6(ACKVIEN,ACKQPRV) ; attempt to add to visit
156 . I +ACKE Q ; All okay
157 . I '+ACKE D ; Error occurred
158 . . S ACKTMP="Provider"_U_ACKPRV_U_$$GET1^DIQ(200,ACKPRV_",",.01,"E")_U
159 . . S ACKTMP=ACKTMP_$P(ACKE,U,2)
160 . . D ADDERR
161 ;
162 ; if we get this far then provider must be unknown to Quasar
163 S ACKTMP="Provider"_U_ACKPRV_U_$$GET1^DIQ(200,ACKPRV_",",.01,"E")_U
164 S ACKTMP=ACKTMP_"Provider not defined for Audiology and Speech Pathology"
165 D ADDERR
166 ;
167 ; end of checking a secondary provider
168 Q
169 ;
170ADDERR ; add an error to return array in ^TMP
171 ; ACKERR is current error count, ACKTMP is the error detail
172 S ACKERR=ACKERR+1
173 S ^TMP("ACKQASU4",$J,"COPYPCE","ERROR",ACKERR)=ACKTMP
174 Q
175 ;
176DIAGHIST ; ensure diagnosis is on Patient history
177 ; this s/r checks for ACKICD (diagnosis ien) on the patient history
178 ; of patient ACKPAT
179 ; if the ICD is not found a new entry is automatically added using the
180 ; visit date in ACKVD
181 N ACKTGT
182 ;
183 ; look for the diagnosis on the current history
184 D FIND^DIC(509850.22,","_ACKPAT_",","","Q",ACKICD,1,"B","","","ACKTGT")
185 ;
186 ; if found then exit
187 I +$P($G(ACKTGT("DILIST",0)),U,1)=1 Q ; exactly one found
188 ;
189 ; create a new entry
190 S ACKUPD(509850.22,"+1,"_ACKPAT_",",.01)=ACKICD
191 S ACKUPD(509850.22,"+1,"_ACKPAT_",",1)=ACKVD
192 D UPDATE^DIE("","ACKUPD","","")
193 ;
194 ; end
195 Q
196 ;
197PROVCHK(ACKPRV) ; Check to see if Provider is on Quasar Staff file - if so
198 ; function passes back Quasars Provider IEN No else null
199 ;
200 N ACKA,ACKB S ACKB=""
201 I ACKPRV="" Q ACKB
202 ; If not on USR file then definitely wont be on Quasar
203 I '$D(^USR(8930.3,"B",ACKPRV)) Q ACKB
204 S ACKA=""
205 F S ACKA=$O(^USR(8930.3,"B",ACKPRV,ACKA)) Q:'+ACKA!(ACKB'="") D
206 . I '$D(^ACK(509850.3,"B",ACKA)) Q
207 . S ACKB=$O(^ACK(509850.3,"B",ACKA,ACKB))
208 Q ACKB
209 ;
Note: See TracBrowser for help on using the repository browser.