BQITDPRC ;PRXM/HC/ALA-Process Diagnosis Tag ; 11 May 2007 5:43 PM
;;2.1;ICARE MANAGEMENT SYSTEM;**1**;Feb 07, 2011;Build 5
Q
;
EN(DATA,DFN,TAG,STAT,DATE,USR,SCOM,OCOM) ;EP -- BQI UPDATE DX CAT
; Input
; DFN - Patient internal entry number
; TAG - the diagnosis tag internal entry number which is being updated
; STAT - status of the tag management
; DATE - Date of the update, assumes current date if not passed
; may be the date that the tag was last updated by nightly or
; weekly job
; USR - User updating the tag, assumes DUZ if not passed
; SCOM - Standard comment value, should always be passed
; OCOM - Other comment value
;
NEW UID,II,RDA,BI,TXT
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQITDPRC",UID))
K @DATA
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQITDPRC D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S TAG=$G(TAG,"") I TAG="" S BMXSEC="No Diagnosis Category identified" Q
S STAT=$G(STAT,"") I STAT="" S BMXSEC="No status identified" Q
S DFN=$G(DFN,"") I DFN="" S BMXSEC="No patient identified" Q
S SCOM=$G(SCOM,"") I SCOM="" S BMXSEC="No standard comment value identified" Q
I $G(USR)="" S USR=$$GET1^DIQ(200,DUZ_",",.01,"E")
I $G(DATE)="" S DATE=$$NOW^XLFDT()
S OCOM=$G(OCOM,"")
;
K BQTX
I $G(OCOM)[$C(10) D
. F BI=1:1 S TXT=$P(OCOM,$C(10),BI) Q:TXT="" S BQTX(BI,0)=TXT
;
I $G(OCOM)'[$C(10)&($G(OCOM)'="") S BQTX(1,0)=OCOM
;
S @DATA@(II)="I00010RESULT^T00030MSG"_$C(30)
I TAG'?.N S TAG=$$FIND1^DIC(90506.2,"","",TAG,"B","","")
;
; if Asthma tag, check last severity value to determine if 'Accepted'
I TAG=1 D
. NEW SEV,TXN
. I STAT'="P" Q
. S SEV=$$LASTSEV^APCHSAST(DFN,1)
. I SEV<2 Q
. S STAT="A"
. S TXN=$O(BQTX(0))+1
. S BQTX(TXN,0)="Patient's severity was "_$$LASTSEV^APCHSAST(DFN,5)
;
;Build the BQIREG record and move the BQIPAT factors into BQIFACT
S RDA=$O(^BQIREG("C",DFN,TAG,""))
I RDA="" D NPAT(DFN,TAG,STAT,DATE,USR,SCOM,.BQTX) G DONE
;
D UPAT(RDA,DFN,STAT,DATE,USR,SCOM,.BQTX)
;
DONE ;
S II=II+1,@DATA@(II)=$C(31)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
Q
;
NPAT(BQIDFN,BQITAG,BQISTA,DATE,USR,SCOM,BQTX) ;EP - Create new patient record
NEW DIC,DLAYGO,DA,BQIUPD
K ERROR
S DIC(0)="L",DLAYGO=90509,X=BQITAG,DIC="^BQIREG("
K DO,DD D FILE^DICN
S DA=+Y
I DA=-1 S II=II+1,@DATA@(II)="-1^Unable to create record"_$C(30) Q
S BQIUPD(90509,DA_",",.02)=BQIDFN
S BQIUPD(90509,DA_",",.03)=BQISTA
S BQIUPD(90509,DA_",",.04)=DATE
S BQIUPD(90509,DA_",",.05)=USR
S BQIUPD(90509,DA_",",.06)=SCOM
D FILE^DIE("","BQIUPD","ERROR")
I $D(BQTX)>0 D WP^DIE(90509,DA_",",1,"","BQTX","ERROR")
I $D(ERROR) S II=II+1,@DATA@(II)="-1"_"^"_$G(ERROR("DIERR",1,"TEXT",1))_$C(30) Q
I BQISTA="A" D MOV(BQIDFN,BQITAG)
;
S BQIRDA=$O(^BQIREG("C",BQIDFN,BQITAG,""))
I BQIRDA D HIER
;
S II=II+1,@DATA@(II)="1^"_$C(30)
Q
;
UPAT(BQIRDA,BQIDFN,BQISTA,DATE,USR,SCOM,BQTX) ;EP - Update patient record
NEW BQIUPD,ERROR,DIC,DA,PUSR,PSTAT,PCOM
; Build history record
K FDA
;S IENS="+1,"_BQIRDA_","
;
S PSTAT=$P(^BQIREG(BQIRDA,0),U,3)
S PUSR=$P(^BQIREG(BQIRDA,0),U,5)
S PCOM=$P(^BQIREG(BQIRDA,0),U,6)
;
S DIC(0)="L",DA(1)=BQIRDA,DIC="^BQIREG("_DA(1)_",10,",DIE=DIC
I $G(^BQIREG(DA(1),10,0))="" S ^BQIREG(DA(1),10,0)="^90509.01D^^"
S X=$$NOW^XLFDT()
K DO,DD D FILE^DICN S DA=+Y I DA=-1 Q
;
S IENS=$$IENS^DILF(.DA)
S FDA(90509.01,IENS,.02)=PSTAT
S FDA(90509.01,IENS,.03)=PUSR
S FDA(90509.01,IENS,.04)=PCOM
S FDA(90509.01,IENS,.05)=$P(^BQIREG(BQIRDA,0),U,4)
D FILE^DIE("","FDA","ERROR")
; Move comments
D WP^DIE(90509.01,IENS,1,"","^BQIREG(BQIRDA,1)")
; Move factors
S NDA=0
F S NDA=$O(^BQIREG(DA(1),5,NDA)) Q:'NDA D
. S ^BQIREG(DA(1),10,DA,5,NDA,0)=^BQIREG(DA(1),5,NDA,0)
. S ^BQIREG(DA(1),10,DA,5,"B",NDA,NDA)=""
. K ^BQIREG(DA(1),5,NDA)
I $G(^BQIREG(DA(1),5,0))'="" S ^BQIREG(DA(1),10,DA,5,0)=$G(^BQIREG(DA(1),5,0))
K ^BQIREG(DA(1),5)
;
I PSTAT="P" D MOV(BQIDFN,TAG)
;
; Set the new current values
S BQIUPD(90509,BQIRDA_",",.03)=BQISTA
S BQIUPD(90509,BQIRDA_",",.04)=DATE
S BQIUPD(90509,BQIRDA_",",.05)=USR
S BQIUPD(90509,BQIRDA_",",.06)=SCOM
S BQIUPD(90509,BQIRDA_",",1)="@"
D FILE^DIE("","BQIUPD","ERROR")
K ERROR
;
I $D(BQTX)>0 D WP^DIE(90509,BQIRDA_",",1,"","BQTX","ERROR")
;
D HIER
;
I $D(ERROR) S II=II+1,@DATA@(II)="-1^"_$C(30)
E S II=II+1,@DATA@(II)="1^"_$C(30)
Q
;
MOV(BQIDFN,BQITAG) ;EP - Move factors
NEW BQIFN,BQIFAC,BQIDID,BQIRN,BQIREC,BQIRDT,BQIREX,BQIIEN,ADD
NEW BQIFIL,BQIVPR,BQII,SUBREG,STFILE,STFLD,RGDATA,GLBNOD,BQIASRG
I $G(^BQIPAT(BQIDFN,20,BQITAG,0))="" Q
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
. I BQIFAC["Age:" S BQIVPR="~" D CHKR 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="" Q
.. D CHKR
.. Q
. I BQIFAC[" Tag" D CHKR
;
DEL ;Delete proposed tag data from BQIPAT
NEW DA,DIK
S DA(1)=BQIDFN,DA=BQITAG,DIK="^BQIPAT("_DA(1)_",20,"
D ^DIK
Q
;
NREC ;EP - Create new factor record
NEW DIC,DLAYGO,X,DA,BQIUPD,ERROR
I $G(DATE)="" S DATE=DT
S DIC(0)="L",DLAYGO=90509.5,X=BQIFAC,DIC="^BQIFACT("
K DO,DD D FILE^DICN
S (DA,RDA)=+Y
S BQIUPD(90509.5,DA_",",.02)=BQIDFN
S BQIUPD(90509.5,DA_",",.03)=BQITAG
S BQIUPD(90509.5,DA_",",.04)=DATE
S BQIUPD(90509.5,DA_",",.05)=$G(BQIVPR)
S BQIUPD(90509.5,DA_",",.06)=$G(BQIRDT)
S BQIUPD(90509.5,DA_",",.07)=$G(BQIIEN)
S BQIUPD(90509.5,DA_",",.08)=$G(BQIFIL)
S BQIUPD(90509.5,DA_",",.09)=$G(BQIREX)
S BQIUPD(90509.5,DA_",",.1)=BQIDID
D FILE^DIE("","BQIUPD","ERROR")
;
CF ; Set the factor into the CURRENT FACTORS multiple in ^BQIREG
NEW RIEN,DIC,DLAYGO,X,DA
S RIEN=$O(^BQIREG("C",BQIDFN,BQITAG,""))
I $G(^BQIREG(RIEN,5,0))="" S ^BQIREG(RIEN,5,0)="^90509.05P^^"
S DA(1)=RIEN
S DIC(0)="L",DLAYGO=90509.05,(X,DINUM)=RDA,DIC="^BQIREG("_DA(1)_",5,"
K DO,DD D FILE^DICN
Q
;
CHKR ;EP - Check for record
NEW BQIIFACT,BQIISR,BQIIFAC,BQIITG,BQIIVPR
S BQII=""
I $O(^BQIFACT("C",BQIDFN,BQITAG,BQII))="" D NREC Q
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)) D NREC Q
I '$D(BQIISR(BQIFAC,BQITAG,BQIVPR)) D NREC
Q
;
HIER ; Check for hierarchy and if BQISTA="N", set the next lower one
NEW TAG,THCFL,OK,NSTAT,HTAG,HSN,FCN,HIEN
S TAG=$P(^BQIREG(BQIRDA,0),U,1)
S THCFL=+$P(^BQI(90506.2,TAG,0),U,10)
I THCFL D
. I BQISTA="N" D
.. S OK=$$LOW^BQITDUTL(BQIDFN,TAG)
.. I 'OK Q
.. S HTAG=$P(OK,U,2)
.. S NSTAT=$S(HTAG=9:"A",1:"P")
.. D EN(.RDATA,BQIDFN,HTAG,NSTAT,,"REACTIVATED TAG",5)
.. ; Find the previous factors and move them back out of history
.. S HSN="A",QFL=0,HIEN=$O(^BQIREG("C",BQIDFN,HTAG,""))
.. F S HSN=$O(^BQIREG(HIEN,10,HSN),-1) Q:'HSN D Q:QFL
... S FCN=0
... F S FCN=$O(^BQIREG(HIEN,10,HSN,5,FCN)) Q:'FCN D
.... S ^BQIREG(HIEN,5,FCN,0)=^BQIREG(HIEN,10,HSN,5,FCN,0)
.... S ^BQIREG(HIEN,5,"B",FCN,FCN)="",QFL=1
... I QFL S ^BQIREG(HIEN,5,0)=^BQIREG(HIEN,10,HSN,5,0)
. ; If new active status, check for others in the hierarchy
. I BQISTA="A"!(BQISTA="P") D
.. S HSN="A",QFL=0
.. F S HSN=$O(^BQIREG(BQIRDA,10,HSN),-1) Q:'HSN D Q:QFL
... S FCN=0
... F S FCN=$O(^BQIREG(BQIRDA,10,HSN,5,FCN)) Q:'FCN D
.... S ^BQIREG(BQIRDA,5,FCN,0)=^BQIREG(BQIRDA,10,HSN,5,FCN,0)
.... S ^BQIREG(BQIRDA,5,"B",FCN,FCN)="",QFL=1
... I QFL S ^BQIREG(BQIRDA,5,0)=^BQIREG(BQIRDA,10,HSN,5,0)
.. ; if active lower, make it inactive with superseded
.. S OK=$$LOW^BQITDUTL(BQIDFN,TAG)
.. I OK S HTAG=$P(OK,U,2) D
... I '$P(OK,U,3) Q
... D EN(.RDATA,BQIDFN,HTAG,"S",,"SUPERSEDED",4)
Q
BQITDPRC ;PRXM/HC/ALA-Process Diagnosis Tag ; 11 May 2007 5:43 PM
+1 ;;2.1;ICARE MANAGEMENT SYSTEM;**1**;Feb 07, 2011;Build 5
+2 QUIT
+3 ;
EN(DATA,DFN,TAG,STAT,DATE,USR,SCOM,OCOM) ;EP -- BQI UPDATE DX CAT
+1 ; Input
+2 ; DFN - Patient internal entry number
+3 ; TAG - the diagnosis tag internal entry number which is being updated
+4 ; STAT - status of the tag management
+5 ; DATE - Date of the update, assumes current date if not passed
+6 ; may be the date that the tag was last updated by nightly or
+7 ; weekly job
+8 ; USR - User updating the tag, assumes DUZ if not passed
+9 ; SCOM - Standard comment value, should always be passed
+10 ; OCOM - Other comment value
+11 ;
+12 NEW UID,II,RDA,BI,TXT
+13 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+14 SET DATA=$NAME(^TMP("BQITDPRC",UID))
+15 KILL @DATA
+16 SET II=0
+17 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQITDPRC D UNWIND^%ZTER"
+18 ;
+19 SET TAG=$GET(TAG,"")
IF TAG=""
SET BMXSEC="No Diagnosis Category identified"
QUIT
+20 SET STAT=$GET(STAT,"")
IF STAT=""
SET BMXSEC="No status identified"
QUIT
+21 SET DFN=$GET(DFN,"")
IF DFN=""
SET BMXSEC="No patient identified"
QUIT
+22 SET SCOM=$GET(SCOM,"")
IF SCOM=""
SET BMXSEC="No standard comment value identified"
QUIT
+23 IF $GET(USR)=""
SET USR=$$GET1^DIQ(200,DUZ_",",.01,"E")
+24 IF $GET(DATE)=""
SET DATE=$$NOW^XLFDT()
+25 SET OCOM=$GET(OCOM,"")
+26 ;
+27 KILL BQTX
+28 IF $GET(OCOM)[$CHAR(10)
Begin DoDot:1
+29 FOR BI=1:1
SET TXT=$PIECE(OCOM,$CHAR(10),BI)
IF TXT=""
QUIT
SET BQTX(BI,0)=TXT
End DoDot:1
+30 ;
+31 IF $GET(OCOM)'[$CHAR(10)&($GET(OCOM)'="")
SET BQTX(1,0)=OCOM
+32 ;
+33 SET @DATA@(II)="I00010RESULT^T00030MSG"_$CHAR(30)
+34 IF TAG'?.N
SET TAG=$$FIND1^DIC(90506.2,"","",TAG,"B","","")
+35 ;
+36 ; if Asthma tag, check last severity value to determine if 'Accepted'
+37 IF TAG=1
Begin DoDot:1
+38 NEW SEV,TXN
+39 IF STAT'="P"
QUIT
+40 SET SEV=$$LASTSEV^APCHSAST(DFN,1)
+41 IF SEV<2
QUIT
+42 SET STAT="A"
+43 SET TXN=$ORDER(BQTX(0))+1
+44 SET BQTX(TXN,0)="Patient's severity was "_$$LASTSEV^APCHSAST(DFN,5)
End DoDot:1
+45 ;
+46 ;Build the BQIREG record and move the BQIPAT factors into BQIFACT
+47 SET RDA=$ORDER(^BQIREG("C",DFN,TAG,""))
+48 IF RDA=""
DO NPAT(DFN,TAG,STAT,DATE,USR,SCOM,.BQTX)
GOTO DONE
+49 ;
+50 DO UPAT(RDA,DFN,STAT,DATE,USR,SCOM,.BQTX)
+51 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(II)
IF $DATA(DATA)
SET II=II+1
SET @DATA@(II)=$CHAR(31)
+6 QUIT
+7 ;
NPAT(BQIDFN,BQITAG,BQISTA,DATE,USR,SCOM,BQTX) ;EP - Create new patient record
+1 NEW DIC,DLAYGO,DA,BQIUPD
+2 KILL ERROR
+3 SET DIC(0)="L"
SET DLAYGO=90509
SET X=BQITAG
SET DIC="^BQIREG("
+4 KILL DO,DD
DO FILE^DICN
+5 SET DA=+Y
+6 IF DA=-1
SET II=II+1
SET @DATA@(II)="-1^Unable to create record"_$CHAR(30)
QUIT
+7 SET BQIUPD(90509,DA_",",.02)=BQIDFN
+8 SET BQIUPD(90509,DA_",",.03)=BQISTA
+9 SET BQIUPD(90509,DA_",",.04)=DATE
+10 SET BQIUPD(90509,DA_",",.05)=USR
+11 SET BQIUPD(90509,DA_",",.06)=SCOM
+12 DO FILE^DIE("","BQIUPD","ERROR")
+13 IF $DATA(BQTX)>0
DO WP^DIE(90509,DA_",",1,"","BQTX","ERROR")
+14 IF $DATA(ERROR)
SET II=II+1
SET @DATA@(II)="-1"_"^"_$GET(ERROR("DIERR",1,"TEXT",1))_$CHAR(30)
QUIT
+15 IF BQISTA="A"
DO MOV(BQIDFN,BQITAG)
+16 ;
+17 SET BQIRDA=$ORDER(^BQIREG("C",BQIDFN,BQITAG,""))
+18 IF BQIRDA
DO HIER
+19 ;
+20 SET II=II+1
SET @DATA@(II)="1^"_$CHAR(30)
+21 QUIT
+22 ;
UPAT(BQIRDA,BQIDFN,BQISTA,DATE,USR,SCOM,BQTX) ;EP - Update patient record
+1 NEW BQIUPD,ERROR,DIC,DA,PUSR,PSTAT,PCOM
+2 ; Build history record
+3 KILL FDA
+4 ;S IENS="+1,"_BQIRDA_","
+5 ;
+6 SET PSTAT=$PIECE(^BQIREG(BQIRDA,0),U,3)
+7 SET PUSR=$PIECE(^BQIREG(BQIRDA,0),U,5)
+8 SET PCOM=$PIECE(^BQIREG(BQIRDA,0),U,6)
+9 ;
+10 SET DIC(0)="L"
SET DA(1)=BQIRDA
SET DIC="^BQIREG("_DA(1)_",10,"
SET DIE=DIC
+11 IF $GET(^BQIREG(DA(1),10,0))=""
SET ^BQIREG(DA(1),10,0)="^90509.01D^^"
+12 SET X=$$NOW^XLFDT()
+13 KILL DO,DD
DO FILE^DICN
SET DA=+Y
IF DA=-1
QUIT
+14 ;
+15 SET IENS=$$IENS^DILF(.DA)
+16 SET FDA(90509.01,IENS,.02)=PSTAT
+17 SET FDA(90509.01,IENS,.03)=PUSR
+18 SET FDA(90509.01,IENS,.04)=PCOM
+19 SET FDA(90509.01,IENS,.05)=$PIECE(^BQIREG(BQIRDA,0),U,4)
+20 DO FILE^DIE("","FDA","ERROR")
+21 ; Move comments
+22 DO WP^DIE(90509.01,IENS,1,"","^BQIREG(BQIRDA,1)")
+23 ; Move factors
+24 SET NDA=0
+25 FOR
SET NDA=$ORDER(^BQIREG(DA(1),5,NDA))
IF 'NDA
QUIT
Begin DoDot:1
+26 SET ^BQIREG(DA(1),10,DA,5,NDA,0)=^BQIREG(DA(1),5,NDA,0)
+27 SET ^BQIREG(DA(1),10,DA,5,"B",NDA,NDA)=""
+28 KILL ^BQIREG(DA(1),5,NDA)
End DoDot:1
+29 IF $GET(^BQIREG(DA(1),5,0))'=""
SET ^BQIREG(DA(1),10,DA,5,0)=$GET(^BQIREG(DA(1),5,0))
+30 KILL ^BQIREG(DA(1),5)
+31 ;
+32 IF PSTAT="P"
DO MOV(BQIDFN,TAG)
+33 ;
+34 ; Set the new current values
+35 SET BQIUPD(90509,BQIRDA_",",.03)=BQISTA
+36 SET BQIUPD(90509,BQIRDA_",",.04)=DATE
+37 SET BQIUPD(90509,BQIRDA_",",.05)=USR
+38 SET BQIUPD(90509,BQIRDA_",",.06)=SCOM
+39 SET BQIUPD(90509,BQIRDA_",",1)="@"
+40 DO FILE^DIE("","BQIUPD","ERROR")
+41 KILL ERROR
+42 ;
+43 IF $DATA(BQTX)>0
DO WP^DIE(90509,BQIRDA_",",1,"","BQTX","ERROR")
+44 ;
+45 DO HIER
+46 ;
+47 IF $DATA(ERROR)
SET II=II+1
SET @DATA@(II)="-1^"_$CHAR(30)
+48 IF '$TEST
SET II=II+1
SET @DATA@(II)="1^"_$CHAR(30)
+49 QUIT
+50 ;
MOV(BQIDFN,BQITAG) ;EP - Move factors
+1 NEW BQIFN,BQIFAC,BQIDID,BQIRN,BQIREC,BQIRDT,BQIREX,BQIIEN,ADD
+2 NEW BQIFIL,BQIVPR,BQII,SUBREG,STFILE,STFLD,RGDATA,GLBNOD,BQIASRG
+3 IF $GET(^BQIPAT(BQIDFN,20,BQITAG,0))=""
QUIT
+4 SET BQIDID=$PIECE(^BQIPAT(BQIDFN,20,BQITAG,0),U,2)
+5 SET BQIFN=0
+6 FOR
SET BQIFN=$ORDER(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN))
IF 'BQIFN
QUIT
Begin DoDot:1
+7 SET BQIFAC=$PIECE($GET(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,0)),U,1)
+8 IF BQIFAC=""
KILL ^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN)
QUIT
+9 IF BQIFAC["Age:"
SET BQIVPR="~"
DO CHKR
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=""
QUIT
+20 DO CHKR
+21 QUIT
End DoDot:2
+22 IF BQIFAC[" Tag"
DO CHKR
End DoDot:1
+23 ;
DEL ;Delete proposed tag data from BQIPAT
+1 NEW DA,DIK
+2 SET DA(1)=BQIDFN
SET DA=BQITAG
SET DIK="^BQIPAT("_DA(1)_",20,"
+3 DO ^DIK
+4 QUIT
+5 ;
NREC ;EP - Create new factor record
+1 NEW DIC,DLAYGO,X,DA,BQIUPD,ERROR
+2 IF $GET(DATE)=""
SET DATE=DT
+3 SET DIC(0)="L"
SET DLAYGO=90509.5
SET X=BQIFAC
SET DIC="^BQIFACT("
+4 KILL DO,DD
DO FILE^DICN
+5 SET (DA,RDA)=+Y
+6 SET BQIUPD(90509.5,DA_",",.02)=BQIDFN
+7 SET BQIUPD(90509.5,DA_",",.03)=BQITAG
+8 SET BQIUPD(90509.5,DA_",",.04)=DATE
+9 SET BQIUPD(90509.5,DA_",",.05)=$GET(BQIVPR)
+10 SET BQIUPD(90509.5,DA_",",.06)=$GET(BQIRDT)
+11 SET BQIUPD(90509.5,DA_",",.07)=$GET(BQIIEN)
+12 SET BQIUPD(90509.5,DA_",",.08)=$GET(BQIFIL)
+13 SET BQIUPD(90509.5,DA_",",.09)=$GET(BQIREX)
+14 SET BQIUPD(90509.5,DA_",",.1)=BQIDID
+15 DO FILE^DIE("","BQIUPD","ERROR")
+16 ;
CF ; Set the factor into the CURRENT FACTORS multiple in ^BQIREG
+1 NEW RIEN,DIC,DLAYGO,X,DA
+2 SET RIEN=$ORDER(^BQIREG("C",BQIDFN,BQITAG,""))
+3 IF $GET(^BQIREG(RIEN,5,0))=""
SET ^BQIREG(RIEN,5,0)="^90509.05P^^"
+4 SET DA(1)=RIEN
+5 SET DIC(0)="L"
SET DLAYGO=90509.05
SET (X,DINUM)=RDA
SET DIC="^BQIREG("_DA(1)_",5,"
+6 KILL DO,DD
DO FILE^DICN
+7 QUIT
+8 ;
CHKR ;EP - Check for record
+1 NEW BQIIFACT,BQIISR,BQIIFAC,BQIITG,BQIIVPR
+2 SET BQII=""
+3 IF $ORDER(^BQIFACT("C",BQIDFN,BQITAG,BQII))=""
DO NREC
QUIT
+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))
DO NREC
QUIT
+12 IF '$DATA(BQIISR(BQIFAC,BQITAG,BQIVPR))
DO NREC
+13 QUIT
+14 ;
HIER ; Check for hierarchy and if BQISTA="N", set the next lower one
+1 NEW TAG,THCFL,OK,NSTAT,HTAG,HSN,FCN,HIEN
+2 SET TAG=$PIECE(^BQIREG(BQIRDA,0),U,1)
+3 SET THCFL=+$PIECE(^BQI(90506.2,TAG,0),U,10)
+4 IF THCFL
Begin DoDot:1
+5 IF BQISTA="N"
Begin DoDot:2
+6 SET OK=$$LOW^BQITDUTL(BQIDFN,TAG)
+7 IF 'OK
QUIT
+8 SET HTAG=$PIECE(OK,U,2)
+9 SET NSTAT=$SELECT(HTAG=9:"A",1:"P")
+10 DO EN(.RDATA,BQIDFN,HTAG,NSTAT,,"REACTIVATED TAG",5)
+11 ; Find the previous factors and move them back out of history
+12 SET HSN="A"
SET QFL=0
SET HIEN=$ORDER(^BQIREG("C",BQIDFN,HTAG,""))
+13 FOR
SET HSN=$ORDER(^BQIREG(HIEN,10,HSN),-1)
IF 'HSN
QUIT
Begin DoDot:3
+14 SET FCN=0
+15 FOR
SET FCN=$ORDER(^BQIREG(HIEN,10,HSN,5,FCN))
IF 'FCN
QUIT
Begin DoDot:4
+16 SET ^BQIREG(HIEN,5,FCN,0)=^BQIREG(HIEN,10,HSN,5,FCN,0)
+17 SET ^BQIREG(HIEN,5,"B",FCN,FCN)=""
SET QFL=1
End DoDot:4
+18 IF QFL
SET ^BQIREG(HIEN,5,0)=^BQIREG(HIEN,10,HSN,5,0)
End DoDot:3
IF QFL
QUIT
End DoDot:2
+19 ; If new active status, check for others in the hierarchy
+20 IF BQISTA="A"!(BQISTA="P")
Begin DoDot:2
+21 SET HSN="A"
SET QFL=0
+22 FOR
SET HSN=$ORDER(^BQIREG(BQIRDA,10,HSN),-1)
IF 'HSN
QUIT
Begin DoDot:3
+23 SET FCN=0
+24 FOR
SET FCN=$ORDER(^BQIREG(BQIRDA,10,HSN,5,FCN))
IF 'FCN
QUIT
Begin DoDot:4
+25 SET ^BQIREG(BQIRDA,5,FCN,0)=^BQIREG(BQIRDA,10,HSN,5,FCN,0)
+26 SET ^BQIREG(BQIRDA,5,"B",FCN,FCN)=""
SET QFL=1
End DoDot:4
+27 IF QFL
SET ^BQIREG(BQIRDA,5,0)=^BQIREG(BQIRDA,10,HSN,5,0)
End DoDot:3
IF QFL
QUIT
+28 ; if active lower, make it inactive with superseded
+29 SET OK=$$LOW^BQITDUTL(BQIDFN,TAG)
+30 IF OK
SET HTAG=$PIECE(OK,U,2)
Begin DoDot:3
+31 IF '$PIECE(OK,U,3)
QUIT
+32 DO EN(.RDATA,BQIDFN,HTAG,"S",,"SUPERSEDED",4)
End DoDot:3
End DoDot:2
End DoDot:1
+33 QUIT
