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