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

BQITDUTL.m

Go to the documentation of this file. 
  1. BQITDUTL ;APTIV/HC/ALA-Diagnostic Tag Utilities ; 25 Feb 2008  2:30 PM
  1.  ;;2.5;ICARE MANAGEMENT SYSTEM;**1**;May 24, 2016;Build 17
  1.  ;
  1. CMP(BQIDFN,BQITAG) ;EP - Compare data
  1.  NEW BQIFN,BQIFAC,BQIDID,BQIRN,BQIREC,BQIRDT,BQIREX,BQIIEN,ADD
  1.  NEW BQIFIL,BQIVPR,FLAG
  1.  S FLAG=0,THCFL=$P(^BQI(90506.2,BQITAG,0),U,10)
  1.  I $G(^BQIPAT(BQIDFN,20,BQITAG,0))="" Q FLAG
  1.  S BQIDID=$P(^BQIPAT(BQIDFN,20,BQITAG,0),U,2)
  1.  S BQIFN=0
  1.  F  S BQIFN=$O(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN)) Q:'BQIFN  D
  1.  . S BQIFAC=$P($G(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,0)),U,1)
  1.  . I BQIFAC="" K ^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN) Q
  1.  . S BQIRN=0
  1.  . F  S BQIRN=$O(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,1,BQIRN)) Q:'BQIRN  D
  1.  .. S BQIREC=$P(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,1,BQIRN,0),U,1)
  1.  .. S BQIRDT=$P(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,1,BQIRN,0),U,2)
  1.  .. S BQIREX=$P(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,1,BQIRN,0),U,3)
  1.  .. S BQIIEN=$P(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,1,BQIRN,0),U,4)
  1.  .. S BQIFIL=$P(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,1,BQIRN,0),U,5)
  1.  .. I $E(BQIREC,1,1)="P" S BQIVPR=$E(BQIREC,2,$L(BQIREC))_";AUPNPROB("
  1.  .. I $E(BQIREC,1,1)="V" S BQIVPR=$E(BQIREC,2,$L(BQIREC))_";AUPNVSIT("
  1.  .. I BQIREC="" S FLAG=0 Q
  1.  .. S FLAG=$$CHKR()
  1.  .. Q
  1.  . I BQIFAC[" Tag" S FLAG=$$CHKR()
  1.  Q FLAG
  1.  ;
  1. CHKR() ; Check for record
  1.  NEW BQIIFACT,BQIISR,BQIIFAC,BQIITG,BQIIVPR,BQII
  1.  S BQII=""
  1.  I $O(^BQIFACT("C",BQIDFN,BQITAG,BQII))="" Q 1
  1.  F  S BQII=$O(^BQIFACT("C",BQIDFN,BQITAG,BQII)) Q:BQII=""  D
  1.  . S BQIIFACT=^BQIFACT(BQII,0)
  1.  . S BQIIFAC=$P(BQIIFACT,U,1)
  1.  . S BQIITG=$P(BQIIFACT,U,3) S:BQIITG="" BQIITG="~"
  1.  . S BQIIVPR=$P(BQIIFACT,U,5) S:BQIIVPR="" BQIIVPR="~"
  1.  . S BQIISR(BQIIFAC,BQIITG,BQIIVPR)=""
  1.  ;
  1.  I '$D(BQIISR(BQIFAC,BQITAG,BQIVPR)) Q 1
  1.  Q 0
  1.  ;
  1. NCR(BQIDFN,BQITAG) ;EP - If no criteria found, check if patient is already
  1.  ;  in Permanent Tag file BQIREG
  1.  NEW RIEN,HOK,THCFL,RSTAT,TGDATA,OK,MESG,NPREG
  1.  S THCFL=+$P(^BQI(90506.2,BQITAG,0),U,10)
  1.  S RIEN=""
  1.  F  S RIEN=$O(^BQIREG("C",BQIDFN,BQITAG,RIEN)) Q:RIEN=""  D
  1.  . I $$REG(BQIDFN,BQITAG)=1 Q
  1.  . S RSTAT=$P(^BQIREG(RIEN,0),U,3)
  1.  . ; If status is Not Accepted or No Longer Valid or Superceded, quit
  1.  . I RSTAT="N"!(RSTAT="V") Q
  1.  . ; if the current status is 'Proposed', move the factors before setting the
  1.  . ; current status to 'No Longer Valid' or 'Superseded'
  1.  . I RSTAT="P" D MOV^BQITDPRC(BQIDFN,BQITAG)
  1.  . S MESG="SYSTEM UPDATE"
  1.  . I 'THCFL D  Q
  1.  .. I $$REG(BQIDFN,BQITAG)=1 Q
  1.  .. ; Pregnant tag
  1.  .. I BQITAG=16 S OK=0 D  Q:OK
  1.  ... ; If 'accepted' and no evidence of delivery, miscarriage or abortion, quit
  1.  ... I RSTAT="A" D
  1.  .... S NPREG=$$EPG^BQITD13(BQIDFN)
  1.  .... I 'NPREG S OK=1 Q
  1.  .... I NPREG S MESG="NO LONGER PREGNANT"
  1.  .. D EN^BQITDPRC(.TGDATA,BQIDFN,BQITAG,"V",,MESG,3) Q
  1.  . ;S LOK=$$LOW(BQIDFN,BQITAG)
  1.  . S HOK=$$HIGH(BQIDFN,BQITAG)
  1.  . ; If higher tag and it's active, superseded
  1.  . I HOK,$P(HOK,U,3)=1 D EN^BQITDPRC(.TGDATA,BQIDFN,BQITAG,"S",,"SYSTEM UPDATE",4) Q
  1.  . ; If CVD At Risk not met criteria but exists and higher hierarchy is not active, it
  1.  . ; needs to go back to 'Accepted' status because user had manually entered or met with
  1.  . ; original DOB and the DOB has been modified
  1.  . ;I BQITAG=9,HOK,$P(HOK,U,3)'=1 D EN^BQITDPRC(.TGDATA,BQIDFN,BQITAG,"A",,"SYSTEM UPDATE",5) Q
  1.  . D EN^BQITDPRC(.TGDATA,BQIDFN,BQITAG,"V",,"SYSTEM UPDATE",3)
  1.  Q
  1.  ;
  1. ACT(RDFN) ;PEP - Check for any active tags
  1.  NEW ACT,RIEN,CSTAT
  1.  S RIEN="",ACT=0
  1.  F  S RIEN=$O(^BQIREG("AC",RDFN,RIEN)) Q:RIEN=""  D
  1.  . S CSTAT=$P(^BQIREG(RIEN,0),U,3)
  1.  . I CSTAT="A"!(CSTAT="P") S ACT=1
  1.  Q ACT
  1.  ;
  1. ACST(STAT) ; EP - Is this status active or not
  1.  NEW ACT
  1.  S ACT=0
  1.  I STAT="A"!(STAT="P") S ACT=1_U_STAT
  1.  Q ACT
  1.  ;
  1. ATAG(RDFN,RTAG) ;EP - Is this tag active for this patient
  1.  NEW TGN,RGIEN,RGSTAT,RGDT,STAT,TGDT
  1.  S TGN=$$GDXN^BQITUTL(RTAG)
  1.  S RGIEN=$O(^BQIREG("C",RDFN,TGN,"")) I RGIEN="" Q 0
  1.  S RGSTAT=$P($G(^BQIREG(RGIEN,0)),U,3),RGDT=$P($G(^(0)),U,4)
  1.  S TGDT=$P($G(^BQIPAT(RDFN,0)),U,6)
  1.  S STAT=$$ACST(RGSTAT)
  1.  I 'STAT Q STAT
  1.  Q STAT_U_$S($P(STAT,U,2)="A":RGDT,1:TGDT)
  1.  ;Q $$ACST(RGSTAT)
  1.  ;
  1. CTAG(RDFN,RTAG) ;EP - Current tag status
  1.  NEW TGN,RGIEN,RGSTAT,RGDT,STAT,TGDT
  1.  S TGN=$$GDXN^BQITUTL(RTAG)
  1.  S RGIEN=$O(^BQIREG("C",RDFN,TGN,"")) I RGIEN="" Q ""
  1.  S RGSTAT=$P($G(^BQIREG(RGIEN,0)),U,3)
  1.  Q RGSTAT
  1.  ;
  1. LOW(DFN,TAG) ;EP - Check for lower hierarchy and return next lower one found
  1.  NEW RESULT,HCIEN,ORD,HORD,HIEN,HTAG,RIEN,HSTAT,QFL
  1.  S RESULT=0
  1.  S HCIEN=$O(^BQI(90506.2,TAG,4,"B",TAG,""))
  1.  S ORD=$P(^BQI(90506.2,TAG,4,HCIEN,0),U,2),HORD=ORD,QFL=0
  1.  F  S HORD=$O(^BQI(90506.2,TAG,4,"AC",HORD)) Q:HORD=""  D  Q:QFL
  1.  . S HIEN=$O(^BQI(90506.2,TAG,4,"AC",HORD,""))
  1.  . S HTAG=$P(^BQI(90506.2,TAG,4,HIEN,0),U,1)
  1.  . S RIEN=$O(^BQIREG("C",DFN,HTAG,""))
  1.  . I RIEN="" Q
  1.  . S HSTAT=$P(^BQIREG(RIEN,0),U,3)
  1.  . S RESULT=1_U_HTAG_U_$$ACST(HSTAT)
  1.  Q RESULT
  1.  ;
  1. HIGH(DFN,TAG) ;EP - Check for a higher hierarchy and return next highest one found
  1.  NEW RESULT,HCIEN,ORD,HORD,HIEN,HTAG,RIEN,HSTAT
  1.  S RESULT=0
  1.  S HCIEN=$O(^BQI(90506.2,TAG,4,"B",TAG,""))
  1.  S ORD=$P(^BQI(90506.2,TAG,4,HCIEN,0),U,2),HORD=ORD,QFL=0
  1.  F  S HORD=$O(^BQI(90506.2,TAG,4,"AC",HORD),-1) Q:HORD=""  D  Q:QFL
  1.  . S HIEN=$O(^BQI(90506.2,TAG,4,"AC",HORD,""))
  1.  . S HTAG=$P(^BQI(90506.2,TAG,4,HIEN,0),U,1)
  1.  . S RIEN=$O(^BQIREG("C",DFN,HTAG,""))
  1.  . I RIEN="" Q
  1.  . S HSTAT=$P(^BQIREG(RIEN,0),U,3)
  1.  . S RESULT=1_U_HTAG_U_$$ACST(HSTAT)
  1.  Q RESULT
  1.  ;
  1. REG(BQIDFN,BQITAG) ;EP - Inactive Associated Register status
  1.  ; Input
  1.  ;   BQIDFN - Patient internal entry number
  1.  ;   BQITAG - Tag internal entry number
  1.  NEW REGIEN,RDATA,FILE,FIELD,XREF,STFILE,STFLD,STEX,SUBREG,GLBREF,GLBNOD,DFN
  1.  NEW IENS,RESULT,PSTAT,RGRIEN
  1.  ; If there is no associated register with the tag, quit
  1.  S REGIEN=$P(^BQI(90506.2,BQITAG,0),U,8) I REGIEN="" Q 0
  1.  ; Get the information from the register on where the patient is located
  1.  S DFN=BQIDFN
  1.  S RDATA=^BQI(90507,REGIEN,0)
  1.  S FILE=$P(RDATA,U,7),FIELD=$P(RDATA,U,5),XREF=$P(RDATA,U,6)
  1.  S STFILE=$P(RDATA,U,15),STFLD=$P(RDATA,U,14),STEX=$G(^BQI(90507,REGIEN,1))
  1.  S SUBREG=$P(RDATA,U,9)
  1.  S GLBREF=$$ROOT^DILFD(FILE,"")_XREF_")"
  1.  S GLBNOD=$$ROOT^DILFD(FILE,"",1)
  1.  I GLBNOD="" Q 0
  1.  ;
  1.  ; If the register file doesn't exist, quit
  1.  I '$D(@GLBNOD@(0)) Q 0
  1.  ; If the patient isn't found in the register, quit
  1.  I '$D(@GLBREF@(BQIDFN)) Q 0
  1.  ;
  1.  S RESULT=2
  1.  ; If the register is a subregister in CMS, get the record IEN
  1.  I $G(SUBREG)'="" S QFL=0 D  I 'QFL Q 0
  1.  . S RGRIEN=""
  1.  . F  S RGRIEN=$O(@GLBREF@(BQIDFN,RGRIEN)) Q:RGRIEN=""  D
  1.  .. I $P($G(@GLBNOD@(RGRIEN,0)),U,5)=SUBREG S QFL=1,IENS=RGRIEN
  1.  ; If the register is not a subregister, get the record IEN
  1.  I $G(SUBREG)="" S IENS=$O(@GLBREF@(BQIDFN,""))
  1.  ; Execute the status executable
  1.  I STEX'="" X STEX Q:'$D(IENS)
  1.  ; Check on register status, only inactive tagged patients
  1.  ; stay proposed, status="inactive" or "unreviewed"
  1.  S PSTAT=$$GET1^DIQ(STFILE,IENS,STFLD,"I")
  1.  ;
  1.  I PSTAT'="A",PSTAT'="T" Q RESULT
  1.  Q 1
  1.  ;
  1. ORG(BQIDFN,BQIREG) ;EP - On register
  1.  NEW REGIEN,RDATA,FILE,FIELD,XREF,STFILE,STFLD,STEX,SUBREG,GLBREF,GLBNOD,DFN
  1.  NEW PSTAT,QFL
  1.  I BQIREG'?.N S REGIEN=$O(^BQI(90507,"B",BQIREG,"")) I REGIEN="" Q 0
  1.  I BQIREG?.N S REGIEN=BQIREG
  1.  S DFN=BQIDFN
  1.  S RDATA=^BQI(90507,REGIEN,0)
  1.  S FILE=$P(RDATA,U,7),FIELD=$P(RDATA,U,5),XREF=$P(RDATA,U,6)
  1.  S STFILE=$P(RDATA,U,15),STFLD=$P(RDATA,U,14),STEX=$G(^BQI(90507,REGIEN,1))
  1.  I $G(SUBREG)="" S SUBREG=$P(RDATA,U,9)
  1.  S GLBREF=$$ROOT^DILFD(FILE,"")_XREF_")"
  1.  S GLBNOD=$$ROOT^DILFD(FILE,"",1)
  1.  I GLBNOD="" Q 0
  1.  ;
  1.  I '$D(@GLBNOD@(0)) Q 0
  1.  I '$D(@GLBREF@(BQIDFN)) Q 0
  1.  ;
  1.  S RESULT=0
  1.  I $G(SUBREG)'="" S QFL=0 D  I 'QFL Q 0
  1.  . S RGRIEN=""
  1.  . F  S RGRIEN=$O(@GLBREF@(BQIDFN,RGRIEN)) Q:RGRIEN=""  D
  1.  .. I $P($G(@GLBNOD@(RGRIEN,0)),U,5)=SUBREG S QFL=1,IENS=RGRIEN
  1.  . ; Check register status
  1.  I $G(SUBREG)="" S IENS=$O(@GLBREF@(BQIDFN,""))
  1.  I STEX'="" X STEX Q:'$D(IENS)
  1.  ; Check on register status, only 'Active' register, tagged patients
  1.  ; become accepted
  1.  S PSTAT=$$GET1^DIQ(STFILE,IENS,STFLD,"I")
  1.  I PSTAT="" Q RESULT
  1.  I PSTAT'="A" Q RESULT
  1.  Q 1
  1.  ;
  1. FDX(BQDFN,TAX,POV) ;EP - First Diagnosis
  1.  NEW TREF,N,RESULT,VIS,VSDTM,IEN,DATE,RES
  1.  S TREF=$NA(^TMP($J,"BQIFDX")) K @TREF
  1.  I $G(TAX)'="" D BLD^BQITUTL(TAX,.TREF)
  1.  I $G(TAX)="",$G(POV)'="" S @TREF@(POV)=$$CODEC^ICDCODE(POV,80)
  1.  S N="" F  S N=$O(@TREF@(N)) Q:N=""  D
  1.  . S IEN="" F  S IEN=$O(^AUPNVPOV("AC",BQDFN,IEN)) Q:IEN=""  D
  1.  .. I $P(^AUPNVPOV(IEN,0),"^",1)'=N Q
  1.  .. S VIS=$P(^AUPNVPOV(IEN,0),"^",3),VSDTM=$P($G(^AUPNVSIT(VIS,0)),"^",1)\1
  1.  .. S RESULT(VSDTM,"V",VIS)=IEN
  1.  . S IEN="" F  S IEN=$O(^AUPNPROB("AC",BQDFN,IEN)) Q:IEN=""  D
  1.  .. I $P(^AUPNPROB(IEN,0),"^",1)'=N Q
  1.  .. S VSDTM=$$PROB^BQIUL1(IEN),RESULT(VSDTM,"P",IEN)=IEN
  1.  ;
  1.  S RES="",DATE=""
  1.  S DATE=$O(RESULT(DATE)) I DATE'="" D
  1.  . S RES=DATE_"^"_$O(RESULT(DATE,""))
  1.  Q RES