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

BQIDCAH6.m

Go to the documentation of this file. 
  1. BQIDCAH6 ;GDIT/HS/ALA-Ad Hoc Logic ; 26 Apr 2013  11:00 AM
  1.  ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
  1.  ;
  1. ALGY(FGLOB,TGLOB,BEN,MPARMS) ;EP - Allergy search
  1.  NEW ALGPT,AIEN,ACT,AL,CT,LIEN
  1.  I $G(TGLOB)="" Q
  1.  I $G(ALNAS)'="" D ANAS Q
  1.  I $G(ALNKN)'="" D NKNN Q
  1.  I $G(ALLERGY)]"" D ALGY1
  1.  I $D(MPARMS("ALLERGY")) D
  1.  . I ALLOP="!" D  Q
  1.  .. S ALLERGY="" F  S ALLERGY=$O(MPARMS("ALLERGY",ALLERGY)) Q:ALLERGY=""  D ALGY1
  1.  . I ALLOP="&" D
  1.  .. S ALLERGY="",CT=0
  1.  .. F  S ALLERGY=$O(MPARMS("ALLERGY",ALLERGY)) Q:ALLERGY=""  S CT=CT+1
  1.  .. F  S ALLERGY=$O(MPARMS("ALLERGY",ALLERGY)) Q:ALLERGY=""  D ALGY1
  1.  .. I ALLOP="&" D
  1.  ... S IEN=""
  1.  ... F  S IEN=$O(ALGPT(IEN)) Q:IEN=""  D
  1.  .... S ACT=0,AL=""
  1.  .... F  S AL=$O(ALGPT(IEN,AL)) Q:AL=""  S ACT=ACT+1
  1.  .... I ACT'=CT K @CRIT@("ALGY",IEN) Q
  1.  .... S AL="" F  S AL=$O(ALGPT(IEN,AL)) Q:AL=""  S @TGLOB@(IEN)="",LIEN=ALGPT(IEN,AL),@CRIT@("ALGY",IEN,LIEN)=""
  1.  K ALGPT
  1.  Q
  1.  ;
  1. ALGY1 ;EP
  1.  NEW IEN,ALGTX,AN,DFN,TALLG
  1.  I $G(FGLOB)'="" D  Q
  1.  . S IEN=""
  1.  . F  S IEN=$O(@FGLOB@(IEN)) Q:'IEN  D
  1.  .. S AN=""
  1.  .. F  S AN=$O(^GMR(120.8,"B",IEN,AN)) Q:AN=""  D
  1.  ... ; If ENTERED IN ERROR, ignore
  1.  ... I $$GET1^DIQ(120.8,AN_",",22,"I")=1 Q
  1.  ... S ALGTX=$$GET1^DIQ(120.8,AN_",",.02,"E")
  1.  ... I $E(ALGTX,$L(ALGTX),$L(ALGTX))=" " S ALGTX=$$STRIP^BQIUL1(ALGTX," ")
  1.  ... I ALGTX=ALLERGY D
  1.  .... I ALLOP="!" S @TGLOB@(IEN)="",@CRIT@("ALGY",IEN,AN)=AN Q
  1.  .... S ALGPT(IEN,AN)=AN
  1.  ;
  1.  I $L(ALLERGY)'>30 D
  1.  . NEW ALGTX,TXT
  1.  . S IEN=""
  1.  . F  S IEN=$O(^GMR(120.8,"C",ALLERGY,IEN)) Q:IEN=""  D ALCK
  1.  . S ALGTX=$O(^GMR(120.8,"C",ALLERGY)),TXT=ALLERGY_" "
  1.  . I ALGTX=TXT D
  1.  .. F  S IEN=$O(^GMR(120.8,"C",ALGTX,IEN)) Q:IEN=""  D ALCK
  1.  ;
  1.  I $L(ALLERGY)>30 D
  1.  . S TALLG=ALLERGY
  1.  . F  S TALLG=$O(^GMR(120.8,"C",TALLG)) Q:TALLG=""!($E(ALLERGY,1,30)'=$E(TALLG,1,30))  D
  1.  .. S IEN=""
  1.  .. F  S IEN=$O(^GMR(120.8,"C",TALLG,IEN)) Q:IEN=""  D ALCK
  1.  Q
  1.  ;
  1. ALCK ;EP
  1.  I $$GET1^DIQ(120.8,IEN_",",22,"I")=1 Q
  1.  S DFN=$$GET1^DIQ(120.8,IEN_",",.01,"I")
  1.  I ALLOP="!" S @TGLOB@(DFN)="",@CRIT@("ALGY",DFN,IEN)=IEN Q
  1.  S ALGPT(DFN,IEN)=IEN
  1.  Q
  1.  ;
  1. ANAS ;EP - No allergy assessment
  1.  NEW ADATA,IEN
  1.  I $G(FGLOB)'="" D  Q
  1.  . S IEN=""
  1.  . F  S IEN=$O(@FGLOB@(IEN)) Q:'IEN  D
  1.  .. D DETAIL^BEHOCACV(.ADATA,IEN)
  1.  .. I $G(@ADATA@(1))="No allergy assessment." S @TGLOB@(IEN)=""
  1.  I $G(FGLOB)="" D  Q
  1.  . S IEN=0
  1.  . F  S IEN=$O(^AUPNPAT(IEN)) Q:'IEN  D
  1.  .. I $D(^AUPNPAT(IEN,-9)) Q
  1.  .. D DETAIL^BEHOCACV(.ADATA,IEN)
  1.  .. I $G(@ADATA@(1))="No allergy assessment." S @TGLOB@(IEN)=""
  1.  Q
  1.  ;
  1. NKNN ;EP - No known allergy
  1.  NEW ADATA,IEN
  1.  I $G(FGLOB)'="" D  Q
  1.  . S IEN=""
  1.  . F  S IEN=$O(@FGLOB@(IEN)) Q:'IEN  D
  1.  .. D DETAIL^BEHOCACV(.ADATA,IEN)
  1.  .. I $G(@ADATA@(1))="No known allergies." S @TGLOB@(IEN)=""
  1.  I $G(FGLOB)="" D  Q
  1.  . S IEN=0
  1.  . F  S IEN=$O(^AUPNPAT(IEN)) Q:'IEN  D
  1.  .. I $D(^AUPNPAT(IEN,-9)) Q
  1.  .. D DETAIL^BEHOCACV(.ADATA,IEN)
  1.  .. I $G(@ADATA@(1))="No known allergies." S @TGLOB@(IEN)=""
  1.  Q
  1.  ;
  1. REM(FGLOB,TGLOB,REMCODE,RMFROM,RMTHRU,OVD,FUT,MPARMS) ;EP
  1.  I $G(TGLOB)="" Q
  1.  I $G(REMCODE)'="" D RMD
  1.  I $D(MPARMS("REMCODE")) D
  1.  . S REMCODE=""
  1.  . F  S REMCODE=$O(MPARMS("REMCODE",REMCODE)) Q:REMCODE=""  D RMD
  1.  Q
  1.  ;
  1. RMD ;EP
  1.  NEW IEN
  1.  I $G(FGLOB)'="" D  Q
  1.  . S IEN=""
  1.  . F  S IEN=$O(@FGLOB@(IEN)) Q:'IEN  D RMF(IEN)
  1.  ;
  1.  I $G(FGLOB)="" D
  1.  . S IEN=0
  1.  . F  S IEN=$O(^BQIPAT(IEN)) Q:'IEN  D RMF(IEN)
  1.  Q
  1.  ;
  1. RMF(DFN) ;EP - Find reminder
  1.  NEW RIEN,RDATA
  1.  S RIEN=$O(^BQIPAT(DFN,40,"B",REMCODE,""))
  1.  I RIEN="" Q
  1.  S RDATA=$G(^BQIPAT(DFN,40,RIEN,0)) I RDATA="" Q
  1.  I $P(RDATA,U,3)=""!($P(RDATA,U,3)="N/A")&($P(RDATA,U,4)="") Q
  1.  ;
  1.  I FUT'=0 D  Q
  1.  . I $P(RDATA,U,3)="DUE NOW" Q
  1.  . I $P(RDATA,U,3)="RESOLVED" Q
  1.  . I $P(RDATA,U,3)="DONE" Q
  1.  . I $P(RDATA,U,4)'="" D
  1.  .. I $G(RMFROM)'="" D
  1.  ... I $P(RDATA,U,4)<RMFROM!($P(RDATA,U,4)>RMTHRU) Q
  1.  ... S @TGLOB@(DFN)="",@CRIT@("REM",DFN,REMCODE)=""
  1.  .. I $G(RMFROM)="",$P(RDATA,U,4)>DT S @TGLOB@(DFN)="",@CRIT@("REM",DFN,REMCODE)="" Q
  1.  ;
  1.  I OVD'=0 D  Q
  1.  . I $P(RDATA,U,3)="RESOLVED" Q
  1.  . I $P(RDATA,U,3)="DONE" Q
  1.  . I $P(RDATA,U,4)>DT Q
  1.  . S @TGLOB@(DFN)="",@CRIT@("REM",DFN,REMCODE)=""
  1.  Q
  1.  ;
  1. POVS(FGLOB,TGLOB,POVS,POVSB,FDT,TDT,CNOT,MPARMS) ;EP - POV SNOMED search
  1.  NEW PVPT,PSUB,TREF,NGLOB,LCT,CT,IEN,PVS
  1.  S NGLOB=$NA(^TMP("BQIDCPOVS",$J)) K @NGLOB
  1.  I $G(TGLOB)="" Q
  1.  I $G(POVS)'="" D PVS
  1.  I $G(POVSB)'="" D
  1.  . S TREF=$NA(^TMP("BQISNLST",$J))
  1.  . K @TREF
  1.  . S OK=$$SUBLST^BSTSAPI(TREF,POVSB_"^36^1")
  1.  . S PVS="" F  S PVS=$O(@TREF@(PVS)) Q:PVS=""  S POVS=$P(@TREF@(PVS),"^",1),MPARMS("POVS",POVS)=""
  1.  I PVOP="!" D
  1.  . I $D(MPARMS("POVS")) S POVS="" F  S POVS=$O(MPARMS("POVS",POVS)) Q:POVS=""  D PVS
  1.  I PVOP="&" D
  1.  . K PVPT
  1.  . S POVS="",CT=0 F  S POVS=$O(MPARMS("POVS",POVS)) Q:POVS=""  D PVS S CT=CT+1
  1.  . S IEN=""
  1.  . F  S IEN=$O(PVPT(IEN)) Q:IEN=""  D
  1.  .. S LCT=0,LB=""
  1.  .. F  S LB=$O(PVPT(IEN,LB)) Q:LB=""  S LCT=LCT+1
  1.  .. I LCT'=CT K PVPT(IEN),@CRIT@("POV",IEN) Q
  1.  .. I LCT=CT,'CNOT S @TGLOB@(IEN)="" Q
  1.  .. I LCT=CT,CNOT S @NGLOB@(IEN)="" K @CRIT@("POV",IEN)
  1.  ;
  1.  I CNOT,$G(FGLOB)'="" D
  1.  . S IEN="" F  S IEN=$O(@FGLOB@(IEN)) Q:IEN=""  D
  1.  .. I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
  1.  I CNOT,$G(FGLOB)="" D
  1.  . S IEN=0 F  S IEN=$O(^AUPNPAT(IEN)) Q:'IEN  I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
  1.  K @NGLOB
  1.  Q
  1.  ;
  1. PVS ;
  1.  NEW DFN,IEN
  1.  S TDT=$S(TDT'="":TDT,1:DT)
  1.  I $G(FGLOB)'="" D  Q
  1.  . NEW IEN
  1.  . S IEN=""
  1.  . F  S IEN=$O(@FGLOB@(IEN)) Q:'IEN  D
  1.  .. I FDT="" D
  1.  ... S BDT=""
  1.  ... F  S BDT=$O(^AUPNVPOV("ASNC",IEN,POVS,BDT)) Q:BDT=""  D PVSDT
  1.  .. I FDT'="" D
  1.  ... S BGT=9999999-FDT,ENT=9999999-TDT,BDT=ENT-1
  1.  ... F  S BDT=$O(^AUPNVPOV("ASNC",IEN,POVS,BDT)) Q:BDT=""!(BDT>BGT)  D PVSDT
  1.  ;
  1.  S IEN=""
  1.  F  S IEN=$O(^AUPNVPOV("ASCI",POVS,IEN)) Q:IEN=""  D
  1.  . I $G(^AUPNVPOV(IEN,0))="" Q
  1.  . S DFN=$P($G(^AUPNVPOV(IEN,0)),U,2),VIS=$P(^AUPNVPOV(IEN,0),U,3) I VIS="" Q
  1.  . I $G(^AUPNVSIT(VIS,0))="" Q
  1.  . Q:"DXCT"[$P(^AUPNVSIT(VIS,0),U,7)
  1.  . S VSDTM=$P(^AUPNVSIT(VIS,0),U,1)\1
  1.  . I FDT'="",VSDTM<FDT!(VSDTM>TDT) Q
  1.  . I DFN'="",PVOP="!",'CNOT S @TGLOB@(DFN)="",@CRIT@("POV",DFN,IEN)="" Q
  1.  . I DFN'="",PVOP="!",CNOT S @NGLOB@(DFN)="" Q
  1.  . I DFN'="",PVOP="&" S PVPT(DFN,POV)=IEN,@CRIT@("POV",DFN,IEN)=""
  1.  ;
  1.  Q
  1.  ;
  1. PVSDT ; EP
  1.  S LIEN=""
  1.  F  S LIEN=$O(^AUPNVPOV("ASNC",IEN,POVS,BDT,LIEN)) Q:LIEN=""  D
  1.  . I $P($G(^AUPNVPOV(LIEN,11)),U,1)'=POVS Q
  1.  . S VIS=$P($G(^AUPNVPOV(LIEN,0)),U,3) I VIS="" Q
  1.  . I $G(^AUPNVSIT(VIS,0))="" Q
  1.  . Q:"DXCT"[$P(^AUPNVSIT(VIS,0),U,7)
  1.  . I PVOP="!",'CNOT S @TGLOB@(IEN)=LIEN,@CRIT@("POV",IEN,LIEN)="" Q
  1.  . I PVOP="!",CNOT S @NGLOB@(IEN)="" Q
  1.  . I PVOP="&" S PVPT(IEN,POV)=LIEN,@CRIT@("POV",DFN,IEN)=""
  1.  Q
  1.  ;
  1. POV(FGLOB,TGLOB,POV,POVTX,FDT,TDT,CNOT,MPARMS) ;EP - POV search
  1.  NEW PVPT,PTAX,TREF,NGLOB,LCT,CT,IEN
  1.  S NGLOB=$NA(^TMP("BQIDCPOV",$J)) K @NGLOB
  1.  I $G(TGLOB)="" Q
  1.  I $G(POV)'="" D PV
  1.  I $G(POVTX)'="" D
  1.  . S TREF=$NA(MPARMS("POV"))
  1.  . K @TREF
  1.  . S PTAX=$P(@("^"_$P(POVTX,";",2)_$P(POVTX,";",1)_",0)"),"^",1)
  1.  . D BLD^BQITUTL(PTAX,TREF)
  1.  I PVOP="!" D
  1.  . I $D(MPARMS("POV")) S POV="" F  S POV=$O(MPARMS("POV",POV)) Q:POV=""  D PV
  1.  I PVOP="&" D
  1.  . K PVPT
  1.  . S POV="",CT=0 F  S POV=$O(MPARMS("POV",POV)) Q:POV=""  D PV S CT=CT+1
  1.  . S IEN=""
  1.  . F  S IEN=$O(PVPT(IEN)) Q:IEN=""  D
  1.  .. S LCT=0,LB=""
  1.  .. F  S LB=$O(PVPT(IEN,LB)) Q:LB=""  S LCT=LCT+1
  1.  .. I LCT'=CT K PVPT(IEN),@CRIT@("POV",IEN) Q
  1.  .. I LCT=CT,'CNOT S @TGLOB@(IEN)="" Q
  1.  .. I LCT=CT,CNOT S @NGLOB@(IEN)="" K @CRIT@("POV",IEN)
  1.  ;
  1.  I CNOT,$G(FGLOB)'="" D
  1.  . S IEN="" F  S IEN=$O(@FGLOB@(IEN)) Q:IEN=""  D
  1.  .. I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
  1.  I CNOT,$G(FGLOB)="" D
  1.  . S IEN=0 F  S IEN=$O(^AUPNPAT(IEN)) Q:'IEN  I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
  1.  K @NGLOB
  1.  Q
  1.  ;
  1. PV ;EP
  1.  NEW DFN,IEN
  1.  S TDT=$S(TDT'="":TDT,1:DT)
  1.  I $G(FGLOB)'="" D  Q
  1.  . NEW IEN
  1.  . S IEN=""
  1.  . F  S IEN=$O(@FGLOB@(IEN)) Q:'IEN  D
  1.  .. I FDT="" D
  1.  ... S BDT=""
  1.  ... F  S BDT=$O(^AUPNVPOV("AA",IEN,BDT)) Q:BDT=""  D PVDT
  1.  .. I FDT'="" D
  1.  ... S BGT=9999999-FDT,ENT=9999999-TDT,BDT=ENT-1
  1.  ... F  S BDT=$O(^AUPNVPOV("AA",IEN,BDT)) Q:BDT=""!(BDT>BGT)  D PVDT
  1.  ;
  1.  S IEN=""
  1.  F  S IEN=$O(^AUPNVPOV("B",POV,IEN)) Q:IEN=""  D
  1.  . I $G(^AUPNVPOV(IEN,0))="" Q
  1.  . S DFN=$P($G(^AUPNVPOV(IEN,0)),U,2),VIS=$P(^AUPNVPOV(IEN,0),U,3) I VIS="" Q
  1.  . I $G(^AUPNVSIT(VIS,0))="" Q
  1.  . Q:"DXCT"[$P(^AUPNVSIT(VIS,0),U,7)
  1.  . S VSDTM=$P(^AUPNVSIT(VIS,0),U,1)\1
  1.  . I FDT'="",VSDTM<FDT!(VSDTM>TDT) Q
  1.  . I DFN'="",PVOP="!",'CNOT S @TGLOB@(DFN)="",@CRIT@("POV",DFN,IEN)="" Q
  1.  . I DFN'="",PVOP="!",CNOT S @NGLOB@(DFN)="" Q
  1.  . I DFN'="",PVOP="&" S PVPT(DFN,POV)=IEN,@CRIT@("POV",DFN,IEN)=""
  1.  ;
  1.  Q
  1.  ;
  1. PVDT ;EP
  1.  S LIEN=""
  1.  F  S LIEN=$O(^AUPNVPOV("AA",IEN,BDT,LIEN)) Q:LIEN=""  D
  1.  . I $P($G(^AUPNVPOV(LIEN,0)),U,1)'=POV Q
  1.  . S VIS=$P($G(^AUPNVPOV(LIEN,0)),U,3) I VIS="" Q
  1.  . I $G(^AUPNVSIT(VIS,0))="" Q
  1.  . Q:"DXCT"[$P(^AUPNVSIT(VIS,0),U,7)
  1.  . I PVOP="!",'CNOT S @TGLOB@(IEN)=LIEN,@CRIT@("POV",IEN,LIEN)="" Q
  1.  . I PVOP="!",CNOT S @NGLOB@(IEN)="" Q
  1.  . I PVOP="&" S PVPT(IEN,POV)=LIEN,@CRIT@("POV",DFN,IEN)=""
  1.  Q