- 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 Jan 18, 2025@03:34:01 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