Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACKQUTL5

ACKQUTL5.m

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