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