BQICASUI ;PRXM/HC/ALA-Find Community Suicides ; 11 Oct 2007 2:10 PM
;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
;
FND ; EP - Find Suicides
NEW DATA,ENDT,STDT,DATE,VC,VCIEN,VCODE,RIEN,IEN,CIEN,CM,COMM,DFN,DIEN
NEW DTC,DTE,DTY,E1,E2,E3,PT,SIEN,TAX,TIEN,TREF,VISIT,VSDTM,X,XIEN,Y
NEW FILE
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
; Set the alert temporary global
S DATA=$NA(^TMP("BQISUICTMP",UID))
K @DATA
;
NEW DA,IENS,BQIH,BQI,TMFRAME,ENDT,DATE,STDT,VC,VCODE,RIEN,IEN,VCIEN
NEW DFN,COMM,TREF,VISIT,VSDTM,DTY,E1,E2,E3,CM,PT
S BQIH=$$SPM^BQIGPUTL()
S BQI=$O(^BQI(90508,BQIH,15,"B","Suicidal Behavior",""))
S DA(1)=BQIH,DA=BQI,IENS=$$IENS^DILF(.DA)
S TMFRAME=$$GET1^DIQ(90508.015,IENS,.03,"E") S:TMFRAME="" TMFRAME=30
S TMFRAME="T-"_TMFRAME
S ENDT=DT,STDT=$$DATE^BQIUL1(TMFRAME),DATE=STDT_".24"
;
; Set up the visit codes
F VC=39,40,41 S VCIEN=$O(^AMHPROB("B",VC,"")) Q:VCIEN="" D
. S VCODE(VCIEN)=$P(^AMHPROB(VCIEN,0),U,5)
. S:VC=39 $P(VCODE(VCIEN),U,2)="Ideation"
. S:VC=40 $P(VCODE(VCIEN),U,2)="Attempt"
. S:VC=41 $P(VCODE(VCIEN),U,2)="Completion"
;
; Check in the MHSS files
F S DATE=$O(^AMHREC("B",DATE)) Q:DATE=""!(DATE\1>ENDT) D
. S RIEN=""
. F S RIEN=$O(^AMHREC("B",DATE,RIEN)) Q:RIEN="" D
.. S IEN=""
.. F S IEN=$O(^AMHRPRO("AD",RIEN,IEN),-1) Q:IEN="" D
... S VCIEN=$P(^AMHRPRO(IEN,0),U,1)
... I '$D(VCODE(VCIEN)) Q
... S DFN=$P(^AMHRPRO(IEN,0),U,2) I DFN="" S DFN="Not identified"
... S FILE=9002011.01
... S COMM=$$GET1^DIQ(9000001,DFN_",",1117,"I")
... I COMM="" S COMM=$$COMM()
... S @DATA@(COMM,DFN,$P(VCODE(VCIEN),U,2),DATE\1,$P(VCODE(VCIEN),U,1))=RIEN_U_IEN_U_FILE_U
;
; Check for a Suicide Form
NEW DTACT,RIEN,STY,TYPE,FILE,DFN,COMM,ICD
S DTACT=$$DATE^BQIUL1("T-30"),DTACT=DTACT-.001
F S DTACT=$O(^AMHPSUIC("AD",DTACT)) Q:DTACT="" D
. S RIEN=""
. F S RIEN=$O(^AMHPSUIC("AD",DTACT,RIEN)) Q:RIEN="" D
.. S FILE=9002011.65
.. S DFN=$P(^AMHPSUIC(RIEN,0),U,4),TYPE=$$GET1^DIQ(9002011.65,RIEN_",",.13,"I")
.. I TYPE="" Q
.. S STY=$S(TYPE=1:"Ideation",TYPE=2!(TYPE=4)!(TYPE=6)!(TYPE=7):"Attempt",1:"Completion")
.. D
... I STY="Ideation" S ICD=$$SCD("BGP SUICIDAL IDEATION DXS",DTACT) Q
... I STY="Attempt" S ICD=$$SCD("BQI SUICIDE ATTEMPT DXS",DTACT) Q
... ;S ICD=$$SCD("BQI SUICIDE COMPLETION DXS",DTACT)
.. I $G(ICD)="" S ICD="Not specified"
.. S COMM=$$GET1^DIQ(9000001,DFN_",",1117,"I")
.. I COMM="" S COMM=$$COMM()
.. S @DATA@(COMM,DFN,STY,DTACT\1,ICD)=RIEN_U_U_FILE
;
; Check SNOMED in Problem file and V POV
F BQISUB="PXRM BQI SUICIDE IDEATION","PXRM BQI SUICIDE ATTEMPT","PXRM BQI SUICIDE COMPLETION" D
. S TREF=$NA(^TMP("BQISNOM",$J)) K @TREF
. S BQIOK=$$SUBLST^BSTSAPI(TREF,BQISUB_"^36^1")
. I 'BQIOK Q
. S SNIEN=""
. F S SNIEN=$O(@TREF@(SNIEN)) Q:SNIEN="" D
.. S SCID=$P(@TREF@(SNIEN),U,1)
.. D SNS(SCID)
;
; Check in PCC
F TAX="BGP SUICIDAL IDEATION DXS","BQI SUICIDE ATTEMPT DXS" D
. NEW DIAC
. ;D BLDSV^BQITUTL(80,"V62.84 ",TREF)
. ;D BLDSV^BQITUTL(80,"798.1 ",TREF)
. S TREF=$NA(^TMP("BQITAX",UID))
. K @TREF
. D BLD^BQITUTL(TAX,.TREF)
. S TIEN=0 F S TIEN=$O(@TREF@(TIEN)) Q:'TIEN D
.. S IEN="",DIAC=$P(@TREF@(TIEN),U,1)
.. F S IEN=$O(^AUPNVPOV("B",TIEN,IEN),-1) Q:IEN="" D
... ; if a bad record (no zero node), quit
... I $G(^AUPNVPOV(IEN,0))="" Q
... ; get patient record
... S DFN=$$GET1^DIQ(9000010.07,IEN,.02,"I") Q:DFN=""
... S VISIT=$$GET1^DIQ(9000010.07,IEN,.03,"I") Q:VISIT=""
... ; if the visit is deleted, quit
... I $$GET1^DIQ(9000010,VISIT,.11,"I")=1 Q
... S VSDTM=$$GET1^DIQ(9000010,VISIT,.01,"I")\1 Q:VSDTM=0
... S COMM=$$GET1^DIQ(9000001,DFN_",",1117,"I")
... I COMM="" S COMM=$$COMM()
... S FILE=9000010
... I $G(TMFRAME)'="",VSDTM'>STDT Q
... ;I $G(TMFRAME)'="",VSDTM<STDT Q
... S DTY=$S(TAX["IDEATION":"Ideation",TAX["ATTEMPT":"Attempt",1:"Completion")
... ;I '$D(@DATA@(COMM,DFN,DTY,VSDTM)) S @DATA@(COMM,DFN,DTY,VSDTM,@TREF@(TIEN))=VISIT_U_U_$S(@TREF@(TIEN)["V62.84":"Ideation",1:"Completion")_U_FILE Q
... I '$D(@DATA@(COMM,DFN,DTY,VSDTM)) S @DATA@(COMM,DFN,DTY,VSDTM,DIAC)=VISIT_U_U_FILE Q
; Look for ECODES
K @TREF
S TAX="BQI INJ SUICIDE CODES"
;I '$D(^ATXAX("B",TAX)) S TAX="APCL INJ SUICIDE"
D BLD^BQITUTL(TAX,TREF)
;S DATE=STDT
S DATE=STDT_".24"
F S DATE=$O(^AUPNVSIT("B",DATE)) Q:DATE=""!(DATE\1>ENDT) D
. S VISIT=""
. F S VISIT=$O(^AUPNVSIT("B",DATE,VISIT)) Q:VISIT="" D
.. S IEN=""
.. F S IEN=$O(^AUPNVPOV("AD",VISIT,IEN)) Q:IEN="" D
... S E1=$P(^AUPNVPOV(IEN,0),U,9)
... S E2=$P(^AUPNVPOV(IEN,0),U,18)
... S E3=$P(^AUPNVPOV(IEN,0),U,19)
... I E1="",E2="",E3="" Q
... I E1'="",$D(@TREF@(E1)) D STOR(E1,(DATE\1))
... I E2'="",$D(@TREF@(E2)) D STOR(E2,(DATE\1))
... I E3'="",$D(@TREF@(E3)) D STOR(E3,(DATE\1))
;
; Check for duplicates
NEW LDTE
S (CM,DTY,PT)=""
F S CM=$O(@DATA@(CM)) Q:CM="" D
. F S PT=$O(@DATA@(CM,PT)) Q:PT="" D
.. F S DTY=$O(@DATA@(CM,PT,DTY)) Q:DTY="" D
... S DTE=$O(@DATA@(CM,PT,DTY,""),-1) Q:DTE=""
... S LDTE=$$FMADD^XLFDT(DTE,-30)
... F S DTE=$O(@DATA@(CM,PT,DTY,DTE),-1) Q:DTE="" D
.... ; Only one suicide type per patient per 30 day period should be included
.... I DTE>LDTE K @DATA@(CM,PT,DTY,DTE) Q
.... S LDTE=$$FMADD^XLFDT(DTE,-30)
;
S CM=""
F S CM=$O(@DATA@(CM)) Q:CM="" D
. S PT=""
. F S PT=$O(@DATA@(CM,PT)) Q:PT="" D
.. S DTY=""
.. F S DTY=$O(@DATA@(CM,PT,DTY)) Q:DTY="" D
... S DTE=""
... F S DTE=$O(@DATA@(CM,PT,DTY,DTE)) Q:DTE="" D
.... S DTC=""
.... F S DTC=$O(@DATA@(CM,PT,DTY,DTE,DTC)) Q:DTC="" D
..... S VISIT=$P(@DATA@(CM,PT,DTY,DTE,DTC),U,1)
..... S FILE=$P(@DATA@(CM,PT,DTY,DTE,DTC),U,3)
..... D NFILE(CM,DTY,DTC,DTE,VISIT,PT,FILE)
;
K @TREF,@DATA
Q
;
NFILE(COMM,DCAT,DXC,DATE,VISIT,PT,FILE) ;
; Input
; COMM - Community
; DCAT - Diagnosis Category
; DXC - Diagnosis Code
; DATE - Event Date
; VISIT - Visit to make it unique
; PT - DFN
; Assumed that the Alert Type is Suicidal Behavior
NEW DIC,DA,AIEN,CIEN,DIEN,RIEN,NFLG,USR
; Set the community
S DIC="^BQI(90507.6,",X="`"_COMM,DIC(0)="LMZ"
D ^DIC
S CIEN=+Y
I CIEN=-1 S (X,DINUM)=COMM K DO,DD D FILE^DICN S CIEN=+Y
; Set the Alert Type
S DA(1)=CIEN,X="Suicidal Behavior",DIC="^BQI(90507.6,"_DA(1)_",1,",DIC(0)="LMN"
I $G(^BQI(90507.6,DA(1),1,0))="" S ^BQI(90507.6,DA(1),1,0)="^90507.61A^^"
D ^DIC
S AIEN=+Y
; Set the DX Category
S DA(2)=CIEN,DA(1)=AIEN,X=DCAT,DIC(0)="LMN"
S DIC="^BQI(90507.6,"_DA(2)_",1,"_DA(1)_",1,"
I $G(^BQI(90507.6,DA(2),1,DA(1),1,0))="" S ^BQI(90507.6,DA(2),1,DA(1),1,0)="^90507.611A^^"
D ^DIC
S DIEN=+Y
; Set the Dx Code
K X
;S DA(3)=CIEN,DA(2)=AIEN,DA(1)=DIEN,X(1)=DXC,X(2)=DATE,X(3)=VISIT,DIC(0)="LN",D="C"
S DA(3)=CIEN,DA(2)=AIEN,DA(1)=DIEN,X(1)=PT,X(2)=DATE,X(3)=VISIT,DIC(0)="LN",D="D"
S DIC="^BQI(90507.6,"_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",1,"
I $G(^BQI(90507.6,DA(3),1,DA(2),1,DA(1),1,0))="" S ^BQI(90507.6,DA(3),1,DA(2),1,DA(1),1,0)="^90507.6111A^^"
D IX^DIC
I Y=-1 D
. K X,D
. S X(1)=DXC,X(2)=DATE,X(3)=VISIT,D="C"
. D IX^DIC
S RIEN=+Y,NFLG=+$P(Y,U,3)
S $P(^BQI(90507.6,DA(3),1,DA(2),1,DA(1),1,RIEN,0),U,4)=PT
S $P(^BQI(90507.6,DA(3),1,DA(2),1,DA(1),1,RIEN,0),U,5)=FILE
I $D(BQIUPD) D FILE^DIE("","BQIUPD","ERROR")
NEW DIK
S DIK=DIC,DIK(1)=.04
D ENALL^DIK
;
Q
; Set the users
S USR=0
F S USR=$O(^BQICARE(USR)) Q:'USR D
. S DA(3)=CIEN,DA(2)=AIEN,DA(1)=DIEN,X=USR,DIC(0)="LMN",DINUM=X
. S DIC="^BQI(90507.6,"_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",5,"
. I $G(^BQI(90507.6,DA(3),1,DA(2),1,DA(1),5,0))="" S ^BQI(90507.6,DA(3),1,DA(2),1,DA(1),5,0)="^90507.6115PA^^"
. K DO,DD D FILE^DICN
Q
;
STOR(TIEN,VSDTM) ;
NEW DFN,COMM,FILE,DIAG
S DFN=$$GET1^DIQ(9000010.07,IEN,.02,"I") Q:DFN=""
S COMM=$$GET1^DIQ(9000001,DFN_",",1117,"I")
I COMM="" S COMM=$$COMM()
S DIAG=$P(@TREF@(TIEN),U,1),FILE=9000010
I '$D(@DATA@(COMM,DFN,"Not Categorized",VSDTM)) S @DATA@(COMM,DFN,"Not Categorized",VSDTM,DIAG)=VISIT_U_U_FILE Q
Q
;
SCD(TAX,ADT) ;EP - Find appropriate code
NEW TREF,BQN,BQCODE
S TREF="BQITAX" K @TREF
D BLD^BQITUTL(TAX,.TREF)
I '$D(@TREF) Q ""
S BQN=""
F S BQN=$O(@TREF@(BQN)) Q:BQN="" D
. I $$VERSION^XPDUTL("AICD")<4.0 D Q
.. I $P(@TREF@(BQN),U,4)="ICD-9-CM" S BQCODE=$P(@TREF@(BQN),U,1)
. I $$VERSION^XPDUTL("AICD")>3.51 D
.. I ADT<$$IMP^ICDEXA(30) D Q
... I $P(@TREF@(BQN),U,4)="ICD-9-CM" S BQCODE=$P(@TREF@(BQN),U,1)
.. I $P(@TREF@(BQN),U,4)="ICD-10-CM" S BQCODE=$P(@TREF@(BQN),U,1)
Q BQCODE
;
SNS(BQCID) ;EP - Look by concept ID
S PIEN=""
F S PIEN=$O(^AUPNPROB("ASCT",BQCID,PIEN)) Q:PIEN="" D
. I $G(^AUPNPROB(PIEN,0))="" Q
. S STAT=$P(^AUPNPROB(PIEN,0),"^",12)
. I STAT="I"!(STAT="D") Q
. S VSDTM=$$PROB^BQIUL1(PIEN)\1 I VSDTM<STDT Q
. S DTY=$S(BQISUB["IDEATION":"Ideation",BQISUB["ATTEMPT":"Attempt",1:"Completion")
. S DFN=$P(^AUPNPROB(PIEN,0),"^",2)
. S DIAC=BQCID
. S COMM=$$GET1^DIQ(9000001,DFN_",",1117,"I")
. I COMM="" S COMM=$$COMM()
. I '$D(@DATA@(COMM,DFN,DTY,VSDTM)) S @DATA@(COMM,DFN,DTY,VSDTM,DIAC)=PIEN_U_U_"9000011" Q
. S @DATA@(COMM,DFN,DTY,VSDTM,BQCID)=PIEN_U_IEN_U_"9000011"
;
S IEN=""
F S IEN=$O(^AUPNVPOV("ASCI",BQCID,IEN)) Q:IEN="" D
. ; For each entry CONCEPT ID
. ; if a bad record (no zero node), quit
. I $G(^AUPNVPOV(IEN,0))="" Q
. S VISIT=$P(^AUPNVPOV(IEN,0),"^",3),DFN=$P(^(0),"^",2)
. I VISIT="" Q
. S VSDTM=$P($G(^AUPNVSIT(VISIT,0)),"^",1)\1 I VSDTM=0 Q
. I VSDTM<STDT Q
. S COMM=$$GET1^DIQ(9000001,DFN_",",1117,"I"),FILE="9000010.07"
. I COMM="" S COMM=$$COMM()
. S DTY=$S(BQISUB["IDEATION":"Ideation",BQISUB["ATTEMPT":"Attempt",1:"Completion")
. S DIAC=BQCID
. I '$D(@DATA@(COMM,DFN,DTY,VSDTM)) S @DATA@(COMM,DFN,DTY,VSDTM,DIAC)=VISIT_U_U_FILE Q
. S @DATA@(COMM,DFN,DTY,VSDTM,BQCID)=VISIT_U_IEN_U_FILE
Q
;
COMM() ;EP - Get UNKNOWN community
S COMM=$$FIND1^DIC(9999999.05,"","BX","UNKNOWN","","","ERROR")
I COMM=-1 S COMM="Not identified"
Q COMM
BQICASUI ;PRXM/HC/ALA-Find Community Suicides ; 11 Oct 2007 2:10 PM
+1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
+2 ;
FND ; EP - Find Suicides
+1 NEW DATA,ENDT,STDT,DATE,VC,VCIEN,VCODE,RIEN,IEN,CIEN,CM,COMM,DFN,DIEN
+2 NEW DTC,DTE,DTY,E1,E2,E3,PT,SIEN,TAX,TIEN,TREF,VISIT,VSDTM,X,XIEN,Y
+3 NEW FILE
+4 ;
+5 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+6 ; Set the alert temporary global
+7 SET DATA=$NAME(^TMP("BQISUICTMP",UID))
+8 KILL @DATA
+9 ;
+10 NEW DA,IENS,BQIH,BQI,TMFRAME,ENDT,DATE,STDT,VC,VCODE,RIEN,IEN,VCIEN
+11 NEW DFN,COMM,TREF,VISIT,VSDTM,DTY,E1,E2,E3,CM,PT
+12 SET BQIH=$$SPM^BQIGPUTL()
+13 SET BQI=$ORDER(^BQI(90508,BQIH,15,"B","Suicidal Behavior",""))
+14 SET DA(1)=BQIH
SET DA=BQI
SET IENS=$$IENS^DILF(.DA)
+15 SET TMFRAME=$$GET1^DIQ(90508.015,IENS,.03,"E")
IF TMFRAME=""
SET TMFRAME=30
+16 SET TMFRAME="T-"_TMFRAME
+17 SET ENDT=DT
SET STDT=$$DATE^BQIUL1(TMFRAME)
SET DATE=STDT_".24"
+18 ;
+19 ; Set up the visit codes
+20 FOR VC=39,40,41
SET VCIEN=$ORDER(^AMHPROB("B",VC,""))
IF VCIEN=""
QUIT
Begin DoDot:1
+21 SET VCODE(VCIEN)=$PIECE(^AMHPROB(VCIEN,0),U,5)
+22 IF VC=39
SET $PIECE(VCODE(VCIEN),U,2)="Ideation"
+23 IF VC=40
SET $PIECE(VCODE(VCIEN),U,2)="Attempt"
+24 IF VC=41
SET $PIECE(VCODE(VCIEN),U,2)="Completion"
End DoDot:1
+25 ;
+26 ; Check in the MHSS files
+27 FOR
SET DATE=$ORDER(^AMHREC("B",DATE))
IF DATE=""!(DATE\1>ENDT)
QUIT
Begin DoDot:1
+28 SET RIEN=""
+29 FOR
SET RIEN=$ORDER(^AMHREC("B",DATE,RIEN))
IF RIEN=""
QUIT
Begin DoDot:2
+30 SET IEN=""
+31 FOR
SET IEN=$ORDER(^AMHRPRO("AD",RIEN,IEN),-1)
IF IEN=""
QUIT
Begin DoDot:3
+32 SET VCIEN=$PIECE(^AMHRPRO(IEN,0),U,1)
+33 IF '$DATA(VCODE(VCIEN))
QUIT
+34 SET DFN=$PIECE(^AMHRPRO(IEN,0),U,2)
IF DFN=""
SET DFN="Not identified"
+35 SET FILE=9002011.01
+36 SET COMM=$$GET1^DIQ(9000001,DFN_",",1117,"I")
+37 IF COMM=""
SET COMM=$$COMM()
+38 SET @DATA@(COMM,DFN,$PIECE(VCODE(VCIEN),U,2),DATE\1,$PIECE(VCODE(VCIEN),U,1))=RIEN_U_IEN_U_FILE_U
End DoDot:3
End DoDot:2
End DoDot:1
+39 ;
+40 ; Check for a Suicide Form
+41 NEW DTACT,RIEN,STY,TYPE,FILE,DFN,COMM,ICD
+42 SET DTACT=$$DATE^BQIUL1("T-30")
SET DTACT=DTACT-.001
+43 FOR
SET DTACT=$ORDER(^AMHPSUIC("AD",DTACT))
IF DTACT=""
QUIT
Begin DoDot:1
+44 SET RIEN=""
+45 FOR
SET RIEN=$ORDER(^AMHPSUIC("AD",DTACT,RIEN))
IF RIEN=""
QUIT
Begin DoDot:2
+46 SET FILE=9002011.65
+47 SET DFN=$PIECE(^AMHPSUIC(RIEN,0),U,4)
SET TYPE=$$GET1^DIQ(9002011.65,RIEN_",",.13,"I")
+48 IF TYPE=""
QUIT
+49 SET STY=$SELECT(TYPE=1:"Ideation",TYPE=2!(TYPE=4)!(TYPE=6)!(TYPE=7):"Attempt",1:"Completion")
+50 Begin DoDot:3
+51 IF STY="Ideation"
SET ICD=$$SCD("BGP SUICIDAL IDEATION DXS",DTACT)
QUIT
+52 IF STY="Attempt"
SET ICD=$$SCD("BQI SUICIDE ATTEMPT DXS",DTACT)
QUIT
+53 ;S ICD=$$SCD("BQI SUICIDE COMPLETION DXS",DTACT)
End DoDot:3
+54 IF $GET(ICD)=""
SET ICD="Not specified"
+55 SET COMM=$$GET1^DIQ(9000001,DFN_",",1117,"I")
+56 IF COMM=""
SET COMM=$$COMM()
+57 SET @DATA@(COMM,DFN,STY,DTACT\1,ICD)=RIEN_U_U_FILE
End DoDot:2
End DoDot:1
+58 ;
+59 ; Check SNOMED in Problem file and V POV
+60 FOR BQISUB="PXRM BQI SUICIDE IDEATION","PXRM BQI SUICIDE ATTEMPT","PXRM BQI SUICIDE COMPLETION"
Begin DoDot:1
+61 SET TREF=$NAME(^TMP("BQISNOM",$JOB))
KILL @TREF
+62 SET BQIOK=$$SUBLST^BSTSAPI(TREF,BQISUB_"^36^1")
+63 IF 'BQIOK
QUIT
+64 SET SNIEN=""
+65 FOR
SET SNIEN=$ORDER(@TREF@(SNIEN))
IF SNIEN=""
QUIT
Begin DoDot:2
+66 SET SCID=$PIECE(@TREF@(SNIEN),U,1)
+67 DO SNS(SCID)
End DoDot:2
End DoDot:1
+68 ;
+69 ; Check in PCC
+70 FOR TAX="BGP SUICIDAL IDEATION DXS","BQI SUICIDE ATTEMPT DXS"
Begin DoDot:1
+71 NEW DIAC
+72 ;D BLDSV^BQITUTL(80,"V62.84 ",TREF)
+73 ;D BLDSV^BQITUTL(80,"798.1 ",TREF)
+74 SET TREF=$NAME(^TMP("BQITAX",UID))
+75 KILL @TREF
+76 DO BLD^BQITUTL(TAX,.TREF)
+77 SET TIEN=0
FOR
SET TIEN=$ORDER(@TREF@(TIEN))
IF 'TIEN
QUIT
Begin DoDot:2
+78 SET IEN=""
SET DIAC=$PIECE(@TREF@(TIEN),U,1)
+79 FOR
SET IEN=$ORDER(^AUPNVPOV("B",TIEN,IEN),-1)
IF IEN=""
QUIT
Begin DoDot:3
+80 ; if a bad record (no zero node), quit
+81 IF $GET(^AUPNVPOV(IEN,0))=""
QUIT
+82 ; get patient record
+83 SET DFN=$$GET1^DIQ(9000010.07,IEN,.02,"I")
IF DFN=""
QUIT
+84 SET VISIT=$$GET1^DIQ(9000010.07,IEN,.03,"I")
IF VISIT=""
QUIT
+85 ; if the visit is deleted, quit
+86 IF $$GET1^DIQ(9000010,VISIT,.11,"I")=1
QUIT
+87 SET VSDTM=$$GET1^DIQ(9000010,VISIT,.01,"I")\1
IF VSDTM=0
QUIT
+88 SET COMM=$$GET1^DIQ(9000001,DFN_",",1117,"I")
+89 IF COMM=""
SET COMM=$$COMM()
+90 SET FILE=9000010
+91 IF $GET(TMFRAME)'=""
IF VSDTM'>STDT
QUIT
+92 ;I $G(TMFRAME)'="",VSDTM<STDT Q
+93 SET DTY=$SELECT(TAX["IDEATION":"Ideation",TAX["ATTEMPT":"Attempt",1:"Completion")
+94 ;I '$D(@DATA@(COMM,DFN,DTY,VSDTM)) S @DATA@(COMM,DFN,DTY,VSDTM,@TREF@(TIEN))=VISIT_U_U_$S(@TREF@(TIEN)["V62.84":"Ideation",1:"Completion")_U_FILE Q
+95 IF '$DATA(@DATA@(COMM,DFN,DTY,VSDTM))
SET @DATA@(COMM,DFN,DTY,VSDTM,DIAC)=VISIT_U_U_FILE
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+96 ; Look for ECODES
+97 KILL @TREF
+98 SET TAX="BQI INJ SUICIDE CODES"
+99 ;I '$D(^ATXAX("B",TAX)) S TAX="APCL INJ SUICIDE"
+100 DO BLD^BQITUTL(TAX,TREF)
+101 ;S DATE=STDT
+102 SET DATE=STDT_".24"
+103 FOR
SET DATE=$ORDER(^AUPNVSIT("B",DATE))
IF DATE=""!(DATE\1>ENDT)
QUIT
Begin DoDot:1
+104 SET VISIT=""
+105 FOR
SET VISIT=$ORDER(^AUPNVSIT("B",DATE,VISIT))
IF VISIT=""
QUIT
Begin DoDot:2
+106 SET IEN=""
+107 FOR
SET IEN=$ORDER(^AUPNVPOV("AD",VISIT,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+108 SET E1=$PIECE(^AUPNVPOV(IEN,0),U,9)
+109 SET E2=$PIECE(^AUPNVPOV(IEN,0),U,18)
+110 SET E3=$PIECE(^AUPNVPOV(IEN,0),U,19)
+111 IF E1=""
IF E2=""
IF E3=""
QUIT
+112 IF E1'=""
IF $DATA(@TREF@(E1))
DO STOR(E1,(DATE\1))
+113 IF E2'=""
IF $DATA(@TREF@(E2))
DO STOR(E2,(DATE\1))
+114 IF E3'=""
IF $DATA(@TREF@(E3))
DO STOR(E3,(DATE\1))
End DoDot:3
End DoDot:2
End DoDot:1
+115 ;
+116 ; Check for duplicates
+117 NEW LDTE
+118 SET (CM,DTY,PT)=""
+119 FOR
SET CM=$ORDER(@DATA@(CM))
IF CM=""
QUIT
Begin DoDot:1
+120 FOR
SET PT=$ORDER(@DATA@(CM,PT))
IF PT=""
QUIT
Begin DoDot:2
+121 FOR
SET DTY=$ORDER(@DATA@(CM,PT,DTY))
IF DTY=""
QUIT
Begin DoDot:3
+122 SET DTE=$ORDER(@DATA@(CM,PT,DTY,""),-1)
IF DTE=""
QUIT
+123 SET LDTE=$$FMADD^XLFDT(DTE,-30)
+124 FOR
SET DTE=$ORDER(@DATA@(CM,PT,DTY,DTE),-1)
IF DTE=""
QUIT
Begin DoDot:4
+125 ; Only one suicide type per patient per 30 day period should be included
+126 IF DTE>LDTE
KILL @DATA@(CM,PT,DTY,DTE)
QUIT
+127 SET LDTE=$$FMADD^XLFDT(DTE,-30)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+128 ;
+129 SET CM=""
+130 FOR
SET CM=$ORDER(@DATA@(CM))
IF CM=""
QUIT
Begin DoDot:1
+131 SET PT=""
+132 FOR
SET PT=$ORDER(@DATA@(CM,PT))
IF PT=""
QUIT
Begin DoDot:2
+133 SET DTY=""
+134 FOR
SET DTY=$ORDER(@DATA@(CM,PT,DTY))
IF DTY=""
QUIT
Begin DoDot:3
+135 SET DTE=""
+136 FOR
SET DTE=$ORDER(@DATA@(CM,PT,DTY,DTE))
IF DTE=""
QUIT
Begin DoDot:4
+137 SET DTC=""
+138 FOR
SET DTC=$ORDER(@DATA@(CM,PT,DTY,DTE,DTC))
IF DTC=""
QUIT
Begin DoDot:5
+139 SET VISIT=$PIECE(@DATA@(CM,PT,DTY,DTE,DTC),U,1)
+140 SET FILE=$PIECE(@DATA@(CM,PT,DTY,DTE,DTC),U,3)
+141 DO NFILE(CM,DTY,DTC,DTE,VISIT,PT,FILE)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+142 ;
+143 KILL @TREF,@DATA
+144 QUIT
+145 ;
NFILE(COMM,DCAT,DXC,DATE,VISIT,PT,FILE) ;
+1 ; Input
+2 ; COMM - Community
+3 ; DCAT - Diagnosis Category
+4 ; DXC - Diagnosis Code
+5 ; DATE - Event Date
+6 ; VISIT - Visit to make it unique
+7 ; PT - DFN
+8 ; Assumed that the Alert Type is Suicidal Behavior
+9 NEW DIC,DA,AIEN,CIEN,DIEN,RIEN,NFLG,USR
+10 ; Set the community
+11 SET DIC="^BQI(90507.6,"
SET X="`"_COMM
SET DIC(0)="LMZ"
+12 DO ^DIC
+13 SET CIEN=+Y
+14 IF CIEN=-1
SET (X,DINUM)=COMM
KILL DO,DD
DO FILE^DICN
SET CIEN=+Y
+15 ; Set the Alert Type
+16 SET DA(1)=CIEN
SET X="Suicidal Behavior"
SET DIC="^BQI(90507.6,"_DA(1)_",1,"
SET DIC(0)="LMN"
+17 IF $GET(^BQI(90507.6,DA(1),1,0))=""
SET ^BQI(90507.6,DA(1),1,0)="^90507.61A^^"
+18 DO ^DIC
+19 SET AIEN=+Y
+20 ; Set the DX Category
+21 SET DA(2)=CIEN
SET DA(1)=AIEN
SET X=DCAT
SET DIC(0)="LMN"
+22 SET DIC="^BQI(90507.6,"_DA(2)_",1,"_DA(1)_",1,"
+23 IF $GET(^BQI(90507.6,DA(2),1,DA(1),1,0))=""
SET ^BQI(90507.6,DA(2),1,DA(1),1,0)="^90507.611A^^"
+24 DO ^DIC
+25 SET DIEN=+Y
+26 ; Set the Dx Code
+27 KILL X
+28 ;S DA(3)=CIEN,DA(2)=AIEN,DA(1)=DIEN,X(1)=DXC,X(2)=DATE,X(3)=VISIT,DIC(0)="LN",D="C"
+29 SET DA(3)=CIEN
SET DA(2)=AIEN
SET DA(1)=DIEN
SET X(1)=PT
SET X(2)=DATE
SET X(3)=VISIT
SET DIC(0)="LN"
SET D="D"
+30 SET DIC="^BQI(90507.6,"_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",1,"
+31 IF $GET(^BQI(90507.6,DA(3),1,DA(2),1,DA(1),1,0))=""
SET ^BQI(90507.6,DA(3),1,DA(2),1,DA(1),1,0)="^90507.6111A^^"
+32 DO IX^DIC
+33 IF Y=-1
Begin DoDot:1
+34 KILL X,D
+35 SET X(1)=DXC
SET X(2)=DATE
SET X(3)=VISIT
SET D="C"
+36 DO IX^DIC
End DoDot:1
+37 SET RIEN=+Y
SET NFLG=+$PIECE(Y,U,3)
+38 SET $PIECE(^BQI(90507.6,DA(3),1,DA(2),1,DA(1),1,RIEN,0),U,4)=PT
+39 SET $PIECE(^BQI(90507.6,DA(3),1,DA(2),1,DA(1),1,RIEN,0),U,5)=FILE
+40 IF $DATA(BQIUPD)
DO FILE^DIE("","BQIUPD","ERROR")
+41 NEW DIK
+42 SET DIK=DIC
SET DIK(1)=.04
+43 DO ENALL^DIK
+44 ;
+45 QUIT
+46 ; Set the users
+47 SET USR=0
+48 FOR
SET USR=$ORDER(^BQICARE(USR))
IF 'USR
QUIT
Begin DoDot:1
+49 SET DA(3)=CIEN
SET DA(2)=AIEN
SET DA(1)=DIEN
SET X=USR
SET DIC(0)="LMN"
SET DINUM=X
+50 SET DIC="^BQI(90507.6,"_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",5,"
+51 IF $GET(^BQI(90507.6,DA(3),1,DA(2),1,DA(1),5,0))=""
SET ^BQI(90507.6,DA(3),1,DA(2),1,DA(1),5,0)="^90507.6115PA^^"
+52 KILL DO,DD
DO FILE^DICN
End DoDot:1
+53 QUIT
+54 ;
STOR(TIEN,VSDTM) ;
+1 NEW DFN,COMM,FILE,DIAG
+2 SET DFN=$$GET1^DIQ(9000010.07,IEN,.02,"I")
IF DFN=""
QUIT
+3 SET COMM=$$GET1^DIQ(9000001,DFN_",",1117,"I")
+4 IF COMM=""
SET COMM=$$COMM()
+5 SET DIAG=$PIECE(@TREF@(TIEN),U,1)
SET FILE=9000010
+6 IF '$DATA(@DATA@(COMM,DFN,"Not Categorized",VSDTM))
SET @DATA@(COMM,DFN,"Not Categorized",VSDTM,DIAG)=VISIT_U_U_FILE
QUIT
+7 QUIT
+8 ;
SCD(TAX,ADT) ;EP - Find appropriate code
+1 NEW TREF,BQN,BQCODE
+2 SET TREF="BQITAX"
KILL @TREF
+3 DO BLD^BQITUTL(TAX,.TREF)
+4 IF '$DATA(@TREF)
QUIT ""
+5 SET BQN=""
+6 FOR
SET BQN=$ORDER(@TREF@(BQN))
IF BQN=""
QUIT
Begin DoDot:1
+7 IF $$VERSION^XPDUTL("AICD")<4.0
Begin DoDot:2
+8 IF $PIECE(@TREF@(BQN),U,4)="ICD-9-CM"
SET BQCODE=$PIECE(@TREF@(BQN),U,1)
End DoDot:2
QUIT
+9 IF $$VERSION^XPDUTL("AICD")>3.51
Begin DoDot:2
+10 IF ADT<$$IMP^ICDEXA(30)
Begin DoDot:3
+11 IF $PIECE(@TREF@(BQN),U,4)="ICD-9-CM"
SET BQCODE=$PIECE(@TREF@(BQN),U,1)
End DoDot:3
QUIT
+12 IF $PIECE(@TREF@(BQN),U,4)="ICD-10-CM"
SET BQCODE=$PIECE(@TREF@(BQN),U,1)
End DoDot:2
End DoDot:1
+13 QUIT BQCODE
+14 ;
SNS(BQCID) ;EP - Look by concept ID
+1 SET PIEN=""
+2 FOR
SET PIEN=$ORDER(^AUPNPROB("ASCT",BQCID,PIEN))
IF PIEN=""
QUIT
Begin DoDot:1
+3 IF $GET(^AUPNPROB(PIEN,0))=""
QUIT
+4 SET STAT=$PIECE(^AUPNPROB(PIEN,0),"^",12)
+5 IF STAT="I"!(STAT="D")
QUIT
+6 SET VSDTM=$$PROB^BQIUL1(PIEN)\1
IF VSDTM<STDT
QUIT
+7 SET DTY=$SELECT(BQISUB["IDEATION":"Ideation",BQISUB["ATTEMPT":"Attempt",1:"Completion")
+8 SET DFN=$PIECE(^AUPNPROB(PIEN,0),"^",2)
+9 SET DIAC=BQCID
+10 SET COMM=$$GET1^DIQ(9000001,DFN_",",1117,"I")
+11 IF COMM=""
SET COMM=$$COMM()
+12 IF '$DATA(@DATA@(COMM,DFN,DTY,VSDTM))
SET @DATA@(COMM,DFN,DTY,VSDTM,DIAC)=PIEN_U_U_"9000011"
QUIT
+13 SET @DATA@(COMM,DFN,DTY,VSDTM,BQCID)=PIEN_U_IEN_U_"9000011"
End DoDot:1
+14 ;
+15 SET IEN=""
+16 FOR
SET IEN=$ORDER(^AUPNVPOV("ASCI",BQCID,IEN))
IF IEN=""
QUIT
Begin DoDot:1
+17 ; For each entry CONCEPT ID
+18 ; if a bad record (no zero node), quit
+19 IF $GET(^AUPNVPOV(IEN,0))=""
QUIT
+20 SET VISIT=$PIECE(^AUPNVPOV(IEN,0),"^",3)
SET DFN=$PIECE(^(0),"^",2)
+21 IF VISIT=""
QUIT
+22 SET VSDTM=$PIECE($GET(^AUPNVSIT(VISIT,0)),"^",1)\1
IF VSDTM=0
QUIT
+23 IF VSDTM<STDT
QUIT
+24 SET COMM=$$GET1^DIQ(9000001,DFN_",",1117,"I")
SET FILE="9000010.07"
+25 IF COMM=""
SET COMM=$$COMM()
+26 SET DTY=$SELECT(BQISUB["IDEATION":"Ideation",BQISUB["ATTEMPT":"Attempt",1:"Completion")
+27 SET DIAC=BQCID
+28 IF '$DATA(@DATA@(COMM,DFN,DTY,VSDTM))
SET @DATA@(COMM,DFN,DTY,VSDTM,DIAC)=VISIT_U_U_FILE
QUIT
+29 SET @DATA@(COMM,DFN,DTY,VSDTM,BQCID)=VISIT_U_IEN_U_FILE
End DoDot:1
+30 QUIT
+31 ;
COMM() ;EP - Get UNKNOWN community
+1 SET COMM=$$FIND1^DIC(9999999.05,"","BX","UNKNOWN","","","ERROR")
+2 IF COMM=-1
SET COMM="Not identified"
+3 QUIT COMM
