- ACKQASU4 ;HCIOFO/AG - New/Edit Visit Utilities ;18 Nov 2013 4:38 PM
- ;;3.0;QUASAR;**17,22,21**;Feb 11, 2000;Build 40
- ;Per VHA Directive 2004-038, this routine SHOULD NOT be modified.
- ;
- ; Reference/ICR
- ; $$CODEC^ICDEX - 5747
- ; $$MOD^ICPTMOD - 1996
- ; $$CPT^ICPTCOD - 1995
- ;
- COPYPCE(ACKVIEN,ACKPCENO) ; Copies the visit data from given PCE Visit
- ; inputs:- ACKVIEN - QUASAR Visit ien to receive data
- ; ACKPCENO - PCE Visit ien to copy from
- ; outputs:- 0^ - everything ok
- ; n^ - n errors found
- ; errors filed in ^TMP("ACKQASU4",$J,"COPYPCE","ERROR",n)=field^int^ext^message
- ; NB. In the validation of Dx and CPT codes, the Visit Stop Code (A,S,
- ; AT or ST) is read from the Qsr Visit record. For this validation to
- ; work therefore, the Visit Stop Code must already be filed on the Qsr
- ; visit.
- N ACKERR,ACKARR,ACKVELG,ACKI,ACKICD,ACKE,ACKTMP,ACKPRIM,ACKSTUD
- N ACKSC,ACKAO,ACKIR,ACKEC,ACKREC,ACKPRV,ACKTYP,ACKCPT,ACKQTY,ACKVTME
- N ACKDPRIM,ACKQPRV,ACKPRVCK
- K ^TMP("ACKQASU4",$J,"COPYPCE") ; initialise return array
- S ACKERR=0 ; error counter
- ;
- ; get the PCE Visit data - returned in ^TMP("PXKENC",$J,pce ien,...)
- D ENCEVENT^PXAPI(ACKPCENO,"")
- ;
- ; Get Diagnostic codes
- S ACKI="",ACKDPRIM=""
- F S ACKI=$O(^TMP("PXKENC",$J,ACKPCENO,"POV",ACKI)) Q:ACKI="" D
- . S ACKICD=$P($G(^TMP("PXKENC",$J,ACKPCENO,"POV",ACKI,0)),U,1) ; icd ien
- . I ACKDPRIM="",$P($G(^TMP("PXKENC",$J,ACKPCENO,"POV",ACKI,0)),U,12)="P" S ACKDPRIM=1
- . ; add to visit
- . S ACKE=$$SETDIAG^ACKQASU5(ACKVIEN,ACKICD,ACKDPRIM)
- . I ACKDPRIM S ACKDPRIM="0"
- . ; if error returned then file
- . I 'ACKE D Q
- . . ;ACKQ*3.0*22 updated api
- . . S ACKTMP="Diagnosis"_U_ACKICD_U_$$CODEC^ICDEX(80,ACKICD)_U_$P(ACKE,U,2)
- . . D ADDERR
- . ; if successful then ensure Diagnosis is added to Patient Diagnostic history
- . D DIAGHIST
- ;
- ; get all the providers and file
- S ACKI="",ACKPRIM="",ACKSTUD=""
- F S ACKI=$O(^TMP("PXKENC",$J,ACKPCENO,"PRV",ACKI)) Q:ACKI="" D
- . S ACKREC=$G(^TMP("PXKENC",$J,ACKPCENO,"PRV",ACKI,0))
- . S ACKPRV=$P(ACKREC,U,1) ; provider ien
- . S ACKTYP=$P(ACKREC,U,4) ; primary/secondary
- . I ACKTYP="P" D COPYPRIM Q ; copy primary provider
- . I ACKTYP="S" D COPYSCND Q ; copy secondary provider
- ;
- ; Get procedure codes
- S ACKI=""
- F S ACKI=$O(^TMP("PXKENC",$J,ACKPCENO,"CPT",ACKI)) Q:ACKI="" D
- . S ACKREC=$G(^TMP("PXKENC",$J,ACKPCENO,"CPT",ACKI,0))
- . S ACKCPT=$P(ACKREC,U,1),ACKQTY=$P(ACKREC,U,16) ; unpack cpt and volume
- . ; Get Procedure Provider
- . S ACKPRV=$P($G(^TMP("PXKENC",$J,ACKPCENO,"CPT",ACKI,12)),U,4)
- . S ACKQPRV=$$PROVCHK(ACKPRV)
- . I ACKPRV'="" D
- . . S ACKPRVCK=$$STACT^ACKQUTL(ACKQPRV,ACKVD)
- . . I ACKPRVCK'="0",ACKPRVCK'="-6" D
- . . . S ACKTMP="Provider"_U_ACKPRV_U_$$GET1^DIQ(200,ACKPRV_",",.01,"E")_U
- . . . S ACKTMP=ACKTMP_"Invalid Procedure Provider"
- . . . D ADDERR
- . . . S ACKQPRV=""
- . ; add to visit
- . S ACKE=$$SETPROC^ACKQASU5(ACKVIEN,ACKCPT,ACKQTY,ACKQPRV)
- . ; if error returned then file
- . I 'ACKE D Q
- . . ;ACKQ*3.0*22 updated api
- . . S ACKTMP="Procedure"_U_ACKCPT_U_$P($$CPT^ICPTCOD(ACKCPT),U,2)_U_$P(ACKE,U,2)
- . . D ADDERR
- . ; if successful then do the modifiers for this procedure
- . S ACKM=0,ACKPIEN=+ACKE ; ACKPIEN=procedure ien from visit file
- . F S ACKM=$O(^TMP("PXKENC",$J,ACKPCENO,"CPT",ACKI,1,ACKM)) Q:'ACKM D
- . . S ACKMOD=$P($G(^TMP("PXKENC",$J,ACKPCENO,"CPT",ACKI,1,ACKM,0)),U,1)
- . . ; add to visit
- . . S ACKE=$$SETMDFR^ACKQASU5(ACKVIEN,ACKPIEN,ACKMOD)
- . . ; if error returned then file
- . . I '+ACKE D Q
- . . . ;ACKQ*3.0*22 updated api
- . . . S ACKTMP="Modifier"_U_ACKMOD_U_$P($$MOD^ICPTMOD(ACKMOD,"I"),U,2)_U_$P(ACKE,U,2)
- . . . D ADDERR
- ;
- ; now file header items
- K ACKARR,ACKPRV
- ;
- ; If PCE visit has an eligibility write to a&sp visit file
- S ACKVELG=$P($G(^TMP("PXKENC",$J,ACKPCENO,"VST",ACKPCENO,0)),U,21)
- I ACKVELG'="" S ACKARR(509850.6,ACKVIEN_",",80)=ACKVELG
- ;
- ; Get service connected,Agent Orange,Radiation and Environmental
- ; Contaminents from PCE file and set them to the Visit file.
- S ACKREC=$G(^TMP("PXKENC",$J,ACKPCENO,"VST",ACKPCENO,800))
- S ACKSC=$P(ACKREC,U,1) ; service connected
- S ACKAO=$P(ACKREC,U,2) ; agent orange
- S ACKIR=$P(ACKREC,U,3) ; ionizing radiation
- S ACKEC=$P(ACKREC,U,4) ; environmental contaminants
- S ACKARR(509850.6,ACKVIEN_",",20)=$S(+ACKSC:1,ACKSC=0:0,1:"")
- S ACKARR(509850.6,ACKVIEN_",",25)=$S(+ACKAO:1,ACKAO=0:0,1:"")
- S ACKARR(509850.6,ACKVIEN_",",30)=$S(+ACKIR:1,ACKIR=0:0,1:"")
- S ACKARR(509850.6,ACKVIEN_",",35)=$S(+ACKEC:1,ACKEC=0:0,1:"")
- ;
- ; Update QUASAR visit record
- D FILE^DIE("","ACKARR")
- K ACKARR
- ;
- COPYPCEX ; Exit point
- K ^TMP("PXKENC",$J) ; Clear PCE data
- I ACKERR S ^TMP("ACKQASU4",$J,"COPYPCE","ERROR")=ACKERR ; final error count
- Q ACKERR_U ; return error count
- ;
- ;
- COPYPRIM ; Copy the primary provider to QUASAR
- ;
- ; If we haven't successfully filed a primary then attempt to
- I ACKPRIM="" D Q ;
- . S ACKQPRV=$$PROVCHK(ACKPRV)
- . S ACKE=$$SETPRIM^ACKQASU6(ACKVIEN,ACKQPRV) ; Attempt to add to visit
- . I +ACKE S ACKPRIM=ACKQPRV ; Record that we now have a primary
- . I '+ACKE D ; error occurred
- . . S ACKTMP="Provider"_U_ACKPRV_U_$$GET1^DIQ(200,ACKPRV_",",.01,"E")_U
- . . S ACKTMP=ACKTMP_$P(ACKE,U,2)
- . . D ADDERR
- ;
- ; if we already have a primary then add an error message
- S ACKTMP="Provider"_U_ACKPRV_U_$$GET1^DIQ(200,ACKPRV_",",.01,"E")_U
- S ACKTMP=ACKTMP_"Visit already has a Primary Provider"
- D ADDERR
- ;
- ; return to provider loop
- Q
- ;
- COPYSCND ; copy a secondary provider to QUASAR
- ;
- ; determine the Quasar classification for this provider
- S ACKQPRV=$$PROVCHK(ACKPRV)
- S ACKTYPQ=$$GET1^DIQ(509850.3,$S(ACKQPRV="":" ",1:ACKQPRV)_",",.02,"I")
- ;
- ; if they are a student and we haven't one already,
- ; then attempt to file as student
- I ACKTYPQ="S",ACKSTUD="" D Q ; student
- . S ACKE=$$SETSTUD^ACKQASU6(ACKVIEN,ACKQPRV)
- . I +ACKE S ACKSTUD=ACKQPRV Q ; record that we now have a student
- . I '+ACKE D ; Error occurred
- . . S ACKTMP="Student"_U_ACKPRV_U_$$GET1^DIQ(200,ACKPRV_",",.01,"E")_U
- . . S ACKTMP=ACKTMP_$P(ACKE,U,2)
- . . D ADDERR
- ;
- ; if they are a student and we already have one then set error
- I ACKTYPQ="S",ACKSTUD'="" D Q
- . S ACKTMP="Student"_U_ACKPRV_U_$$GET1^DIQ(200,ACKPRV_",",.01,"E")_U
- . S ACKTMP=ACKTMP_"Visit already has a Student"
- . D ADDERR
- ;
- ; if they are a regular provider, and we do not already have
- ; a secondary provider then attempt to file
- I (ACKTYPQ="C")!(ACKTYPQ="F")!(ACKTYPQ="O") D Q
- . S ACKE=$$SETSCND^ACKQASU6(ACKVIEN,ACKQPRV) ; attempt to add to visit
- . I +ACKE Q ; All okay
- . I '+ACKE D ; Error occurred
- . . S ACKTMP="Provider"_U_ACKPRV_U_$$GET1^DIQ(200,ACKPRV_",",.01,"E")_U
- . . S ACKTMP=ACKTMP_$P(ACKE,U,2)
- . . D ADDERR
- ;
- ; if we get this far then provider must be unknown to Quasar
- S ACKTMP="Provider"_U_ACKPRV_U_$$GET1^DIQ(200,ACKPRV_",",.01,"E")_U
- S ACKTMP=ACKTMP_"Provider not defined for Audiology and Speech Pathology"
- D ADDERR
- ;
- ; end of checking a secondary provider
- Q
- ;
- ADDERR ; add an error to return array in ^TMP
- ; ACKERR is current error count, ACKTMP is the error detail
- S ACKERR=ACKERR+1
- S ^TMP("ACKQASU4",$J,"COPYPCE","ERROR",ACKERR)=ACKTMP
- Q
- ;
- DIAGHIST ; ensure diagnosis is on Patient history
- ; this s/r checks for ACKICD (diagnosis ien) on the patient history
- ; of patient ACKPAT
- ; if the ICD is not found a new entry is automatically added using the
- ; visit date in ACKVD
- N ACKTGT
- ;
- ; look for the diagnosis on the current history
- D FIND^DIC(509850.22,","_ACKPAT_",","","Q",ACKICD,1,"B","","","ACKTGT")
- ;
- ; if found then exit
- I +$P($G(ACKTGT("DILIST",0)),U,1)=1 Q ; exactly one found
- ;
- ; create a new entry
- S ACKUPD(509850.22,"+1,"_ACKPAT_",",.01)=ACKICD
- S ACKUPD(509850.22,"+1,"_ACKPAT_",",1)=ACKVD
- D UPDATE^DIE("","ACKUPD","","")
- ;
- ; end
- Q
- ;
- PROVCHK(ACKPRV) ; Check to see if Provider is on Quasar Staff file - if so
- ; function passes back Quasars Provider IEN No else null
- ;
- N ACKA,ACKB,NPNAME S ACKB=""
- I ACKPRV="" Q ACKB
- ;ACKQ*3*17
- S NPNAME=$$GET1^DIQ(200,ACKPRV,.01,"")
- I '$D(^ACK(509850.3,"B",NPNAME)) Q ACKB
- Q $O(^ACK(509850.3,"B",NPNAME,ACKB))
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQASU4 8339 printed Feb 18, 2025@23:58:20 Page 2
- ACKQASU4 ;HCIOFO/AG - New/Edit Visit Utilities ;18 Nov 2013 4:38 PM
- +1 ;;3.0;QUASAR;**17,22,21**;Feb 11, 2000;Build 40
- +2 ;Per VHA Directive 2004-038, this routine SHOULD NOT be modified.
- +3 ;
- +4 ; Reference/ICR
- +5 ; $$CODEC^ICDEX - 5747
- +6 ; $$MOD^ICPTMOD - 1996
- +7 ; $$CPT^ICPTCOD - 1995
- +8 ;
- COPYPCE(ACKVIEN,ACKPCENO) ; Copies the visit data from given PCE Visit
- +1 ; inputs:- ACKVIEN - QUASAR Visit ien to receive data
- +2 ; ACKPCENO - PCE Visit ien to copy from
- +3 ; outputs:- 0^ - everything ok
- +4 ; n^ - n errors found
- +5 ; errors filed in ^TMP("ACKQASU4",$J,"COPYPCE","ERROR",n)=field^int^ext^message
- +6 ; NB. In the validation of Dx and CPT codes, the Visit Stop Code (A,S,
- +7 ; AT or ST) is read from the Qsr Visit record. For this validation to
- +8 ; work therefore, the Visit Stop Code must already be filed on the Qsr
- +9 ; visit.
- +10 NEW ACKERR,ACKARR,ACKVELG,ACKI,ACKICD,ACKE,ACKTMP,ACKPRIM,ACKSTUD
- +11 NEW ACKSC,ACKAO,ACKIR,ACKEC,ACKREC,ACKPRV,ACKTYP,ACKCPT,ACKQTY,ACKVTME
- +12 NEW ACKDPRIM,ACKQPRV,ACKPRVCK
- +13 ; initialise return array
- KILL ^TMP("ACKQASU4",$JOB,"COPYPCE")
- +14 ; error counter
- SET ACKERR=0
- +15 ;
- +16 ; get the PCE Visit data - returned in ^TMP("PXKENC",$J,pce ien,...)
- +17 DO ENCEVENT^PXAPI(ACKPCENO,"")
- +18 ;
- +19 ; Get Diagnostic codes
- +20 SET ACKI=""
- SET ACKDPRIM=""
- +21 FOR
- SET ACKI=$ORDER(^TMP("PXKENC",$JOB,ACKPCENO,"POV",ACKI))
- if ACKI=""
- QUIT
- Begin DoDot:1
- +22 ; icd ien
- SET ACKICD=$PIECE($GET(^TMP("PXKENC",$JOB,ACKPCENO,"POV",ACKI,0)),U,1)
- +23 IF ACKDPRIM=""
- IF $PIECE($GET(^TMP("PXKENC",$JOB,ACKPCENO,"POV",ACKI,0)),U,12)="P"
- SET ACKDPRIM=1
- +24 ; add to visit
- +25 SET ACKE=$$SETDIAG^ACKQASU5(ACKVIEN,ACKICD,ACKDPRIM)
- +26 IF ACKDPRIM
- SET ACKDPRIM="0"
- +27 ; if error returned then file
- +28 IF 'ACKE
- Begin DoDot:2
- +29 ;ACKQ*3.0*22 updated api
- +30 SET ACKTMP="Diagnosis"_U_ACKICD_U_$$CODEC^ICDEX(80,ACKICD)_U_$PIECE(ACKE,U,2)
- +31 DO ADDERR
- End DoDot:2
- QUIT
- +32 ; if successful then ensure Diagnosis is added to Patient Diagnostic history
- +33 DO DIAGHIST
- End DoDot:1
- +34 ;
- +35 ; get all the providers and file
- +36 SET ACKI=""
- SET ACKPRIM=""
- SET ACKSTUD=""
- +37 FOR
- SET ACKI=$ORDER(^TMP("PXKENC",$JOB,ACKPCENO,"PRV",ACKI))
- if ACKI=""
- QUIT
- Begin DoDot:1
- +38 SET ACKREC=$GET(^TMP("PXKENC",$JOB,ACKPCENO,"PRV",ACKI,0))
- +39 ; provider ien
- SET ACKPRV=$PIECE(ACKREC,U,1)
- +40 ; primary/secondary
- SET ACKTYP=$PIECE(ACKREC,U,4)
- +41 ; copy primary provider
- IF ACKTYP="P"
- DO COPYPRIM
- QUIT
- +42 ; copy secondary provider
- IF ACKTYP="S"
- DO COPYSCND
- QUIT
- End DoDot:1
- +43 ;
- +44 ; Get procedure codes
- +45 SET ACKI=""
- +46 FOR
- SET ACKI=$ORDER(^TMP("PXKENC",$JOB,ACKPCENO,"CPT",ACKI))
- if ACKI=""
- QUIT
- Begin DoDot:1
- +47 SET ACKREC=$GET(^TMP("PXKENC",$JOB,ACKPCENO,"CPT",ACKI,0))
- +48 ; unpack cpt and volume
- SET ACKCPT=$PIECE(ACKREC,U,1)
- SET ACKQTY=$PIECE(ACKREC,U,16)
- +49 ; Get Procedure Provider
- +50 SET ACKPRV=$PIECE($GET(^TMP("PXKENC",$JOB,ACKPCENO,"CPT",ACKI,12)),U,4)
- +51 SET ACKQPRV=$$PROVCHK(ACKPRV)
- +52 IF ACKPRV'=""
- Begin DoDot:2
- +53 SET ACKPRVCK=$$STACT^ACKQUTL(ACKQPRV,ACKVD)
- +54 IF ACKPRVCK'="0"
- IF ACKPRVCK'="-6"
- Begin DoDot:3
- +55 SET ACKTMP="Provider"_U_ACKPRV_U_$$GET1^DIQ(200,ACKPRV_",",.01,"E")_U
- +56 SET ACKTMP=ACKTMP_"Invalid Procedure Provider"
- +57 DO ADDERR
- +58 SET ACKQPRV=""
- End DoDot:3
- End DoDot:2
- +59 ; add to visit
- +60 SET ACKE=$$SETPROC^ACKQASU5(ACKVIEN,ACKCPT,ACKQTY,ACKQPRV)
- +61 ; if error returned then file
- +62 IF 'ACKE
- Begin DoDot:2
- +63 ;ACKQ*3.0*22 updated api
- +64 SET ACKTMP="Procedure"_U_ACKCPT_U_$PIECE($$CPT^ICPTCOD(ACKCPT),U,2)_U_$PIECE(ACKE,U,2)
- +65 DO ADDERR
- End DoDot:2
- QUIT
- +66 ; if successful then do the modifiers for this procedure
- +67 ; ACKPIEN=procedure ien from visit file
- SET ACKM=0
- SET ACKPIEN=+ACKE
- +68 FOR
- SET ACKM=$ORDER(^TMP("PXKENC",$JOB,ACKPCENO,"CPT",ACKI,1,ACKM))
- if 'ACKM
- QUIT
- Begin DoDot:2
- +69 SET ACKMOD=$PIECE($GET(^TMP("PXKENC",$JOB,ACKPCENO,"CPT",ACKI,1,ACKM,0)),U,1)
- +70 ; add to visit
- +71 SET ACKE=$$SETMDFR^ACKQASU5(ACKVIEN,ACKPIEN,ACKMOD)
- +72 ; if error returned then file
- +73 IF '+ACKE
- Begin DoDot:3
- +74 ;ACKQ*3.0*22 updated api
- +75 SET ACKTMP="Modifier"_U_ACKMOD_U_$PIECE($$MOD^ICPTMOD(ACKMOD,"I"),U,2)_U_$PIECE(ACKE,U,2)
- +76 DO ADDERR
- End DoDot:3
- QUIT
- End DoDot:2
- End DoDot:1
- +77 ;
- +78 ; now file header items
- +79 KILL ACKARR,ACKPRV
- +80 ;
- +81 ; If PCE visit has an eligibility write to a&sp visit file
- +82 SET ACKVELG=$PIECE($GET(^TMP("PXKENC",$JOB,ACKPCENO,"VST",ACKPCENO,0)),U,21)
- +83 IF ACKVELG'=""
- SET ACKARR(509850.6,ACKVIEN_",",80)=ACKVELG
- +84 ;
- +85 ; Get service connected,Agent Orange,Radiation and Environmental
- +86 ; Contaminents from PCE file and set them to the Visit file.
- +87 SET ACKREC=$GET(^TMP("PXKENC",$JOB,ACKPCENO,"VST",ACKPCENO,800))
- +88 ; service connected
- SET ACKSC=$PIECE(ACKREC,U,1)
- +89 ; agent orange
- SET ACKAO=$PIECE(ACKREC,U,2)
- +90 ; ionizing radiation
- SET ACKIR=$PIECE(ACKREC,U,3)
- +91 ; environmental contaminants
- SET ACKEC=$PIECE(ACKREC,U,4)
- +92 SET ACKARR(509850.6,ACKVIEN_",",20)=$SELECT(+ACKSC:1,ACKSC=0:0,1:"")
- +93 SET ACKARR(509850.6,ACKVIEN_",",25)=$SELECT(+ACKAO:1,ACKAO=0:0,1:"")
- +94 SET ACKARR(509850.6,ACKVIEN_",",30)=$SELECT(+ACKIR:1,ACKIR=0:0,1:"")
- +95 SET ACKARR(509850.6,ACKVIEN_",",35)=$SELECT(+ACKEC:1,ACKEC=0:0,1:"")
- +96 ;
- +97 ; Update QUASAR visit record
- +98 DO FILE^DIE("","ACKARR")
- +99 KILL ACKARR
- +100 ;
- COPYPCEX ; Exit point
- +1 ; Clear PCE data
- KILL ^TMP("PXKENC",$JOB)
- +2 ; final error count
- IF ACKERR
- SET ^TMP("ACKQASU4",$JOB,"COPYPCE","ERROR")=ACKERR
- +3 ; return error count
- QUIT ACKERR_U
- +4 ;
- +5 ;
- COPYPRIM ; Copy the primary provider to QUASAR
- +1 ;
- +2 ; If we haven't successfully filed a primary then attempt to
- +3 ;
- IF ACKPRIM=""
- Begin DoDot:1
- +4 SET ACKQPRV=$$PROVCHK(ACKPRV)
- +5 ; Attempt to add to visit
- SET ACKE=$$SETPRIM^ACKQASU6(ACKVIEN,ACKQPRV)
- +6 ; Record that we now have a primary
- IF +ACKE
- SET ACKPRIM=ACKQPRV
- +7 ; error occurred
- IF '+ACKE
- Begin DoDot:2
- +8 SET ACKTMP="Provider"_U_ACKPRV_U_$$GET1^DIQ(200,ACKPRV_",",.01,"E")_U
- +9 SET ACKTMP=ACKTMP_$PIECE(ACKE,U,2)
- +10 DO ADDERR
- End DoDot:2
- End DoDot:1
- QUIT
- +11 ;
- +12 ; if we already have a primary then add an error message
- +13 SET ACKTMP="Provider"_U_ACKPRV_U_$$GET1^DIQ(200,ACKPRV_",",.01,"E")_U
- +14 SET ACKTMP=ACKTMP_"Visit already has a Primary Provider"
- +15 DO ADDERR
- +16 ;
- +17 ; return to provider loop
- +18 QUIT
- +19 ;
- COPYSCND ; copy a secondary provider to QUASAR
- +1 ;
- +2 ; determine the Quasar classification for this provider
- +3 SET ACKQPRV=$$PROVCHK(ACKPRV)
- +4 SET ACKTYPQ=$$GET1^DIQ(509850.3,$SELECT(ACKQPRV="":" ",1:ACKQPRV)_",",.02,"I")
- +5 ;
- +6 ; if they are a student and we haven't one already,
- +7 ; then attempt to file as student
- +8 ; student
- IF ACKTYPQ="S"
- IF ACKSTUD=""
- Begin DoDot:1
- +9 SET ACKE=$$SETSTUD^ACKQASU6(ACKVIEN,ACKQPRV)
- +10 ; record that we now have a student
- IF +ACKE
- SET ACKSTUD=ACKQPRV
- QUIT
- +11 ; Error occurred
- IF '+ACKE
- Begin DoDot:2
- +12 SET ACKTMP="Student"_U_ACKPRV_U_$$GET1^DIQ(200,ACKPRV_",",.01,"E")_U
- +13 SET ACKTMP=ACKTMP_$PIECE(ACKE,U,2)
- +14 DO ADDERR
- End DoDot:2
- End DoDot:1
- QUIT
- +15 ;
- +16 ; if they are a student and we already have one then set error
- +17 IF ACKTYPQ="S"
- IF ACKSTUD'=""
- Begin DoDot:1
- +18 SET ACKTMP="Student"_U_ACKPRV_U_$$GET1^DIQ(200,ACKPRV_",",.01,"E")_U
- +19 SET ACKTMP=ACKTMP_"Visit already has a Student"
- +20 DO ADDERR
- End DoDot:1
- QUIT
- +21 ;
- +22 ; if they are a regular provider, and we do not already have
- +23 ; a secondary provider then attempt to file
- +24 IF (ACKTYPQ="C")!(ACKTYPQ="F")!(ACKTYPQ="O")
- Begin DoDot:1
- +25 ; attempt to add to visit
- SET ACKE=$$SETSCND^ACKQASU6(ACKVIEN,ACKQPRV)
- +26 ; All okay
- IF +ACKE
- QUIT
- +27 ; Error occurred
- IF '+ACKE
- Begin DoDot:2
- +28 SET ACKTMP="Provider"_U_ACKPRV_U_$$GET1^DIQ(200,ACKPRV_",",.01,"E")_U
- +29 SET ACKTMP=ACKTMP_$PIECE(ACKE,U,2)
- +30 DO ADDERR
- End DoDot:2
- End DoDot:1
- QUIT
- +31 ;
- +32 ; if we get this far then provider must be unknown to Quasar
- +33 SET ACKTMP="Provider"_U_ACKPRV_U_$$GET1^DIQ(200,ACKPRV_",",.01,"E")_U
- +34 SET ACKTMP=ACKTMP_"Provider not defined for Audiology and Speech Pathology"
- +35 DO ADDERR
- +36 ;
- +37 ; end of checking a secondary provider
- +38 QUIT
- +39 ;
- ADDERR ; add an error to return array in ^TMP
- +1 ; ACKERR is current error count, ACKTMP is the error detail
- +2 SET ACKERR=ACKERR+1
- +3 SET ^TMP("ACKQASU4",$JOB,"COPYPCE","ERROR",ACKERR)=ACKTMP
- +4 QUIT
- +5 ;
- DIAGHIST ; ensure diagnosis is on Patient history
- +1 ; this s/r checks for ACKICD (diagnosis ien) on the patient history
- +2 ; of patient ACKPAT
- +3 ; if the ICD is not found a new entry is automatically added using the
- +4 ; visit date in ACKVD
- +5 NEW ACKTGT
- +6 ;
- +7 ; look for the diagnosis on the current history
- +8 DO FIND^DIC(509850.22,","_ACKPAT_",","","Q",ACKICD,1,"B","","","ACKTGT")
- +9 ;
- +10 ; if found then exit
- +11 ; exactly one found
- IF +$PIECE($GET(ACKTGT("DILIST",0)),U,1)=1
- QUIT
- +12 ;
- +13 ; create a new entry
- +14 SET ACKUPD(509850.22,"+1,"_ACKPAT_",",.01)=ACKICD
- +15 SET ACKUPD(509850.22,"+1,"_ACKPAT_",",1)=ACKVD
- +16 DO UPDATE^DIE("","ACKUPD","","")
- +17 ;
- +18 ; end
- +19 QUIT
- +20 ;
- PROVCHK(ACKPRV) ; Check to see if Provider is on Quasar Staff file - if so
- +1 ; function passes back Quasars Provider IEN No else null
- +2 ;
- +3 NEW ACKA,ACKB,NPNAME
- SET ACKB=""
- +4 IF ACKPRV=""
- QUIT ACKB
- +5 ;ACKQ*3*17
- +6 SET NPNAME=$$GET1^DIQ(200,ACKPRV,.01,"")
- +7 IF '$DATA(^ACK(509850.3,"B",NPNAME))
- QUIT ACKB
- +8 QUIT $ORDER(^ACK(509850.3,"B",NPNAME,ACKB))
- +9 ;