ACKQUTL5 ;HCIOFO/BH-Quasar utilities routine ; 12/24/09 2:15pm
;;3.0;QUASAR;**1,4,6,8,18,22**;Feb 11, 2000;Build 5
;Per VHA Directive 2004-038, this routine SHOULD NOT be modified.
;
;Reference/IA
;
;$$MOD^ICPTMOD - 1996
;$$CPT^ICPTMOD - 1995
;
;
SETREF(X,ACKVIEN,ACKTYPE) ;
; Maintains APCE xRef When 3 of the 4 entries are present & the 4TH
; has been entered a new entry will be set up. If any of the 4 data
; items used within the X ref are changed the entry will be deleted & a
; new 1 set up
N ACKTME,ACKCLIN,ACKVD,ACKPAT
D GETVAL
I ACKTME="",ACKTYPE'="T" Q
I ACKCLIN="",ACKTYPE'="C" Q
I ACKVD="",ACKTYPE'="D" Q
I ACKPAT="",ACKTYPE'="P" Q
;
S ^ACK(509850.6,"APCE",ACKPAT,ACKCLIN,ACKVD,ACKTME,ACKVIEN)=""
Q
KILLREF(X,ACKVIEN,ACKTYPE) ;
; When any of the 4 var values that make up the APCE xRef are deleted
; or when the visit record is deleted the APCE xRef will be deleted
N ACKTME,ACKCLIN,ACKVD,ACKPAT
D GETVAL
;
I ACKTYPE'="T",ACKTME="" Q ; If any of the 4 field values other than
I ACKTYPE'="C",ACKCLIN="" Q ; the field being edited are null the
I ACKTYPE'="D",ACKVD="" Q ; xRef will not have been set up
I ACKTYPE'="P",ACKPAT="" Q
;
I ACKTYPE="D" S ACKVD=X ; X=Old field value
I ACKTYPE="P" S ACKPAT=X
I ACKTYPE="C" S ACKCLIN=X
I ACKTYPE="T" S ACKTME=X
;
I $D(^ACK(509850.6,"APCE",ACKPAT,ACKCLIN,ACKVD,ACKTME,ACKVIEN)) D
. K ^ACK(509850.6,"APCE",ACKPAT,ACKCLIN,ACKVD,ACKTME,ACKVIEN)
Q
;
GETVAL ; Used with SETREF & KILLREF - Gets The Clinic, Visit Date, Visit
; time and Patient from the visit file currently being processed
N ACKTGT
D GETS^DIQ(509850.6,ACKVIEN_",",".01;1;2.6;55","I","ACKTGT")
S ACKVD=$G(ACKTGT(509850.6,ACKVIEN_",",.01,"I"))
S ACKPAT=$G(ACKTGT(509850.6,ACKVIEN_",",1,"I"))
S ACKCLIN=$G(ACKTGT(509850.6,ACKVIEN_",",2.6,"I"))
S ACKTME=$G(ACKTGT(509850.6,ACKVIEN_",",55,"I"))
Q
;
EXCEPT(ACKVIEN,ACKFLD,ACKVAL) ; Called from xRefs within the LAST SENT TO PCE, LAST
; EDITED IN QSR and PCE VISIT IEN fields
N ACKTGT,ACKPIEN,ACKSENT,ACKEDIT,ACKARR,ACKEXCP
I ACKFLD=125 D
. S ACKPIEN=ACKVAL
. S ACKSENT=$$GET1^DIQ(509850.6,ACKVIEN_",",135,"I")
. S ACKEDIT=$$GET1^DIQ(509850.6,ACKVIEN_",",140,"I")
I ACKFLD=135 D
. S ACKPIEN=$$GET1^DIQ(509850.6,ACKVIEN_",",125,"I")
. S ACKSENT=ACKVAL
. S ACKEDIT=$$GET1^DIQ(509850.6,ACKVIEN_",",140,"I")
I ACKFLD=140 D
. S ACKPIEN=$$GET1^DIQ(509850.6,ACKVIEN_",",125,"I")
. S ACKSENT=$$GET1^DIQ(509850.6,ACKVIEN_",",135,"I")
. S ACKEDIT=ACKVAL
;
; if PCE visit ien known and PCE updated last then no exception
I ACKPIEN'="",ACKEDIT'="",ACKSENT'="",ACKEDIT<ACKSENT D Q
. S ACKARR(509850.6,ACKVIEN_",",900)="@"
. D FILE^DIE("","ACKARR")
; else this visit is an exception - only update if null or
; earlier than today
S ACKEXCP=$$GET1^DIQ(509850.6,ACKVIEN_",",900,"I")
D NOW^%DTC
I (ACKEXCP="")!(ACKEXCP\1<(%\1)) D
. S ACKARR(509850.6,ACKVIEN_",",900)=%
. D FILE^DIE("","ACKARR")
Q
SEND(ACKVIEN) ; Called when entering/editing any of the PCE fields.
; inputs: ACKVIEN - visit ien
; this s/r is used in the xRef of any data field that, if changed,
; should be sent to PCE to keep PCE up to date. The edit triggers the
; xRef call to this s/r. It ensures that the LAST EDITED IN QSR date is
; after the LAST SENT TO PCE date so that the visit becomes a PCE
; EXCEPTION. NB. The LAST EDITED IN QSR date will only be updated if
; a. it is currently earlier than the LAST SENT TO PCE and by updating
; it the visit becomes a PCE Exception. or b. the current value is
; earlier than today this saves the system from constantly updating
; this field and checking the exception status each time a pce field
; is changed
N ACKARR,ACKEDIT,ACKSENT
; get current value of LAST EDITED IN QSR and LAST SENT TO PCE
S ACKEDIT=$$GET1^DIQ(509850.6,ACKVIEN_",",140,"I")
S ACKSENT=$$GET1^DIQ(509850.6,ACKVIEN_",",135,"I")
D NOW^%DTC
; if qsr edit currently earlier than sent to pce update
I ACKEDIT<ACKSENT D Q
. S ACKARR(509850.6,ACKVIEN_",",140)=%
. D FILE^DIE("","ACKARR")
;
; if last edit is earlier than today update
I (ACKEDIT\1)<(%\1) D Q
. S ACKARR(509850.6,ACKVIEN_",",140)=%
. D FILE^DIE("","ACKARR")
; nothing to do - QSR date must already be after LAST SENT and for today
Q
MOD ; Creates an array of valid CPT Modfrs. gets all valid Mods for the
; Proc then disgards any that are not on the A&SP Proc Mod file or that
; are on file but Inactive
K ACKMOD,ACKMODD
N CDT,ACKMOD1,ACKM1,ACKK2
I $$PATCH^XPDUTL("PX*1.0*73") S ACKMOD1=$$CODM^ICPTCOD(ACKPC,"ACKMODD","",ACKVD)
I '$$PATCH^XPDUTL("PX*1.0*73") S ACKMOD1=$$CODM^ICPTCOD(ACKPC,"ACKMODD")
S ACKM1=""
F S ACKM1=$O(ACKMODD(ACKM1)) Q:ACKM1="" D
. S ACKK2=$P(ACKMODD(ACKM1),U,2)
. I '$D(^ACK(509850.5,ACKK2,0)) K ACKMODD(ACKM1) Q
. I $P(^ACK(509850.5,ACKK2,0),U,2)=0 K ACKMODD(ACKM1) Q
. K ACKMODD(ACKM1) S ACKMOD(ACKPC,ACKK2)=""
S ACKMOD(ACKPC)=""
Q
MODW ; Called from x ref of Modfr field within 509850.6
I X'["?" Q
N ACKQDDD
S ACKQDDD=$G(ACKVD)
;ACKQ*3.0*22 updated api
S DIC("W")="S ACKSRCE=$P($$MOD^ICPTMOD(Y,""I""),U,5) W "" "",$$MODTXT^ACKQUTL8(Y,"_ACKQDDD_"),?48,$S(ACKSRCE=""C"":""CPT"",ACKSRCE=""H"":""HCPCS"",ACKSRCE=""V"":""VA NATIONAL"",1:"""")"
Q
;
;
MODS ; Screen for Modfrs input within Modifrs field of Modfrs File
N ACKQDDD,ACKMOD
S ACKQDDD=$G(ACKVD)
;ACKQ*3.0*22 updated api
S DIC("S")="S ACKMOD=$$MOD^ICPTMOD(Y,""I"") I $P($G(ACKMOD),""^"",5)=""C""!($P($G(ACKMOD),""^"",5)=""H""),$P($G(ACKMOD),""^"",7)=1"
S DIC("W")="W "" "",$$MODTXT^ACKQUTL8(Y,"_ACKQDDD_")"
Q
;
;
CHK(Y,ACKVD,ACKCSC) ; Screen for EC codes
N ACKQCD,ACKQQD,ACKQQCPT,ACKPARAM
I $E($P(^EC(725,+Y,0),"^",2),1,2)'="SP" Q 0
S ACKQQCPT=$$GET1^DIQ(725,+Y_",",4,"I") I ACKQQCPT="" Q 0
;S ACKQCD=$$CONVERT(ACKQQCPT) I ACKQCD="" Q 0
S ACKQCD=ACKQQCPT
S ACKPARAM=$P($$CPT^ICPTCOD(ACKQCD,ACKVD),"^",7) I 'ACKPARAM Q 0
I '$D(^ACK(509850.4,ACKQCD,0)) Q 0
I $P(^ACK(509850.4,ACKQCD,0),U,2)'[$E(ACKCSC) Q 0
I $P(^ACK(509850.4,ACKQCD,0),U,4)'=1 Q 0
S ACKQQD=$P(^EC(725,Y,0),"^",3) I ACKQQD="" Q 1
I ACKVD<ACKQQD Q 1
Q 0
EVNTDIS ; Get EC Procs filed and display
D ENS^%ZISS
N D0,ACKKEY,ACKEVTDS,ACKK3,ACKPROC,ACKPRV,ACKNME,ACKNATNM
D LIST^DIC(509850.615,","_ACKVIEN_",",".01;.03;.05","I","*","","","","","","ACKEVTDS")
I '$D(ACKEVTDS("DILIST",1)) Q
W !!," ",IOUON,"Event Capture Procedures currently entered for this visit",IOUOFF,!
S ACKK3=""
F S ACKK3=$O(ACKEVTDS("DILIST",1,ACKK3)) Q:ACKK3="" D
. S ACKPROC=ACKEVTDS("DILIST",1,ACKK3)
. S ACKPRV=ACKEVTDS("DILIST","ID",ACKK3,.05)
. I ACKPRV'="" S ACKPRV=$$CONVERT^ACKQUTL4(ACKPRV)
. S ACKNME=$$GET1^DIQ(725,ACKPROC_",",.01) S ACKNME=$E(ACKNME,1,29)
. S ACKNATNM=$$GET1^DIQ(725,ACKPROC_",",1)
. W !," Nat.#: ",ACKNATNM,?14," Name: ",ACKNME,?55,"Vol.: ",ACKEVTDS("DILIST","ID",ACKK3,.03) I ACKPRV'="" W !,?14,"Provider: ",ACKPRV
. W !
Q
SETCPT(DA,ACKQQIEN,X) ; When EC Code is entered create a CPT entry
I '$D(ACKEVENT) Q ; "" or 1 ACKEVENT must be defined
N ACK,ACKARR1,ACKCIEN,ACKQQCPT
; Get CPT associated with EC code
S ACKQQCPT=$$GET1^DIQ(725,X_",",4,"I")
;S ACKQQCPT=$$CONVERT(ACKQQCPT)
S ACKCIEN="" K ACKARR1
; Create CPT entry and enter DA as CPT's pter to creating EC entry
S ACKARR1(509850.61,"+1,"_ACKQQIEN_",",.01)=ACKQQCPT
S ACKARR1(509850.61,"+1,"_ACKQQIEN_",",.07)=DA
D UPDATE^DIE("","ACKARR1","ACKCIEN","")
K ACK
; After CPT entry set up get its IEN & set it to the creating EC
; entries CPT ptr field
S ACK(509850.615,DA_","_ACKQQIEN_",",.07)=ACKCIEN(1)
D FILE^DIE("","ACK","")
Q
KILLCPT(DA,ACKQQIEN) ; Deletes CPT entry if created by an EC entry
I '$D(ACKEVENT) Q ; "" or 1 ACKEVENT must be defined
Q:'ACKEVENT ; Q if Div set up to use CPT's
N ACKCIEN,ACK
S ACKCIEN=$$GET1^DIQ(509850.615,DA_","_ACKQQIEN_",",.07)
I ACKCIEN="" Q
S ACK(509850.61,ACKCIEN_","_ACKQQIEN_",",.01)="@" D FILE^DIE("","ACK")
Q
ECVOLPRV(DA,ACKQQIEN,X,ACKQQVP,ACKQQDS) ; Update CPT rec. when EC data entered
;If CPT entry linked with the EC entry -
; If ACKQQDS='S'
; If ACKQQVP='V' set EC vol to CPT vol
; If ACKQQVP='P' set EC Prvdr to CPT Prvdr
; If ACKQQDS='D'
; If ACKQQVP='V' delete CPT vol
; If ACKQQVP='P' delete CPT Prvdr
;
I '$D(ACKEVENT) Q ; "" or 1 ACKEVENT must be defined
Q:'ACKEVENT
N ACKFIELD,ACKVAL,ACK,ACKCIEN
S ACKCIEN=$$GET1^DIQ(509850.615,DA_","_ACKQQIEN_",",.07)
I ACKCIEN="" Q
S ACKFIELD=".03" I ACKQQVP="P" S ACKFIELD=".05"
S ACKVAL=X I ACKQQDS="D" S ACKVAL="@"
S ACK(509850.61,ACKCIEN_","_ACKQQIEN_",",ACKFIELD)=ACKVAL
D FILE^DIE("","ACK","")
Q
CPVOLPRV(DA,ACKQQIEN,X,ACKQQVP,ACKQQDS) ; Update EC rec. when CPT data entered
;If EC entry linked with the CPT entry -
; If ACKQQDS='S'
; If ACKQQVP='V' set CPT vol to EC vol
; If ACKQQVP='P' set CPT Prvdr to EC Prvdr
; If ACKQQDS='D'
; If ACKQQVP='V' delete EC vol
; If ACKQQVP='P' delete EC Prvdr
;
I '$D(ACKEVENT) Q ; "" or 1 ACKEVENT must be defined
Q:ACKEVENT
N ACKFIELD,ACKVAL,ACK,ACKEIEN
S ACKEIEN=$$GET1^DIQ(509850.61,DA_","_ACKQQIEN_",",.07)
I ACKEIEN="" Q
S ACKFIELD=".03" I ACKQQVP="P" S ACKFIELD=".05"
S ACKVAL=X I ACKQQDS="D" S ACKVAL="@"
S ACK(509850.615,ACKEIEN_","_ACKQQIEN_",",ACKFIELD)=ACKVAL
D FILE^DIE("","ACK","")
Q
KILLEC(DA,ACKQQIEN) ; Delets EC entry if CPT entry has EC pter
I '$D(ACKEVENT) Q ; "" or 1 ACKEVENT must be defined
Q:ACKEVENT ; Q if Div set up to use EC's
N ACKECIEN,ACK
S ACKECIEN=$$GET1^DIQ(509850.61,DA_","_ACKQQIEN_",",.07)
I ACKECIEN="" Q
S ACK(509850.615,ACKECIEN_","_ACKQQIEN_",",.01)="@" D FILE^DIE("","ACK")
Q
EVENT(ACKDIV,ACKVD) ; params set up for Divn to use EC Codes ?
N ACKY,X,Y,ACKM
S ACKY=$E(ACKVD,2,3),ACKM=$E(ACKVD,4,5)
I ACKM>9 S ACKY=ACKY+1 I $L(ACKY)=1 S ACKY="0"_ACKY
I '$D(^ACK(509850.8,1,2,ACKDIV,2,"B",ACKY)) Q 0
S ACKKEY=0
S ACKKEY=$O(^ACK(509850.8,1,2,ACKDIV,2,"B",ACKY,ACKKEY))
S ACKEC=$P(^ACK(509850.8,1,2,ACKDIV,2,ACKKEY,0),"^",2)
I ACKEC="" S ACKEC="0"
Q ACKEC
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQUTL5 10198 printed Apr 09, 2024@21:35:10 Page 2
ACKQUTL5 ;HCIOFO/BH-Quasar utilities routine ; 12/24/09 2:15pm
+1 ;;3.0;QUASAR;**1,4,6,8,18,22**;Feb 11, 2000;Build 5
+2 ;Per VHA Directive 2004-038, this routine SHOULD NOT be modified.
+3 ;
+4 ;Reference/IA
+5 ;
+6 ;$$MOD^ICPTMOD - 1996
+7 ;$$CPT^ICPTMOD - 1995
+8 ;
+9 ;
SETREF(X,ACKVIEN,ACKTYPE) ;
+1 ; Maintains APCE xRef When 3 of the 4 entries are present & the 4TH
+2 ; has been entered a new entry will be set up. If any of the 4 data
+3 ; items used within the X ref are changed the entry will be deleted & a
+4 ; new 1 set up
+5 NEW ACKTME,ACKCLIN,ACKVD,ACKPAT
+6 DO GETVAL
+7 IF ACKTME=""
IF ACKTYPE'="T"
QUIT
+8 IF ACKCLIN=""
IF ACKTYPE'="C"
QUIT
+9 IF ACKVD=""
IF ACKTYPE'="D"
QUIT
+10 IF ACKPAT=""
IF ACKTYPE'="P"
QUIT
+11 ;
+12 SET ^ACK(509850.6,"APCE",ACKPAT,ACKCLIN,ACKVD,ACKTME,ACKVIEN)=""
+13 QUIT
KILLREF(X,ACKVIEN,ACKTYPE) ;
+1 ; When any of the 4 var values that make up the APCE xRef are deleted
+2 ; or when the visit record is deleted the APCE xRef will be deleted
+3 NEW ACKTME,ACKCLIN,ACKVD,ACKPAT
+4 DO GETVAL
+5 ;
+6 ; If any of the 4 field values other than
IF ACKTYPE'="T"
IF ACKTME=""
QUIT
+7 ; the field being edited are null the
IF ACKTYPE'="C"
IF ACKCLIN=""
QUIT
+8 ; xRef will not have been set up
IF ACKTYPE'="D"
IF ACKVD=""
QUIT
+9 IF ACKTYPE'="P"
IF ACKPAT=""
QUIT
+10 ;
+11 ; X=Old field value
IF ACKTYPE="D"
SET ACKVD=X
+12 IF ACKTYPE="P"
SET ACKPAT=X
+13 IF ACKTYPE="C"
SET ACKCLIN=X
+14 IF ACKTYPE="T"
SET ACKTME=X
+15 ;
+16 IF $DATA(^ACK(509850.6,"APCE",ACKPAT,ACKCLIN,ACKVD,ACKTME,ACKVIEN))
Begin DoDot:1
+17 KILL ^ACK(509850.6,"APCE",ACKPAT,ACKCLIN,ACKVD,ACKTME,ACKVIEN)
End DoDot:1
+18 QUIT
+19 ;
GETVAL ; Used with SETREF & KILLREF - Gets The Clinic, Visit Date, Visit
+1 ; time and Patient from the visit file currently being processed
+2 NEW ACKTGT
+3 DO GETS^DIQ(509850.6,ACKVIEN_",",".01;1;2.6;55","I","ACKTGT")
+4 SET ACKVD=$GET(ACKTGT(509850.6,ACKVIEN_",",.01,"I"))
+5 SET ACKPAT=$GET(ACKTGT(509850.6,ACKVIEN_",",1,"I"))
+6 SET ACKCLIN=$GET(ACKTGT(509850.6,ACKVIEN_",",2.6,"I"))
+7 SET ACKTME=$GET(ACKTGT(509850.6,ACKVIEN_",",55,"I"))
+8 QUIT
+9 ;
EXCEPT(ACKVIEN,ACKFLD,ACKVAL) ; Called from xRefs within the LAST SENT TO PCE, LAST
+1 ; EDITED IN QSR and PCE VISIT IEN fields
+2 NEW ACKTGT,ACKPIEN,ACKSENT,ACKEDIT,ACKARR,ACKEXCP
+3 IF ACKFLD=125
Begin DoDot:1
+4 SET ACKPIEN=ACKVAL
+5 SET ACKSENT=$$GET1^DIQ(509850.6,ACKVIEN_",",135,"I")
+6 SET ACKEDIT=$$GET1^DIQ(509850.6,ACKVIEN_",",140,"I")
End DoDot:1
+7 IF ACKFLD=135
Begin DoDot:1
+8 SET ACKPIEN=$$GET1^DIQ(509850.6,ACKVIEN_",",125,"I")
+9 SET ACKSENT=ACKVAL
+10 SET ACKEDIT=$$GET1^DIQ(509850.6,ACKVIEN_",",140,"I")
End DoDot:1
+11 IF ACKFLD=140
Begin DoDot:1
+12 SET ACKPIEN=$$GET1^DIQ(509850.6,ACKVIEN_",",125,"I")
+13 SET ACKSENT=$$GET1^DIQ(509850.6,ACKVIEN_",",135,"I")
+14 SET ACKEDIT=ACKVAL
End DoDot:1
+15 ;
+16 ; if PCE visit ien known and PCE updated last then no exception
+17 IF ACKPIEN'=""
IF ACKEDIT'=""
IF ACKSENT'=""
IF ACKEDIT<ACKSENT
Begin DoDot:1
+18 SET ACKARR(509850.6,ACKVIEN_",",900)="@"
+19 DO FILE^DIE("","ACKARR")
End DoDot:1
QUIT
+20 ; else this visit is an exception - only update if null or
+21 ; earlier than today
+22 SET ACKEXCP=$$GET1^DIQ(509850.6,ACKVIEN_",",900,"I")
+23 DO NOW^%DTC
+24 IF (ACKEXCP="")!(ACKEXCP\1<(%\1))
Begin DoDot:1
+25 SET ACKARR(509850.6,ACKVIEN_",",900)=%
+26 DO FILE^DIE("","ACKARR")
End DoDot:1
+27 QUIT
SEND(ACKVIEN) ; Called when entering/editing any of the PCE fields.
+1 ; inputs: ACKVIEN - visit ien
+2 ; this s/r is used in the xRef of any data field that, if changed,
+3 ; should be sent to PCE to keep PCE up to date. The edit triggers the
+4 ; xRef call to this s/r. It ensures that the LAST EDITED IN QSR date is
+5 ; after the LAST SENT TO PCE date so that the visit becomes a PCE
+6 ; EXCEPTION. NB. The LAST EDITED IN QSR date will only be updated if
+7 ; a. it is currently earlier than the LAST SENT TO PCE and by updating
+8 ; it the visit becomes a PCE Exception. or b. the current value is
+9 ; earlier than today this saves the system from constantly updating
+10 ; this field and checking the exception status each time a pce field
+11 ; is changed
+12 NEW ACKARR,ACKEDIT,ACKSENT
+13 ; get current value of LAST EDITED IN QSR and LAST SENT TO PCE
+14 SET ACKEDIT=$$GET1^DIQ(509850.6,ACKVIEN_",",140,"I")
+15 SET ACKSENT=$$GET1^DIQ(509850.6,ACKVIEN_",",135,"I")
+16 DO NOW^%DTC
+17 ; if qsr edit currently earlier than sent to pce update
+18 IF ACKEDIT<ACKSENT
Begin DoDot:1
+19 SET ACKARR(509850.6,ACKVIEN_",",140)=%
+20 DO FILE^DIE("","ACKARR")
End DoDot:1
QUIT
+21 ;
+22 ; if last edit is earlier than today update
+23 IF (ACKEDIT\1)<(%\1)
Begin DoDot:1
+24 SET ACKARR(509850.6,ACKVIEN_",",140)=%
+25 DO FILE^DIE("","ACKARR")
End DoDot:1
QUIT
+26 ; nothing to do - QSR date must already be after LAST SENT and for today
+27 QUIT
MOD ; Creates an array of valid CPT Modfrs. gets all valid Mods for the
+1 ; Proc then disgards any that are not on the A&SP Proc Mod file or that
+2 ; are on file but Inactive
+3 KILL ACKMOD,ACKMODD
+4 NEW CDT,ACKMOD1,ACKM1,ACKK2
+5 IF $$PATCH^XPDUTL("PX*1.0*73")
SET ACKMOD1=$$CODM^ICPTCOD(ACKPC,"ACKMODD","",ACKVD)
+6 IF '$$PATCH^XPDUTL("PX*1.0*73")
SET ACKMOD1=$$CODM^ICPTCOD(ACKPC,"ACKMODD")
+7 SET ACKM1=""
+8 FOR
SET ACKM1=$ORDER(ACKMODD(ACKM1))
if ACKM1=""
QUIT
Begin DoDot:1
+9 SET ACKK2=$PIECE(ACKMODD(ACKM1),U,2)
+10 IF '$DATA(^ACK(509850.5,ACKK2,0))
KILL ACKMODD(ACKM1)
QUIT
+11 IF $PIECE(^ACK(509850.5,ACKK2,0),U,2)=0
KILL ACKMODD(ACKM1)
QUIT
+12 KILL ACKMODD(ACKM1)
SET ACKMOD(ACKPC,ACKK2)=""
End DoDot:1
+13 SET ACKMOD(ACKPC)=""
+14 QUIT
MODW ; Called from x ref of Modfr field within 509850.6
+1 IF X'["?"
QUIT
+2 NEW ACKQDDD
+3 SET ACKQDDD=$GET(ACKVD)
+4 ;ACKQ*3.0*22 updated api
+5 SET DIC("W")="S ACKSRCE=$P($$MOD^ICPTMOD(Y,""I""),U,5) W "" "",$$MODTXT^ACKQUTL8(Y,"_ACKQDDD_"),?48,$S(ACKSRCE=""C"":""CPT"",ACKSRCE=""H"":""HCPCS"",ACKSRCE=""V"":""VA NATIONAL"",1:"""")"
+6 QUIT
+7 ;
+8 ;
MODS ; Screen for Modfrs input within Modifrs field of Modfrs File
+1 NEW ACKQDDD,ACKMOD
+2 SET ACKQDDD=$GET(ACKVD)
+3 ;ACKQ*3.0*22 updated api
+4 SET DIC("S")="S ACKMOD=$$MOD^ICPTMOD(Y,""I"") I $P($G(ACKMOD),""^"",5)=""C""!($P($G(ACKMOD),""^"",5)=""H""),$P($G(ACKMOD),""^"",7)=1"
+5 SET DIC("W")="W "" "",$$MODTXT^ACKQUTL8(Y,"_ACKQDDD_")"
+6 QUIT
+7 ;
+8 ;
CHK(Y,ACKVD,ACKCSC) ; Screen for EC codes
+1 NEW ACKQCD,ACKQQD,ACKQQCPT,ACKPARAM
+2 IF $EXTRACT($PIECE(^EC(725,+Y,0),"^",2),1,2)'="SP"
QUIT 0
+3 SET ACKQQCPT=$$GET1^DIQ(725,+Y_",",4,"I")
IF ACKQQCPT=""
QUIT 0
+4 ;S ACKQCD=$$CONVERT(ACKQQCPT) I ACKQCD="" Q 0
+5 SET ACKQCD=ACKQQCPT
+6 SET ACKPARAM=$PIECE($$CPT^ICPTCOD(ACKQCD,ACKVD),"^",7)
IF 'ACKPARAM
QUIT 0
+7 IF '$DATA(^ACK(509850.4,ACKQCD,0))
QUIT 0
+8 IF $PIECE(^ACK(509850.4,ACKQCD,0),U,2)'[$EXTRACT(ACKCSC)
QUIT 0
+9 IF $PIECE(^ACK(509850.4,ACKQCD,0),U,4)'=1
QUIT 0
+10 SET ACKQQD=$PIECE(^EC(725,Y,0),"^",3)
IF ACKQQD=""
QUIT 1
+11 IF ACKVD<ACKQQD
QUIT 1
+12 QUIT 0
EVNTDIS ; Get EC Procs filed and display
+1 DO ENS^%ZISS
+2 NEW D0,ACKKEY,ACKEVTDS,ACKK3,ACKPROC,ACKPRV,ACKNME,ACKNATNM
+3 DO LIST^DIC(509850.615,","_ACKVIEN_",",".01;.03;.05","I","*","","","","","","ACKEVTDS")
+4 IF '$DATA(ACKEVTDS("DILIST",1))
QUIT
+5 WRITE !!," ",IOUON,"Event Capture Procedures currently entered for this visit",IOUOFF,!
+6 SET ACKK3=""
+7 FOR
SET ACKK3=$ORDER(ACKEVTDS("DILIST",1,ACKK3))
if ACKK3=""
QUIT
Begin DoDot:1
+8 SET ACKPROC=ACKEVTDS("DILIST",1,ACKK3)
+9 SET ACKPRV=ACKEVTDS("DILIST","ID",ACKK3,.05)
+10 IF ACKPRV'=""
SET ACKPRV=$$CONVERT^ACKQUTL4(ACKPRV)
+11 SET ACKNME=$$GET1^DIQ(725,ACKPROC_",",.01)
SET ACKNME=$EXTRACT(ACKNME,1,29)
+12 SET ACKNATNM=$$GET1^DIQ(725,ACKPROC_",",1)
+13 WRITE !," Nat.#: ",ACKNATNM,?14," Name: ",ACKNME,?55,"Vol.: ",ACKEVTDS("DILIST","ID",ACKK3,.03)
IF ACKPRV'=""
WRITE !,?14,"Provider: ",ACKPRV
+14 WRITE !
End DoDot:1
+15 QUIT
SETCPT(DA,ACKQQIEN,X) ; When EC Code is entered create a CPT entry
+1 ; "" or 1 ACKEVENT must be defined
IF '$DATA(ACKEVENT)
QUIT
+2 NEW ACK,ACKARR1,ACKCIEN,ACKQQCPT
+3 ; Get CPT associated with EC code
+4 SET ACKQQCPT=$$GET1^DIQ(725,X_",",4,"I")
+5 ;S ACKQQCPT=$$CONVERT(ACKQQCPT)
+6 SET ACKCIEN=""
KILL ACKARR1
+7 ; Create CPT entry and enter DA as CPT's pter to creating EC entry
+8 SET ACKARR1(509850.61,"+1,"_ACKQQIEN_",",.01)=ACKQQCPT
+9 SET ACKARR1(509850.61,"+1,"_ACKQQIEN_",",.07)=DA
+10 DO UPDATE^DIE("","ACKARR1","ACKCIEN","")
+11 KILL ACK
+12 ; After CPT entry set up get its IEN & set it to the creating EC
+13 ; entries CPT ptr field
+14 SET ACK(509850.615,DA_","_ACKQQIEN_",",.07)=ACKCIEN(1)
+15 DO FILE^DIE("","ACK","")
+16 QUIT
KILLCPT(DA,ACKQQIEN) ; Deletes CPT entry if created by an EC entry
+1 ; "" or 1 ACKEVENT must be defined
IF '$DATA(ACKEVENT)
QUIT
+2 ; Q if Div set up to use CPT's
if 'ACKEVENT
QUIT
+3 NEW ACKCIEN,ACK
+4 SET ACKCIEN=$$GET1^DIQ(509850.615,DA_","_ACKQQIEN_",",.07)
+5 IF ACKCIEN=""
QUIT
+6 SET ACK(509850.61,ACKCIEN_","_ACKQQIEN_",",.01)="@"
DO FILE^DIE("","ACK")
+7 QUIT
ECVOLPRV(DA,ACKQQIEN,X,ACKQQVP,ACKQQDS) ; Update CPT rec. when EC data entered
+1 ;If CPT entry linked with the EC entry -
+2 ; If ACKQQDS='S'
+3 ; If ACKQQVP='V' set EC vol to CPT vol
+4 ; If ACKQQVP='P' set EC Prvdr to CPT Prvdr
+5 ; If ACKQQDS='D'
+6 ; If ACKQQVP='V' delete CPT vol
+7 ; If ACKQQVP='P' delete CPT Prvdr
+8 ;
+9 ; "" or 1 ACKEVENT must be defined
IF '$DATA(ACKEVENT)
QUIT
+10 if 'ACKEVENT
QUIT
+11 NEW ACKFIELD,ACKVAL,ACK,ACKCIEN
+12 SET ACKCIEN=$$GET1^DIQ(509850.615,DA_","_ACKQQIEN_",",.07)
+13 IF ACKCIEN=""
QUIT
+14 SET ACKFIELD=".03"
IF ACKQQVP="P"
SET ACKFIELD=".05"
+15 SET ACKVAL=X
IF ACKQQDS="D"
SET ACKVAL="@"
+16 SET ACK(509850.61,ACKCIEN_","_ACKQQIEN_",",ACKFIELD)=ACKVAL
+17 DO FILE^DIE("","ACK","")
+18 QUIT
CPVOLPRV(DA,ACKQQIEN,X,ACKQQVP,ACKQQDS) ; Update EC rec. when CPT data entered
+1 ;If EC entry linked with the CPT entry -
+2 ; If ACKQQDS='S'
+3 ; If ACKQQVP='V' set CPT vol to EC vol
+4 ; If ACKQQVP='P' set CPT Prvdr to EC Prvdr
+5 ; If ACKQQDS='D'
+6 ; If ACKQQVP='V' delete EC vol
+7 ; If ACKQQVP='P' delete EC Prvdr
+8 ;
+9 ; "" or 1 ACKEVENT must be defined
IF '$DATA(ACKEVENT)
QUIT
+10 if ACKEVENT
QUIT
+11 NEW ACKFIELD,ACKVAL,ACK,ACKEIEN
+12 SET ACKEIEN=$$GET1^DIQ(509850.61,DA_","_ACKQQIEN_",",.07)
+13 IF ACKEIEN=""
QUIT
+14 SET ACKFIELD=".03"
IF ACKQQVP="P"
SET ACKFIELD=".05"
+15 SET ACKVAL=X
IF ACKQQDS="D"
SET ACKVAL="@"
+16 SET ACK(509850.615,ACKEIEN_","_ACKQQIEN_",",ACKFIELD)=ACKVAL
+17 DO FILE^DIE("","ACK","")
+18 QUIT
KILLEC(DA,ACKQQIEN) ; Delets EC entry if CPT entry has EC pter
+1 ; "" or 1 ACKEVENT must be defined
IF '$DATA(ACKEVENT)
QUIT
+2 ; Q if Div set up to use EC's
if ACKEVENT
QUIT
+3 NEW ACKECIEN,ACK
+4 SET ACKECIEN=$$GET1^DIQ(509850.61,DA_","_ACKQQIEN_",",.07)
+5 IF ACKECIEN=""
QUIT
+6 SET ACK(509850.615,ACKECIEN_","_ACKQQIEN_",",.01)="@"
DO FILE^DIE("","ACK")
+7 QUIT
EVENT(ACKDIV,ACKVD) ; params set up for Divn to use EC Codes ?
+1 NEW ACKY,X,Y,ACKM
+2 SET ACKY=$EXTRACT(ACKVD,2,3)
SET ACKM=$EXTRACT(ACKVD,4,5)
+3 IF ACKM>9
SET ACKY=ACKY+1
IF $LENGTH(ACKY)=1
SET ACKY="0"_ACKY
+4 IF '$DATA(^ACK(509850.8,1,2,ACKDIV,2,"B",ACKY))
QUIT 0
+5 SET ACKKEY=0
+6 SET ACKKEY=$ORDER(^ACK(509850.8,1,2,ACKDIV,2,"B",ACKY,ACKKEY))
+7 SET ACKEC=$PIECE(^ACK(509850.8,1,2,ACKDIV,2,ACKKEY,0),"^",2)
+8 IF ACKEC=""
SET ACKEC="0"
+9 QUIT ACKEC
+10 ;
