source: WorldVistAEHR/trunk/r/QUASAR-ACKQ/ACKQUTL3.m@ 1445

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

initial load of WorldVistAEHR
File size: 7.8 KB
RevLine 
[613]1ACKQUTL3 ;HCIOFO/AG - QUASAR Utility Routine ; 12/13/02 3:51pm
2 ;;3.0;QUASAR;**5**;Feb 11, 2000
3 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
4 ;
5PCECHKV(ACKVIEN) ; is PCE Visit still same patient etc.
6 ; this function will check that the Qsr Visit (ACKVIEN) has the same
7 ; values for Patient, Clinic, Date and Time as the PCE Visit that it
8 ; points to.
9 ; inputs:- ACKVIEN - QUASAR Visit IEN (reqd)
10 ; outputs:- see function $$PCECHK below!
11 N ACKTGT,ACKPCE,ACKDT,ACKTM,ACKPAT,ACKCLN
12 D GETS^DIQ(509850.6,ACKVIEN_",",".01;125;1;2.6;55","I","ACKTGT")
13 S ACKPCE=$G(ACKTGT(509850.6,ACKVIEN_",",125,"I"))
14 I 'ACKPCE Q "2^" ; not pointing to a visit
15 S ACKDT=$G(ACKTGT(509850.6,ACKVIEN_",",.01,"I"))\1
16 S ACKTM=$G(ACKTGT(509850.6,ACKVIEN_",",55,"I"))
17 S ACKPAT=$G(ACKTGT(509850.6,ACKVIEN_",",1,"I"))
18 S ACKCLN=$G(ACKTGT(509850.6,ACKVIEN_",",2.6,"I"))
19 Q $$PCECHK(ACKPCE,ACKDT,ACKTM,ACKPAT,ACKCLN)
20 ;
21PCECHK(ACKPCE,ACKDT,ACKTM,ACKPAT,ACKCLN) ; is PCE Visit still same patient etc.
22 ; this function will check that the Qsr Visit (ACKVIEN) has the same
23 ; values for Patient, Clinic, Date and Time as the PCE Visit that it
24 ; points to.
25 ; inputs:- ACKPCE - PCE Visit IEN (reqd)
26 ; ACKDT - date of visit (reqd) (fileman internal)
27 ; ACKTM - time of visit (reqd) (qsr time .n[nnnnn])
28 ; ACKPAT - patient (reqd)
29 ; ACKCLN - clinic (reqd)
30 ; outputs:- string
31 ; value: "0^X^Y^Z" - either the date, patient or clinic differ
32 ; where X=Clinics are same (1 or 0)
33 ; Y=Patients are same (1 or 0)
34 ; Z=Dates are same (1 or 0)
35 ; eg "0^1^0^0" = patient and dates differ
36 ; "1^.123" - only time is different (.123=Pce time)
37 ; "2^" - all fields the same
38 N PCEDTTM,PCEDT,PCETM,PCEPAT,PCECLN,ACKSTR
39 K ^TMP("PXKENC",$J)
40 ;
41 ; get the visit data from PCE (places it in ^TMP("PXKENC",$J)
42 D ENCEVENT^PXAPI(ACKPCE)
43 S PCEDTTM=$P($G(^TMP("PXKENC",$J,ACKPCE,"VST",ACKPCE,0)),U,1)
44 S PCEDT=PCEDTTM\1,PCETM=PCEDTTM#1
45 S PCEPAT=$P($G(^TMP("PXKENC",$J,ACKPCE,"VST",ACKPCE,0)),U,5)
46 S PCECLN=$P($G(^TMP("PXKENC",$J,ACKPCE,"VST",ACKPCE,0)),U,22)
47 K ^TMP("PXKENC",$J)
48 ;
49 ; check date, patient and clinic
50 I (PCEDT'=ACKDT)!(PCEPAT'=ACKPAT)!(PCECLN'=ACKCLN) D Q ACKSTR
51 . S ACKSTR="0^"
52 . S $P(ACKSTR,U,2)=$S(PCECLN=ACKCLN:1,1:0)
53 . S $P(ACKSTR,U,3)=$S(PCEPAT=ACKPAT:1,1:0)
54 . S $P(ACKSTR,U,4)=$S(PCEDT=ACKDT:1,1:0)
55 ;
56 ; check Appointment time
57 I +PCETM'=+ACKTM Q "1^"_PCETM
58 ;
59 ; must be the same!
60 Q "2^"
61 ;
62DISPLAY(ACKVIEN,XPOS) ; create summary line for visit selection
63 N ACKPAT,ACKCLN,ACKTM,ACKTIME,ACKAM,ACKDISP,ACKLEN
64 S ACKTM=$$GET1^DIQ(509850.6,ACKVIEN_",",55,"I"),ACKTIME=$$FMT^ACKQUTL6(ACKTM,2)
65 S ACKPAT=$$GET1^DIQ(509850.6,ACKVIEN_",",1,"E")
66 S ACKCLN=$$GET1^DIQ(509850.6,ACKVIEN_",",2.6,"E")
67 S ACKP=$S($$GET1^DIQ(509850.6,ACKVIEN_",",125,"I"):".",1:" ")
68 I XPOS<35 D
69 . S ACKLEN=80-XPOS-10-2/2
70 . S ACKPAT=$E(ACKPAT_$J("",ACKLEN),1,ACKLEN\1)
71 . I $G(%)'="" D
72 . . I $TR(%,",","")'?.A D
73 . . . S ACKCLN=$E(ACKCLN_$J("",ACKLEN),1,ACKLEN+.5\1)
74 . . . S ACKDISP=" "_ACKTIME_ACKP_" "_ACKPAT_" "_ACKCLN
75 . . I $TR(%,",","")?.A D
76 . . . S ACKCLN=$E(ACKCLN,1,(40-$L(%)))
77 . . . S ACKDISP=" "_ACKTIME_ACKP_" "_ACKCLN
78 . I $G(%)="" D
79 . . S ACKCLN=$E(ACKCLN_$J("",ACKLEN),1,ACKLEN+.5\1)
80 . . S ACKDISP=" "_ACKTIME_ACKP_" "_ACKPAT_" "_ACKCLN
81 I XPOS'<35 D
82 . S ACKLEN=80-XPOS-10-1
83 . S ACKPAT=$E(ACKPAT_$J("",ACKLEN),1,ACKLEN)
84 . S ACKDISP=" "_ACKTIME_ACKP_" "_ACKPAT
85 Q ACKDISP
86 ;
87PCEERR(ACKVIEN,ACKARR,ACKNUM,ACKWIDE) ; retrieve PCE Errors for a visit and store in ACKARR
88 ; inputs:- ACKVIEN - visit ien (reqd)
89 ; ACKARR - array name in which to place errors (indirection
90 ; used to file data ie @ACKARR@(x) (reqd)
91 ; ACKNUM - Error number (if only one reqd) (opt)
92 ; ACKWIDE - max number of characters in each line (opt)
93 ; outputs:-
94 ; ACKARR=n - number of lines to display
95 ; ACKARR(1-n)=text - text of error (wrapped to ACKWIDE characters)
96 ; if @ACKARR already contains data then this subroutine will append
97 ; the PCE Errors starting at line @ACKARR+1. It is up to the calling
98 ; routine to clear the array @ACKARR before calling this function.
99 N ACKTMP,ACKCT,ACKSUB,TXT,TXT2,I
100 K ^TMP("ACKQUTL3",$J,"PCEERR")
101 S ACKTMP=$NA(^TMP("ACKQUTL3",$J,"PCEERR"))
102 S ACKNUM=+$G(ACKNUM)
103 S ACKWIDE=$S(+$G(ACKWIDE)<1:80,ACKWIDE<40:40,1:ACKWIDE)
104 I 'ACKNUM D GETS^DIQ(509850.6,ACKVIEN_",","6.5*","I",ACKTMP,"")
105 I ACKNUM D GETS^DIQ(509850.65,ACKNUM_","_ACKVIEN_",","*","I",ACKTMP,"")
106 S ACKCT=+$G(@ACKARR)
107 S ACKSUB="" F S ACKSUB=$O(@ACKTMP@(509850.65,ACKSUB)) Q:ACKSUB="" D
108 . I $P(ACKSUB,",",2)'=ACKVIEN Q
109 . ; field name and external value
110 . S TXT=@ACKTMP@(509850.65,ACKSUB,.02,"I")_" - "_@ACKTMP@(509850.65,ACKSUB,.04,"I")
111 . I $L(TXT)'>ACKWIDE D
112 . . S ACKCT=ACKCT+1,@ACKARR@(ACKCT)=TXT
113 . I $L(TXT)>ACKWIDE D
114 . . S TXT=$E(@ACKTMP@(509850.65,ACKSUB,.02,"I"),1,ACKWIDE)
115 . . S ACKCT=ACKCT+1,@ACKARR@(ACKCT)=TXT
116 . . S TXT=$E(@ACKTMP@(509850.65,ACKSUB,.04,"I"),1,ACKWIDE)
117 . . S ACKCT=ACKCT+1,@ACKARR@(ACKCT)=TXT
118 . ; pce error message
119 . S TXT=@ACKTMP@(509850.65,ACKSUB,1,"I")
120 . F Q:TXT="" D
121 . . S TXT2=$E(TXT,1,ACKWIDE),I=0
122 . . I $L(TXT2)=ACKWIDE F I=$L(TXT2):-1:0 Q:$E(TXT2,I)?1P
123 . . I I S TXT2=$E(TXT2,1,I)
124 . . S TXT=$P(TXT,TXT2,2,255)
125 . . S ACKCT=ACKCT+1,@ACKARR@(ACKCT)=TXT2
126 S @ACKARR=ACKCT
127 K ^TMP("ACKQUTL3",$J,"PCEERR")
128 Q
129 ;
130PROBLIST(ACKPAT,ACKECHO) ; re-build the problem list for a Patient
131 ; this function will run down the QUASAR Visits for a patient and
132 ; create an accurate problem list for the patient on the A&SP
133 ; PATIENT file. The function will be called from the Patient
134 ; Inquiry option and the Delete Visit function.
135 ; inputs:- ACKPAT - patient DFN
136 ; ACKECHO - whether to display progress
137 N ACKTMP,ACKVIEN,ACKDT,ACKDT1,ACKIVDT,ACKDIEN,ACKICD,ACKARR
138 ;
139 I '+$G(ACKPAT) Q
140 S ACKECHO=+$G(ACKECHO)
141 K ^TMP("ACKQUTL3",$J,"PROBLIST")
142 S ACKTMP=$NA(^TMP("ACKQUTL3",$J,"PROBLIST"))
143 ;
144 ; walk down the visits for a patient
145 S ACKIVDT=0
146 S ACKVIEN=0 F S ACKVIEN=$O(^ACK(509850.6,"APT",ACKPAT,ACKVIEN)) Q:'ACKVIEN D
147 . ; get visit date
148 . S ACKDT=+$$GET1^DIQ(509850.6,ACKVIEN_",",.01,"I")\1
149 . ; get Diagnosis multiple for this visit
150 . D GETS^DIQ(509850.6,ACKVIEN_",","3*","I",$NA(@ACKTMP@(1)))
151 . ; walk down the diagnosis multiple entries
152 . S ACKDIEN="" F S ACKDIEN=$O(@ACKTMP@(1,509850.63,ACKDIEN)) Q:ACKDIEN="" D
153 . . I $P(ACKDIEN,",",2)'=ACKVIEN Q
154 . . S ACKICD=@ACKTMP@(1,509850.63,ACKDIEN,.01,"I")
155 . . S ACKDT1=$G(@ACKTMP@(2,ACKICD))
156 . . I ('ACKDT1)!(ACKDT1>ACKDT) S @ACKTMP@(2,ACKICD)=ACKDT
157 . . I ('ACKIVDT)!(ACKIVDT>ACKDT) S ACKIVDT=ACKDT ; earliest visit date
158 ;
159 ; update initial visit date for the patient
160 K ACKARR
161 S ACKARR(509850.2,ACKPAT_",",1)=ACKIVDT
162 D FILE^DIE("","ACKARR","")
163 ;
164 ; clear down the diagnosis history for the patient
165 D GETS^DIQ(509850.2,ACKPAT_",","2*","I",$NA(@ACKTMP@(4)))
166 S ACKDIEN="" F S ACKDIEN=$O(@ACKTMP@(4,509850.22,ACKDIEN)) Q:ACKDIEN="" D
167 . I $P(ACKDIEN,",",2)'=ACKPAT Q
168 . K ACKARR
169 . S ACKARR(509850.22,ACKDIEN,.01)="@"
170 . D FILE^DIE("","ACKARR","")
171 ;
172 ; if no diagnosis history then display message
173 I ACKECHO,$O(@ACKTMP@(2,""))="" D G PROBLISX
174 . W !!,"No Diagnosis was found in the A&SP CLINIC VISIT file for this patient.",!
175 ;
176 ; sort new diagnosis list by date
177 S ACKICD="" F S ACKICD=$O(@ACKTMP@(2,ACKICD)) Q:ACKICD="" D
178 . S ACKDT=@ACKTMP@(2,ACKICD) S @ACKTMP@(3,ACKDT,ACKICD)=""
179 ;
180 ; update diagnosis history
181 I ACKECHO W !!,"Now updating diagnostic history.",!
182 S (ACKDT,ACKICD)="" F S ACKDT=$O(@ACKTMP@(3,ACKDT)) Q:ACKDT="" F S ACKICD=$O(@ACKTMP@(3,ACKDT,ACKICD)) Q:ACKICD="" D
183 . K ACKARR
184 . S ACKARR(509850.22,"?+1,"_ACKPAT_",",.01)=ACKICD
185 . S ACKARR(509850.22,"?+1,"_ACKPAT_",",1)=ACKDT
186 . D UPDATE^DIE("","ACKARR","","")
187 ;
188PROBLISX ; all done
189 K ^TMP("ACKQUTL3",$J,"PROBLIST")
190 Q
Note: See TracBrowser for help on using the repository browser.