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 Oct 16, 2024@18:32:33 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 ;
