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

BQICASUI.m

Go to the documentation of this file. 
  1. BQICASUI ;PRXM/HC/ALA-Find Community Suicides ; 11 Oct 2007  2:10 PM
  1.  ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
  1.  ;
  1. FND ; EP - Find Suicides
  1.  NEW DATA,ENDT,STDT,DATE,VC,VCIEN,VCODE,RIEN,IEN,CIEN,CM,COMM,DFN,DIEN
  1.  NEW DTC,DTE,DTY,E1,E2,E3,PT,SIEN,TAX,TIEN,TREF,VISIT,VSDTM,X,XIEN,Y
  1.  NEW FILE
  1.  ;
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  ; Set the alert temporary global
  1.  S DATA=$NA(^TMP("BQISUICTMP",UID))
  1.  K @DATA
  1.  ;
  1.  NEW DA,IENS,BQIH,BQI,TMFRAME,ENDT,DATE,STDT,VC,VCODE,RIEN,IEN,VCIEN
  1.  NEW DFN,COMM,TREF,VISIT,VSDTM,DTY,E1,E2,E3,CM,PT
  1.  S BQIH=$$SPM^BQIGPUTL()
  1.  S BQI=$O(^BQI(90508,BQIH,15,"B","Suicidal Behavior",""))
  1.  S DA(1)=BQIH,DA=BQI,IENS=$$IENS^DILF(.DA)
  1.  S TMFRAME=$$GET1^DIQ(90508.015,IENS,.03,"E") S:TMFRAME="" TMFRAME=30
  1.  S TMFRAME="T-"_TMFRAME
  1.  S ENDT=DT,STDT=$$DATE^BQIUL1(TMFRAME),DATE=STDT_".24"
  1.  ;
  1.  ; Set up the visit codes
  1.  F VC=39,40,41 S VCIEN=$O(^AMHPROB("B",VC,"")) Q:VCIEN=""  D
  1.  . S VCODE(VCIEN)=$P(^AMHPROB(VCIEN,0),U,5)
  1.  . S:VC=39 $P(VCODE(VCIEN),U,2)="Ideation"
  1.  . S:VC=40 $P(VCODE(VCIEN),U,2)="Attempt"
  1.  . S:VC=41 $P(VCODE(VCIEN),U,2)="Completion"
  1.  ;
  1.  ; Check in the MHSS files
  1.  F  S DATE=$O(^AMHREC("B",DATE)) Q:DATE=""!(DATE\1>ENDT)  D
  1.  . S RIEN=""
  1.  . F  S RIEN=$O(^AMHREC("B",DATE,RIEN)) Q:RIEN=""  D
  1.  .. S IEN=""
  1.  .. F  S IEN=$O(^AMHRPRO("AD",RIEN,IEN),-1) Q:IEN=""  D
  1.  ... S VCIEN=$P(^AMHRPRO(IEN,0),U,1)
  1.  ... I '$D(VCODE(VCIEN)) Q
  1.  ... S DFN=$P(^AMHRPRO(IEN,0),U,2) I DFN="" S DFN="Not identified"
  1.  ... S FILE=9002011.01
  1.  ... S COMM=$$GET1^DIQ(9000001,DFN_",",1117,"I")
  1.  ... I COMM="" S COMM=$$COMM()
  1.  ... S @DATA@(COMM,DFN,$P(VCODE(VCIEN),U,2),DATE\1,$P(VCODE(VCIEN),U,1))=RIEN_U_IEN_U_FILE_U
  1.  ;
  1.  ; Check for a Suicide Form
  1.  NEW DTACT,RIEN,STY,TYPE,FILE,DFN,COMM,ICD
  1.  S DTACT=$$DATE^BQIUL1("T-30"),DTACT=DTACT-.001
  1.  F  S DTACT=$O(^AMHPSUIC("AD",DTACT)) Q:DTACT=""  D
  1.  . S RIEN=""
  1.  . F  S RIEN=$O(^AMHPSUIC("AD",DTACT,RIEN)) Q:RIEN=""  D
  1.  .. S FILE=9002011.65
  1.  .. S DFN=$P(^AMHPSUIC(RIEN,0),U,4),TYPE=$$GET1^DIQ(9002011.65,RIEN_",",.13,"I")
  1.  .. I TYPE="" Q
  1.  .. S STY=$S(TYPE=1:"Ideation",TYPE=2!(TYPE=4)!(TYPE=6)!(TYPE=7):"Attempt",1:"Completion")
  1.  .. D
  1.  ... I STY="Ideation" S ICD=$$SCD("BGP SUICIDAL IDEATION DXS",DTACT) Q
  1.  ... I STY="Attempt" S ICD=$$SCD("BQI SUICIDE ATTEMPT DXS",DTACT) Q
  1.  ... ;S ICD=$$SCD("BQI SUICIDE COMPLETION DXS",DTACT)
  1.  .. I $G(ICD)="" S ICD="Not specified"
  1.  .. S COMM=$$GET1^DIQ(9000001,DFN_",",1117,"I")
  1.  .. I COMM="" S COMM=$$COMM()
  1.  .. S @DATA@(COMM,DFN,STY,DTACT\1,ICD)=RIEN_U_U_FILE
  1.  ;
  1.  ; Check SNOMED in Problem file and V POV
  1.  F BQISUB="PXRM BQI SUICIDE IDEATION","PXRM BQI SUICIDE ATTEMPT","PXRM BQI SUICIDE COMPLETION" D
  1.  . S TREF=$NA(^TMP("BQISNOM",$J)) K @TREF
  1.  . S BQIOK=$$SUBLST^BSTSAPI(TREF,BQISUB_"^36^1")
  1.  . I 'BQIOK Q
  1.  . S SNIEN=""
  1.  . F  S SNIEN=$O(@TREF@(SNIEN)) Q:SNIEN=""  D
  1.  .. S SCID=$P(@TREF@(SNIEN),U,1)
  1.  .. D SNS(SCID)
  1.  ;
  1.  ; Check in PCC
  1.  F TAX="BGP SUICIDAL IDEATION DXS","BQI SUICIDE ATTEMPT DXS" D
  1.  . NEW DIAC
  1.  . ;D BLDSV^BQITUTL(80,"V62.84 ",TREF)
  1.  . ;D BLDSV^BQITUTL(80,"798.1 ",TREF)
  1.  . S TREF=$NA(^TMP("BQITAX",UID))
  1.  . K @TREF
  1.  . D BLD^BQITUTL(TAX,.TREF)
  1.  . S TIEN=0 F  S TIEN=$O(@TREF@(TIEN)) Q:'TIEN  D
  1.  .. S IEN="",DIAC=$P(@TREF@(TIEN),U,1)
  1.  .. F  S IEN=$O(^AUPNVPOV("B",TIEN,IEN),-1) Q:IEN=""  D
  1.  ... ;  if a bad record (no zero node), quit
  1.  ... I $G(^AUPNVPOV(IEN,0))="" Q
  1.  ... ;  get patient record
  1.  ... S DFN=$$GET1^DIQ(9000010.07,IEN,.02,"I") Q:DFN=""
  1.  ... S VISIT=$$GET1^DIQ(9000010.07,IEN,.03,"I") Q:VISIT=""
  1.  ... ;  if the visit is deleted, quit
  1.  ... I $$GET1^DIQ(9000010,VISIT,.11,"I")=1 Q
  1.  ... S VSDTM=$$GET1^DIQ(9000010,VISIT,.01,"I")\1 Q:VSDTM=0
  1.  ... S COMM=$$GET1^DIQ(9000001,DFN_",",1117,"I")
  1.  ... I COMM="" S COMM=$$COMM()
  1.  ... S FILE=9000010
  1.  ... I $G(TMFRAME)'="",VSDTM'>STDT Q
  1.  ... ;I $G(TMFRAME)'="",VSDTM<STDT Q
  1.  ... S DTY=$S(TAX["IDEATION":"Ideation",TAX["ATTEMPT":"Attempt",1:"Completion")
  1.  ... ;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
  1.  ... I '$D(@DATA@(COMM,DFN,DTY,VSDTM)) S @DATA@(COMM,DFN,DTY,VSDTM,DIAC)=VISIT_U_U_FILE Q
  1.  ; Look for ECODES
  1.  K @TREF
  1.  S TAX="BQI INJ SUICIDE CODES"
  1.  ;I '$D(^ATXAX("B",TAX)) S TAX="APCL INJ SUICIDE"
  1.  D BLD^BQITUTL(TAX,TREF)
  1.  ;S DATE=STDT
  1.  S DATE=STDT_".24"
  1.  F  S DATE=$O(^AUPNVSIT("B",DATE)) Q:DATE=""!(DATE\1>ENDT)  D
  1.  . S VISIT=""
  1.  . F  S VISIT=$O(^AUPNVSIT("B",DATE,VISIT)) Q:VISIT=""  D
  1.  .. S IEN=""
  1.  .. F  S IEN=$O(^AUPNVPOV("AD",VISIT,IEN)) Q:IEN=""  D
  1.  ... S E1=$P(^AUPNVPOV(IEN,0),U,9)
  1.  ... S E2=$P(^AUPNVPOV(IEN,0),U,18)
  1.  ... S E3=$P(^AUPNVPOV(IEN,0),U,19)
  1.  ... I E1="",E2="",E3="" Q
  1.  ... I E1'="",$D(@TREF@(E1)) D STOR(E1,(DATE\1))
  1.  ... I E2'="",$D(@TREF@(E2)) D STOR(E2,(DATE\1))
  1.  ... I E3'="",$D(@TREF@(E3)) D STOR(E3,(DATE\1))
  1.  ;
  1.  ; Check for duplicates
  1.  NEW LDTE
  1.  S (CM,DTY,PT)=""
  1.  F  S CM=$O(@DATA@(CM)) Q:CM=""  D
  1.  . F  S PT=$O(@DATA@(CM,PT)) Q:PT=""  D
  1.  .. F  S DTY=$O(@DATA@(CM,PT,DTY)) Q:DTY=""  D
  1.  ... S DTE=$O(@DATA@(CM,PT,DTY,""),-1) Q:DTE=""
  1.  ... S LDTE=$$FMADD^XLFDT(DTE,-30)
  1.  ... F  S DTE=$O(@DATA@(CM,PT,DTY,DTE),-1) Q:DTE=""  D
  1.  .... ; Only one suicide type per patient per 30 day period should be included
  1.  .... I DTE>LDTE K @DATA@(CM,PT,DTY,DTE) Q
  1.  .... S LDTE=$$FMADD^XLFDT(DTE,-30)
  1.  ;
  1.  S CM=""
  1.  F  S CM=$O(@DATA@(CM)) Q:CM=""  D
  1.  . S PT=""
  1.  . F  S PT=$O(@DATA@(CM,PT)) Q:PT=""  D
  1.  .. S DTY=""
  1.  .. F  S DTY=$O(@DATA@(CM,PT,DTY)) Q:DTY=""  D
  1.  ... S DTE=""
  1.  ... F  S DTE=$O(@DATA@(CM,PT,DTY,DTE)) Q:DTE=""  D
  1.  .... S DTC=""
  1.  .... F  S DTC=$O(@DATA@(CM,PT,DTY,DTE,DTC)) Q:DTC=""  D
  1.  ..... S VISIT=$P(@DATA@(CM,PT,DTY,DTE,DTC),U,1)
  1.  ..... S FILE=$P(@DATA@(CM,PT,DTY,DTE,DTC),U,3)
  1.  ..... D NFILE(CM,DTY,DTC,DTE,VISIT,PT,FILE)
  1.  ;
  1.  K @TREF,@DATA
  1.  Q
  1.  ;
  1. NFILE(COMM,DCAT,DXC,DATE,VISIT,PT,FILE) ;
  1.  ; Input
  1.  ;   COMM  - Community
  1.  ;   DCAT  - Diagnosis Category
  1.  ;   DXC   - Diagnosis Code
  1.  ;   DATE  - Event Date
  1.  ;   VISIT - Visit to make it unique
  1.  ;   PT    - DFN
  1.  ; Assumed that the Alert Type is Suicidal Behavior
  1.  NEW DIC,DA,AIEN,CIEN,DIEN,RIEN,NFLG,USR
  1.  ;  Set the community
  1.  S DIC="^BQI(90507.6,",X="`"_COMM,DIC(0)="LMZ"
  1.  D ^DIC
  1.  S CIEN=+Y
  1.  I CIEN=-1 S (X,DINUM)=COMM K DO,DD D FILE^DICN S CIEN=+Y
  1.  ;  Set the Alert Type
  1.  S DA(1)=CIEN,X="Suicidal Behavior",DIC="^BQI(90507.6,"_DA(1)_",1,",DIC(0)="LMN"
  1.  I $G(^BQI(90507.6,DA(1),1,0))="" S ^BQI(90507.6,DA(1),1,0)="^90507.61A^^"
  1.  D ^DIC
  1.  S AIEN=+Y
  1.  ;  Set the DX Category
  1.  S DA(2)=CIEN,DA(1)=AIEN,X=DCAT,DIC(0)="LMN"
  1.  S DIC="^BQI(90507.6,"_DA(2)_",1,"_DA(1)_",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^^"
  1.  D ^DIC
  1.  S DIEN=+Y
  1.  ;  Set the Dx Code
  1.  K X
  1.  ;S DA(3)=CIEN,DA(2)=AIEN,DA(1)=DIEN,X(1)=DXC,X(2)=DATE,X(3)=VISIT,DIC(0)="LN",D="C"
  1.  S DA(3)=CIEN,DA(2)=AIEN,DA(1)=DIEN,X(1)=PT,X(2)=DATE,X(3)=VISIT,DIC(0)="LN",D="D"
  1.  S DIC="^BQI(90507.6,"_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",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^^"
  1.  D IX^DIC
  1.  I Y=-1 D
  1.  . K X,D
  1.  . S X(1)=DXC,X(2)=DATE,X(3)=VISIT,D="C"
  1.  . D IX^DIC
  1.  S RIEN=+Y,NFLG=+$P(Y,U,3)
  1.  S $P(^BQI(90507.6,DA(3),1,DA(2),1,DA(1),1,RIEN,0),U,4)=PT
  1.  S $P(^BQI(90507.6,DA(3),1,DA(2),1,DA(1),1,RIEN,0),U,5)=FILE
  1.  I $D(BQIUPD) D FILE^DIE("","BQIUPD","ERROR")
  1.  NEW DIK
  1.  S DIK=DIC,DIK(1)=.04
  1.  D ENALL^DIK
  1.  ;
  1.  Q
  1.  ;  Set the users
  1.  S USR=0
  1.  F  S USR=$O(^BQICARE(USR)) Q:'USR  D
  1.  . S DA(3)=CIEN,DA(2)=AIEN,DA(1)=DIEN,X=USR,DIC(0)="LMN",DINUM=X
  1.  . S DIC="^BQI(90507.6,"_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",5,"
  1.  . 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^^"
  1.  . K DO,DD D FILE^DICN
  1.  Q
  1.  ;
  1. STOR(TIEN,VSDTM) ;
  1.  NEW DFN,COMM,FILE,DIAG
  1.  S DFN=$$GET1^DIQ(9000010.07,IEN,.02,"I") Q:DFN=""
  1.  S COMM=$$GET1^DIQ(9000001,DFN_",",1117,"I")
  1.  I COMM="" S COMM=$$COMM()
  1.  S DIAG=$P(@TREF@(TIEN),U,1),FILE=9000010
  1.  I '$D(@DATA@(COMM,DFN,"Not Categorized",VSDTM)) S @DATA@(COMM,DFN,"Not Categorized",VSDTM,DIAG)=VISIT_U_U_FILE Q
  1.  Q
  1.  ;
  1. SCD(TAX,ADT) ;EP - Find appropriate code
  1.  NEW TREF,BQN,BQCODE
  1.  S TREF="BQITAX" K @TREF
  1.  D BLD^BQITUTL(TAX,.TREF)
  1.  I '$D(@TREF) Q ""
  1.  S BQN=""
  1.  F  S BQN=$O(@TREF@(BQN)) Q:BQN=""  D
  1.  . I $$VERSION^XPDUTL("AICD")<4.0 D  Q
  1.  .. I $P(@TREF@(BQN),U,4)="ICD-9-CM" S BQCODE=$P(@TREF@(BQN),U,1)
  1.  . I $$VERSION^XPDUTL("AICD")>3.51 D
  1.  .. I ADT<$$IMP^ICDEXA(30) D  Q
  1.  ... I $P(@TREF@(BQN),U,4)="ICD-9-CM" S BQCODE=$P(@TREF@(BQN),U,1)
  1.  .. I $P(@TREF@(BQN),U,4)="ICD-10-CM" S BQCODE=$P(@TREF@(BQN),U,1)
  1.  Q BQCODE
  1.  ;
  1. SNS(BQCID) ;EP - Look by concept ID
  1.  S PIEN=""
  1.  F  S PIEN=$O(^AUPNPROB("ASCT",BQCID,PIEN)) Q:PIEN=""  D
  1.  . I $G(^AUPNPROB(PIEN,0))="" Q
  1.  . S STAT=$P(^AUPNPROB(PIEN,0),"^",12)
  1.  . I STAT="I"!(STAT="D") Q
  1.  . S VSDTM=$$PROB^BQIUL1(PIEN)\1 I VSDTM<STDT Q
  1.  . S DTY=$S(BQISUB["IDEATION":"Ideation",BQISUB["ATTEMPT":"Attempt",1:"Completion")
  1.  . S DFN=$P(^AUPNPROB(PIEN,0),"^",2)
  1.  . S DIAC=BQCID
  1.  . S COMM=$$GET1^DIQ(9000001,DFN_",",1117,"I")
  1.  . I COMM="" S COMM=$$COMM()
  1.  . I '$D(@DATA@(COMM,DFN,DTY,VSDTM)) S @DATA@(COMM,DFN,DTY,VSDTM,DIAC)=PIEN_U_U_"9000011" Q
  1.  . S @DATA@(COMM,DFN,DTY,VSDTM,BQCID)=PIEN_U_IEN_U_"9000011"
  1.  ;
  1.  S IEN=""
  1.  F  S IEN=$O(^AUPNVPOV("ASCI",BQCID,IEN)) Q:IEN=""  D
  1.  . ;  For each entry CONCEPT ID
  1.  . ;  if a bad record (no zero node), quit
  1.  . I $G(^AUPNVPOV(IEN,0))="" Q
  1.  . S VISIT=$P(^AUPNVPOV(IEN,0),"^",3),DFN=$P(^(0),"^",2)
  1.  . I VISIT="" Q
  1.  . S VSDTM=$P($G(^AUPNVSIT(VISIT,0)),"^",1)\1 I VSDTM=0 Q
  1.  . I VSDTM<STDT Q
  1.  . S COMM=$$GET1^DIQ(9000001,DFN_",",1117,"I"),FILE="9000010.07"
  1.  . I COMM="" S COMM=$$COMM()
  1.  . S DTY=$S(BQISUB["IDEATION":"Ideation",BQISUB["ATTEMPT":"Attempt",1:"Completion")
  1.  . S DIAC=BQCID
  1.  . I '$D(@DATA@(COMM,DFN,DTY,VSDTM)) S @DATA@(COMM,DFN,DTY,VSDTM,DIAC)=VISIT_U_U_FILE Q
  1.  . S @DATA@(COMM,DFN,DTY,VSDTM,BQCID)=VISIT_U_IEN_U_FILE
  1.  Q
  1.  ;
  1. COMM() ;EP - Get UNKNOWN community
  1.  S COMM=$$FIND1^DIC(9999999.05,"","BX","UNKNOWN","","","ERROR")
  1.  I COMM=-1 S COMM="Not identified"
  1.  Q COMM