ACKQUTL3 ;HCIOFO/AG - QUASAR Utility Routine ; 12/13/02 3:51pm
;;3.0;QUASAR;**5**;Feb 11, 2000
;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
;
PCECHKV(ACKVIEN) ; is PCE Visit still same patient etc.
; this function will check that the Qsr Visit (ACKVIEN) has the same
; values for Patient, Clinic, Date and Time as the PCE Visit that it
; points to.
; inputs:- ACKVIEN - QUASAR Visit IEN (reqd)
; outputs:- see function $$PCECHK below!
N ACKTGT,ACKPCE,ACKDT,ACKTM,ACKPAT,ACKCLN
D GETS^DIQ(509850.6,ACKVIEN_",",".01;125;1;2.6;55","I","ACKTGT")
S ACKPCE=$G(ACKTGT(509850.6,ACKVIEN_",",125,"I"))
I 'ACKPCE Q "2^" ; not pointing to a visit
S ACKDT=$G(ACKTGT(509850.6,ACKVIEN_",",.01,"I"))\1
S ACKTM=$G(ACKTGT(509850.6,ACKVIEN_",",55,"I"))
S ACKPAT=$G(ACKTGT(509850.6,ACKVIEN_",",1,"I"))
S ACKCLN=$G(ACKTGT(509850.6,ACKVIEN_",",2.6,"I"))
Q $$PCECHK(ACKPCE,ACKDT,ACKTM,ACKPAT,ACKCLN)
;
PCECHK(ACKPCE,ACKDT,ACKTM,ACKPAT,ACKCLN) ; is PCE Visit still same patient etc.
; this function will check that the Qsr Visit (ACKVIEN) has the same
; values for Patient, Clinic, Date and Time as the PCE Visit that it
; points to.
; inputs:- ACKPCE - PCE Visit IEN (reqd)
; ACKDT - date of visit (reqd) (fileman internal)
; ACKTM - time of visit (reqd) (qsr time .n[nnnnn])
; ACKPAT - patient (reqd)
; ACKCLN - clinic (reqd)
; outputs:- string
; value: "0^X^Y^Z" - either the date, patient or clinic differ
; where X=Clinics are same (1 or 0)
; Y=Patients are same (1 or 0)
; Z=Dates are same (1 or 0)
; eg "0^1^0^0" = patient and dates differ
; "1^.123" - only time is different (.123=Pce time)
; "2^" - all fields the same
N PCEDTTM,PCEDT,PCETM,PCEPAT,PCECLN,ACKSTR
K ^TMP("PXKENC",$J)
;
; get the visit data from PCE (places it in ^TMP("PXKENC",$J)
D ENCEVENT^PXAPI(ACKPCE)
S PCEDTTM=$P($G(^TMP("PXKENC",$J,ACKPCE,"VST",ACKPCE,0)),U,1)
S PCEDT=PCEDTTM\1,PCETM=PCEDTTM#1
S PCEPAT=$P($G(^TMP("PXKENC",$J,ACKPCE,"VST",ACKPCE,0)),U,5)
S PCECLN=$P($G(^TMP("PXKENC",$J,ACKPCE,"VST",ACKPCE,0)),U,22)
K ^TMP("PXKENC",$J)
;
; check date, patient and clinic
I (PCEDT'=ACKDT)!(PCEPAT'=ACKPAT)!(PCECLN'=ACKCLN) D Q ACKSTR
. S ACKSTR="0^"
. S $P(ACKSTR,U,2)=$S(PCECLN=ACKCLN:1,1:0)
. S $P(ACKSTR,U,3)=$S(PCEPAT=ACKPAT:1,1:0)
. S $P(ACKSTR,U,4)=$S(PCEDT=ACKDT:1,1:0)
;
; check Appointment time
I +PCETM'=+ACKTM Q "1^"_PCETM
;
; must be the same!
Q "2^"
;
DISPLAY(ACKVIEN,XPOS) ; create summary line for visit selection
N ACKPAT,ACKCLN,ACKTM,ACKTIME,ACKAM,ACKDISP,ACKLEN
S ACKTM=$$GET1^DIQ(509850.6,ACKVIEN_",",55,"I"),ACKTIME=$$FMT^ACKQUTL6(ACKTM,2)
S ACKPAT=$$GET1^DIQ(509850.6,ACKVIEN_",",1,"E")
S ACKCLN=$$GET1^DIQ(509850.6,ACKVIEN_",",2.6,"E")
S ACKP=$S($$GET1^DIQ(509850.6,ACKVIEN_",",125,"I"):".",1:" ")
I XPOS<35 D
. S ACKLEN=80-XPOS-10-2/2
. S ACKPAT=$E(ACKPAT_$J("",ACKLEN),1,ACKLEN\1)
. I $G(%)'="" D
. . I $TR(%,",","")'?.A D
. . . S ACKCLN=$E(ACKCLN_$J("",ACKLEN),1,ACKLEN+.5\1)
. . . S ACKDISP=" "_ACKTIME_ACKP_" "_ACKPAT_" "_ACKCLN
. . I $TR(%,",","")?.A D
. . . S ACKCLN=$E(ACKCLN,1,(40-$L(%)))
. . . S ACKDISP=" "_ACKTIME_ACKP_" "_ACKCLN
. I $G(%)="" D
. . S ACKCLN=$E(ACKCLN_$J("",ACKLEN),1,ACKLEN+.5\1)
. . S ACKDISP=" "_ACKTIME_ACKP_" "_ACKPAT_" "_ACKCLN
I XPOS'<35 D
. S ACKLEN=80-XPOS-10-1
. S ACKPAT=$E(ACKPAT_$J("",ACKLEN),1,ACKLEN)
. S ACKDISP=" "_ACKTIME_ACKP_" "_ACKPAT
Q ACKDISP
;
PCEERR(ACKVIEN,ACKARR,ACKNUM,ACKWIDE) ; retrieve PCE Errors for a visit and store in ACKARR
; inputs:- ACKVIEN - visit ien (reqd)
; ACKARR - array name in which to place errors (indirection
; used to file data ie @ACKARR@(x) (reqd)
; ACKNUM - Error number (if only one reqd) (opt)
; ACKWIDE - max number of characters in each line (opt)
; outputs:-
; ACKARR=n - number of lines to display
; ACKARR(1-n)=text - text of error (wrapped to ACKWIDE characters)
; if @ACKARR already contains data then this subroutine will append
; the PCE Errors starting at line @ACKARR+1. It is up to the calling
; routine to clear the array @ACKARR before calling this function.
N ACKTMP,ACKCT,ACKSUB,TXT,TXT2,I
K ^TMP("ACKQUTL3",$J,"PCEERR")
S ACKTMP=$NA(^TMP("ACKQUTL3",$J,"PCEERR"))
S ACKNUM=+$G(ACKNUM)
S ACKWIDE=$S(+$G(ACKWIDE)<1:80,ACKWIDE<40:40,1:ACKWIDE)
I 'ACKNUM D GETS^DIQ(509850.6,ACKVIEN_",","6.5*","I",ACKTMP,"")
I ACKNUM D GETS^DIQ(509850.65,ACKNUM_","_ACKVIEN_",","*","I",ACKTMP,"")
S ACKCT=+$G(@ACKARR)
S ACKSUB="" F S ACKSUB=$O(@ACKTMP@(509850.65,ACKSUB)) Q:ACKSUB="" D
. I $P(ACKSUB,",",2)'=ACKVIEN Q
. ; field name and external value
. S TXT=@ACKTMP@(509850.65,ACKSUB,.02,"I")_" - "_@ACKTMP@(509850.65,ACKSUB,.04,"I")
. I $L(TXT)'>ACKWIDE D
. . S ACKCT=ACKCT+1,@ACKARR@(ACKCT)=TXT
. I $L(TXT)>ACKWIDE D
. . S TXT=$E(@ACKTMP@(509850.65,ACKSUB,.02,"I"),1,ACKWIDE)
. . S ACKCT=ACKCT+1,@ACKARR@(ACKCT)=TXT
. . S TXT=$E(@ACKTMP@(509850.65,ACKSUB,.04,"I"),1,ACKWIDE)
. . S ACKCT=ACKCT+1,@ACKARR@(ACKCT)=TXT
. ; pce error message
. S TXT=@ACKTMP@(509850.65,ACKSUB,1,"I")
. F Q:TXT="" D
. . S TXT2=$E(TXT,1,ACKWIDE),I=0
. . I $L(TXT2)=ACKWIDE F I=$L(TXT2):-1:0 Q:$E(TXT2,I)?1P
. . I I S TXT2=$E(TXT2,1,I)
. . S TXT=$P(TXT,TXT2,2,255)
. . S ACKCT=ACKCT+1,@ACKARR@(ACKCT)=TXT2
S @ACKARR=ACKCT
K ^TMP("ACKQUTL3",$J,"PCEERR")
Q
;
PROBLIST(ACKPAT,ACKECHO) ; re-build the problem list for a Patient
; this function will run down the QUASAR Visits for a patient and
; create an accurate problem list for the patient on the A&SP
; PATIENT file. The function will be called from the Patient
; Inquiry option and the Delete Visit function.
; inputs:- ACKPAT - patient DFN
; ACKECHO - whether to display progress
N ACKTMP,ACKVIEN,ACKDT,ACKDT1,ACKIVDT,ACKDIEN,ACKICD,ACKARR
;
I '+$G(ACKPAT) Q
S ACKECHO=+$G(ACKECHO)
K ^TMP("ACKQUTL3",$J,"PROBLIST")
S ACKTMP=$NA(^TMP("ACKQUTL3",$J,"PROBLIST"))
;
; walk down the visits for a patient
S ACKIVDT=0
S ACKVIEN=0 F S ACKVIEN=$O(^ACK(509850.6,"APT",ACKPAT,ACKVIEN)) Q:'ACKVIEN D
. ; get visit date
. S ACKDT=+$$GET1^DIQ(509850.6,ACKVIEN_",",.01,"I")\1
. ; get Diagnosis multiple for this visit
. D GETS^DIQ(509850.6,ACKVIEN_",","3*","I",$NA(@ACKTMP@(1)))
. ; walk down the diagnosis multiple entries
. S ACKDIEN="" F S ACKDIEN=$O(@ACKTMP@(1,509850.63,ACKDIEN)) Q:ACKDIEN="" D
. . I $P(ACKDIEN,",",2)'=ACKVIEN Q
. . S ACKICD=@ACKTMP@(1,509850.63,ACKDIEN,.01,"I")
. . S ACKDT1=$G(@ACKTMP@(2,ACKICD))
. . I ('ACKDT1)!(ACKDT1>ACKDT) S @ACKTMP@(2,ACKICD)=ACKDT
. . I ('ACKIVDT)!(ACKIVDT>ACKDT) S ACKIVDT=ACKDT ; earliest visit date
;
; update initial visit date for the patient
K ACKARR
S ACKARR(509850.2,ACKPAT_",",1)=ACKIVDT
D FILE^DIE("","ACKARR","")
;
; clear down the diagnosis history for the patient
D GETS^DIQ(509850.2,ACKPAT_",","2*","I",$NA(@ACKTMP@(4)))
S ACKDIEN="" F S ACKDIEN=$O(@ACKTMP@(4,509850.22,ACKDIEN)) Q:ACKDIEN="" D
. I $P(ACKDIEN,",",2)'=ACKPAT Q
. K ACKARR
. S ACKARR(509850.22,ACKDIEN,.01)="@"
. D FILE^DIE("","ACKARR","")
;
; if no diagnosis history then display message
I ACKECHO,$O(@ACKTMP@(2,""))="" D G PROBLISX
. W !!,"No Diagnosis was found in the A&SP CLINIC VISIT file for this patient.",!
;
; sort new diagnosis list by date
S ACKICD="" F S ACKICD=$O(@ACKTMP@(2,ACKICD)) Q:ACKICD="" D
. S ACKDT=@ACKTMP@(2,ACKICD) S @ACKTMP@(3,ACKDT,ACKICD)=""
;
; update diagnosis history
I ACKECHO W !!,"Now updating diagnostic history.",!
S (ACKDT,ACKICD)="" F S ACKDT=$O(@ACKTMP@(3,ACKDT)) Q:ACKDT="" F S ACKICD=$O(@ACKTMP@(3,ACKDT,ACKICD)) Q:ACKICD="" D
. K ACKARR
. S ACKARR(509850.22,"?+1,"_ACKPAT_",",.01)=ACKICD
. S ACKARR(509850.22,"?+1,"_ACKPAT_",",1)=ACKDT
. D UPDATE^DIE("","ACKARR","","")
;
PROBLISX ; all done
K ^TMP("ACKQUTL3",$J,"PROBLIST")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQUTL3 8145 printed Oct 16, 2024@18:33:36 Page 2
ACKQUTL3 ;HCIOFO/AG - QUASAR Utility Routine ; 12/13/02 3:51pm
+1 ;;3.0;QUASAR;**5**;Feb 11, 2000
+2 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
+3 ;
PCECHKV(ACKVIEN) ; is PCE Visit still same patient etc.
+1 ; this function will check that the Qsr Visit (ACKVIEN) has the same
+2 ; values for Patient, Clinic, Date and Time as the PCE Visit that it
+3 ; points to.
+4 ; inputs:- ACKVIEN - QUASAR Visit IEN (reqd)
+5 ; outputs:- see function $$PCECHK below!
+6 NEW ACKTGT,ACKPCE,ACKDT,ACKTM,ACKPAT,ACKCLN
+7 DO GETS^DIQ(509850.6,ACKVIEN_",",".01;125;1;2.6;55","I","ACKTGT")
+8 SET ACKPCE=$GET(ACKTGT(509850.6,ACKVIEN_",",125,"I"))
+9 ; not pointing to a visit
IF 'ACKPCE
QUIT "2^"
+10 SET ACKDT=$GET(ACKTGT(509850.6,ACKVIEN_",",.01,"I"))\1
+11 SET ACKTM=$GET(ACKTGT(509850.6,ACKVIEN_",",55,"I"))
+12 SET ACKPAT=$GET(ACKTGT(509850.6,ACKVIEN_",",1,"I"))
+13 SET ACKCLN=$GET(ACKTGT(509850.6,ACKVIEN_",",2.6,"I"))
+14 QUIT $$PCECHK(ACKPCE,ACKDT,ACKTM,ACKPAT,ACKCLN)
+15 ;
PCECHK(ACKPCE,ACKDT,ACKTM,ACKPAT,ACKCLN) ; is PCE Visit still same patient etc.
+1 ; this function will check that the Qsr Visit (ACKVIEN) has the same
+2 ; values for Patient, Clinic, Date and Time as the PCE Visit that it
+3 ; points to.
+4 ; inputs:- ACKPCE - PCE Visit IEN (reqd)
+5 ; ACKDT - date of visit (reqd) (fileman internal)
+6 ; ACKTM - time of visit (reqd) (qsr time .n[nnnnn])
+7 ; ACKPAT - patient (reqd)
+8 ; ACKCLN - clinic (reqd)
+9 ; outputs:- string
+10 ; value: "0^X^Y^Z" - either the date, patient or clinic differ
+11 ; where X=Clinics are same (1 or 0)
+12 ; Y=Patients are same (1 or 0)
+13 ; Z=Dates are same (1 or 0)
+14 ; eg "0^1^0^0" = patient and dates differ
+15 ; "1^.123" - only time is different (.123=Pce time)
+16 ; "2^" - all fields the same
+17 NEW PCEDTTM,PCEDT,PCETM,PCEPAT,PCECLN,ACKSTR
+18 KILL ^TMP("PXKENC",$JOB)
+19 ;
+20 ; get the visit data from PCE (places it in ^TMP("PXKENC",$J)
+21 DO ENCEVENT^PXAPI(ACKPCE)
+22 SET PCEDTTM=$PIECE($GET(^TMP("PXKENC",$JOB,ACKPCE,"VST",ACKPCE,0)),U,1)
+23 SET PCEDT=PCEDTTM\1
SET PCETM=PCEDTTM#1
+24 SET PCEPAT=$PIECE($GET(^TMP("PXKENC",$JOB,ACKPCE,"VST",ACKPCE,0)),U,5)
+25 SET PCECLN=$PIECE($GET(^TMP("PXKENC",$JOB,ACKPCE,"VST",ACKPCE,0)),U,22)
+26 KILL ^TMP("PXKENC",$JOB)
+27 ;
+28 ; check date, patient and clinic
+29 IF (PCEDT'=ACKDT)!(PCEPAT'=ACKPAT)!(PCECLN'=ACKCLN)
Begin DoDot:1
+30 SET ACKSTR="0^"
+31 SET $PIECE(ACKSTR,U,2)=$SELECT(PCECLN=ACKCLN:1,1:0)
+32 SET $PIECE(ACKSTR,U,3)=$SELECT(PCEPAT=ACKPAT:1,1:0)
+33 SET $PIECE(ACKSTR,U,4)=$SELECT(PCEDT=ACKDT:1,1:0)
End DoDot:1
QUIT ACKSTR
+34 ;
+35 ; check Appointment time
+36 IF +PCETM'=+ACKTM
QUIT "1^"_PCETM
+37 ;
+38 ; must be the same!
+39 QUIT "2^"
+40 ;
DISPLAY(ACKVIEN,XPOS) ; create summary line for visit selection
+1 NEW ACKPAT,ACKCLN,ACKTM,ACKTIME,ACKAM,ACKDISP,ACKLEN
+2 SET ACKTM=$$GET1^DIQ(509850.6,ACKVIEN_",",55,"I")
SET ACKTIME=$$FMT^ACKQUTL6(ACKTM,2)
+3 SET ACKPAT=$$GET1^DIQ(509850.6,ACKVIEN_",",1,"E")
+4 SET ACKCLN=$$GET1^DIQ(509850.6,ACKVIEN_",",2.6,"E")
+5 SET ACKP=$SELECT($$GET1^DIQ(509850.6,ACKVIEN_",",125,"I"):".",1:" ")
+6 IF XPOS<35
Begin DoDot:1
+7 SET ACKLEN=80-XPOS-10-2/2
+8 SET ACKPAT=$EXTRACT(ACKPAT_$JUSTIFY("",ACKLEN),1,ACKLEN\1)
+9 IF $GET(%)'=""
Begin DoDot:2
+10 IF $TRANSLATE(%,",","")'?.A
Begin DoDot:3
+11 SET ACKCLN=$EXTRACT(ACKCLN_$JUSTIFY("",ACKLEN),1,ACKLEN+.5\1)
+12 SET ACKDISP=" "_ACKTIME_ACKP_" "_ACKPAT_" "_ACKCLN
End DoDot:3
+13 IF $TRANSLATE(%,",","")?.A
Begin DoDot:3
+14 SET ACKCLN=$EXTRACT(ACKCLN,1,(40-$LENGTH(%)))
+15 SET ACKDISP=" "_ACKTIME_ACKP_" "_ACKCLN
End DoDot:3
End DoDot:2
+16 IF $GET(%)=""
Begin DoDot:2
+17 SET ACKCLN=$EXTRACT(ACKCLN_$JUSTIFY("",ACKLEN),1,ACKLEN+.5\1)
+18 SET ACKDISP=" "_ACKTIME_ACKP_" "_ACKPAT_" "_ACKCLN
End DoDot:2
End DoDot:1
+19 IF XPOS'<35
Begin DoDot:1
+20 SET ACKLEN=80-XPOS-10-1
+21 SET ACKPAT=$EXTRACT(ACKPAT_$JUSTIFY("",ACKLEN),1,ACKLEN)
+22 SET ACKDISP=" "_ACKTIME_ACKP_" "_ACKPAT
End DoDot:1
+23 QUIT ACKDISP
+24 ;
PCEERR(ACKVIEN,ACKARR,ACKNUM,ACKWIDE) ; retrieve PCE Errors for a visit and store in ACKARR
+1 ; inputs:- ACKVIEN - visit ien (reqd)
+2 ; ACKARR - array name in which to place errors (indirection
+3 ; used to file data ie @ACKARR@(x) (reqd)
+4 ; ACKNUM - Error number (if only one reqd) (opt)
+5 ; ACKWIDE - max number of characters in each line (opt)
+6 ; outputs:-
+7 ; ACKARR=n - number of lines to display
+8 ; ACKARR(1-n)=text - text of error (wrapped to ACKWIDE characters)
+9 ; if @ACKARR already contains data then this subroutine will append
+10 ; the PCE Errors starting at line @ACKARR+1. It is up to the calling
+11 ; routine to clear the array @ACKARR before calling this function.
+12 NEW ACKTMP,ACKCT,ACKSUB,TXT,TXT2,I
+13 KILL ^TMP("ACKQUTL3",$JOB,"PCEERR")
+14 SET ACKTMP=$NAME(^TMP("ACKQUTL3",$JOB,"PCEERR"))
+15 SET ACKNUM=+$GET(ACKNUM)
+16 SET ACKWIDE=$SELECT(+$GET(ACKWIDE)<1:80,ACKWIDE<40:40,1:ACKWIDE)
+17 IF 'ACKNUM
DO GETS^DIQ(509850.6,ACKVIEN_",","6.5*","I",ACKTMP,"")
+18 IF ACKNUM
DO GETS^DIQ(509850.65,ACKNUM_","_ACKVIEN_",","*","I",ACKTMP,"")
+19 SET ACKCT=+$GET(@ACKARR)
+20 SET ACKSUB=""
FOR
SET ACKSUB=$ORDER(@ACKTMP@(509850.65,ACKSUB))
if ACKSUB=""
QUIT
Begin DoDot:1
+21 IF $PIECE(ACKSUB,",",2)'=ACKVIEN
QUIT
+22 ; field name and external value
+23 SET TXT=@ACKTMP@(509850.65,ACKSUB,.02,"I")_" - "_@ACKTMP@(509850.65,ACKSUB,.04,"I")
+24 IF $LENGTH(TXT)'>ACKWIDE
Begin DoDot:2
+25 SET ACKCT=ACKCT+1
SET @ACKARR@(ACKCT)=TXT
End DoDot:2
+26 IF $LENGTH(TXT)>ACKWIDE
Begin DoDot:2
+27 SET TXT=$EXTRACT(@ACKTMP@(509850.65,ACKSUB,.02,"I"),1,ACKWIDE)
+28 SET ACKCT=ACKCT+1
SET @ACKARR@(ACKCT)=TXT
+29 SET TXT=$EXTRACT(@ACKTMP@(509850.65,ACKSUB,.04,"I"),1,ACKWIDE)
+30 SET ACKCT=ACKCT+1
SET @ACKARR@(ACKCT)=TXT
End DoDot:2
+31 ; pce error message
+32 SET TXT=@ACKTMP@(509850.65,ACKSUB,1,"I")
+33 FOR
if TXT=""
QUIT
Begin DoDot:2
+34 SET TXT2=$EXTRACT(TXT,1,ACKWIDE)
SET I=0
+35 IF $LENGTH(TXT2)=ACKWIDE
FOR I=$LENGTH(TXT2):-1:0
if $EXTRACT(TXT2,I)?1P
QUIT
+36 IF I
SET TXT2=$EXTRACT(TXT2,1,I)
+37 SET TXT=$PIECE(TXT,TXT2,2,255)
+38 SET ACKCT=ACKCT+1
SET @ACKARR@(ACKCT)=TXT2
End DoDot:2
End DoDot:1
+39 SET @ACKARR=ACKCT
+40 KILL ^TMP("ACKQUTL3",$JOB,"PCEERR")
+41 QUIT
+42 ;
PROBLIST(ACKPAT,ACKECHO) ; re-build the problem list for a Patient
+1 ; this function will run down the QUASAR Visits for a patient and
+2 ; create an accurate problem list for the patient on the A&SP
+3 ; PATIENT file. The function will be called from the Patient
+4 ; Inquiry option and the Delete Visit function.
+5 ; inputs:- ACKPAT - patient DFN
+6 ; ACKECHO - whether to display progress
+7 NEW ACKTMP,ACKVIEN,ACKDT,ACKDT1,ACKIVDT,ACKDIEN,ACKICD,ACKARR
+8 ;
+9 IF '+$GET(ACKPAT)
QUIT
+10 SET ACKECHO=+$GET(ACKECHO)
+11 KILL ^TMP("ACKQUTL3",$JOB,"PROBLIST")
+12 SET ACKTMP=$NAME(^TMP("ACKQUTL3",$JOB,"PROBLIST"))
+13 ;
+14 ; walk down the visits for a patient
+15 SET ACKIVDT=0
+16 SET ACKVIEN=0
FOR
SET ACKVIEN=$ORDER(^ACK(509850.6,"APT",ACKPAT,ACKVIEN))
if 'ACKVIEN
QUIT
Begin DoDot:1
+17 ; get visit date
+18 SET ACKDT=+$$GET1^DIQ(509850.6,ACKVIEN_",",.01,"I")\1
+19 ; get Diagnosis multiple for this visit
+20 DO GETS^DIQ(509850.6,ACKVIEN_",","3*","I",$NAME(@ACKTMP@(1)))
+21 ; walk down the diagnosis multiple entries
+22 SET ACKDIEN=""
FOR
SET ACKDIEN=$ORDER(@ACKTMP@(1,509850.63,ACKDIEN))
if ACKDIEN=""
QUIT
Begin DoDot:2
+23 IF $PIECE(ACKDIEN,",",2)'=ACKVIEN
QUIT
+24 SET ACKICD=@ACKTMP@(1,509850.63,ACKDIEN,.01,"I")
+25 SET ACKDT1=$GET(@ACKTMP@(2,ACKICD))
+26 IF ('ACKDT1)!(ACKDT1>ACKDT)
SET @ACKTMP@(2,ACKICD)=ACKDT
+27 ; earliest visit date
IF ('ACKIVDT)!(ACKIVDT>ACKDT)
SET ACKIVDT=ACKDT
End DoDot:2
End DoDot:1
+28 ;
+29 ; update initial visit date for the patient
+30 KILL ACKARR
+31 SET ACKARR(509850.2,ACKPAT_",",1)=ACKIVDT
+32 DO FILE^DIE("","ACKARR","")
+33 ;
+34 ; clear down the diagnosis history for the patient
+35 DO GETS^DIQ(509850.2,ACKPAT_",","2*","I",$NAME(@ACKTMP@(4)))
+36 SET ACKDIEN=""
FOR
SET ACKDIEN=$ORDER(@ACKTMP@(4,509850.22,ACKDIEN))
if ACKDIEN=""
QUIT
Begin DoDot:1
+37 IF $PIECE(ACKDIEN,",",2)'=ACKPAT
QUIT
+38 KILL ACKARR
+39 SET ACKARR(509850.22,ACKDIEN,.01)="@"
+40 DO FILE^DIE("","ACKARR","")
End DoDot:1
+41 ;
+42 ; if no diagnosis history then display message
+43 IF ACKECHO
IF $ORDER(@ACKTMP@(2,""))=""
Begin DoDot:1
+44 WRITE !!,"No Diagnosis was found in the A&SP CLINIC VISIT file for this patient.",!
End DoDot:1
GOTO PROBLISX
+45 ;
+46 ; sort new diagnosis list by date
+47 SET ACKICD=""
FOR
SET ACKICD=$ORDER(@ACKTMP@(2,ACKICD))
if ACKICD=""
QUIT
Begin DoDot:1
+48 SET ACKDT=@ACKTMP@(2,ACKICD)
SET @ACKTMP@(3,ACKDT,ACKICD)=""
End DoDot:1
+49 ;
+50 ; update diagnosis history
+51 IF ACKECHO
WRITE !!,"Now updating diagnostic history.",!
+52 SET (ACKDT,ACKICD)=""
FOR
SET ACKDT=$ORDER(@ACKTMP@(3,ACKDT))
if ACKDT=""
QUIT
FOR
SET ACKICD=$ORDER(@ACKTMP@(3,ACKDT,ACKICD))
if ACKICD=""
QUIT
Begin DoDot:1
+53 KILL ACKARR
+54 SET ACKARR(509850.22,"?+1,"_ACKPAT_",",.01)=ACKICD
+55 SET ACKARR(509850.22,"?+1,"_ACKPAT_",",1)=ACKDT
+56 DO UPDATE^DIE("","ACKARR","","")
End DoDot:1
+57 ;
PROBLISX ; all done
+1 KILL ^TMP("ACKQUTL3",$JOB,"PROBLIST")
+2 QUIT
