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

BQIDCAH4.m

Go to the documentation of this file. 
  1. BQIDCAH4 ;GDIT/HS/ALA-Ad Hoc continued ; 10 Dec 2012  3:23 PM
  1.  ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
  1.  ;
  1. PROB(FGLOB,TGLOB,PROB,PROBTX,FDT,TDT,MPARMS) ;EP - Problems
  1.  NEW PRPT,CT,IEN,PB,PCT,PTAX,TREF
  1.  I $G(PROBTX)'="" D
  1.  . S TREF=$NA(MPARMS("PROB"))
  1.  . K @TREF
  1.  . S PTAX=$P(@("^"_$P(PROBTX,";",2)_$P(PROBTX,";",1)_",0)"),"^",1)
  1.  . D BLD^BQITUTL(PTAX,TREF)
  1.  ;
  1.  I PROP="!" D
  1.  . I $D(MPARMS("PROB")) S PROB="" F  S PROB=$O(MPARMS("PROB",PROB)) Q:PROB=""  D PRBB
  1.  . I '$D(MPARMS("PROB")) D PRBB
  1.  I PROP="&" D
  1.  . K PRPT
  1.  . S PROB="",CT=0 F  S PROB=$O(MPARMS("PROB",PROB)) Q:PROB=""  D PRBB S CT=CT+1
  1.  . S IEN=""
  1.  . F  S IEN=$O(PRPT(IEN)) Q:IEN=""  D
  1.  .. S PCT=0,PB=""
  1.  .. F  S PB=$O(PRPT(IEN,PB)) Q:PB=""  S PCT=PCT+1
  1.  .. I PCT=CT S @TGLOB@(IEN)="" D  Q
  1.  ... F  S PB=$O(PRPT(IEN,PB)) Q:PB=""  S PIEN=PRPT(IEN,PB),@CRIT@("PROB",IEN,PIEN)=""
  1.  ;
  1.  Q
  1.  ;
  1. PRBB ; Problem
  1.  NEW DFN,IEN
  1.  S TDT=$S(TDT'="":TDT,1:DT)
  1.  ; If 'from' data global is populated, use those entries to filter by
  1.  I $G(FGLOB)'="" D  Q
  1.  . NEW IEN,PIEN,PB,STAT,VSDTM
  1.  . S IEN=""
  1.  . F  S IEN=$O(@FGLOB@(IEN)) Q:'IEN  D
  1.  .. I $O(^AUPNPROB("AC",IEN,""))="" Q
  1.  .. S PIEN=""
  1.  .. F  S PIEN=$O(^AUPNPROB("AC",IEN,PIEN)) Q:PIEN=""  D
  1.  ... S PB=$P(^AUPNPROB(PIEN,0),U,1)
  1.  ... I $D(MPARMS("PROB")),'$D(MPARMS("PROB",PB)) Q
  1.  ... I '$D(MPARMS("PROB")),PB'=PROB Q
  1.  ... S STAT=$P(^AUPNPROB(PIEN,0),U,12)
  1.  ... I PRSTAT'="",STAT'=PRSTAT Q
  1.  ... I $D(MPARMS("PRSTAT")),'$D(MPARMS("PRSTAT",STAT)) Q
  1.  ... S VSDTM=$$PROB^BQIUL1(PIEN)
  1.  ... I FDT'="",VSDTM<FDT!(VSDTM>TDT) Q
  1.  ... I PROP="!" S @TGLOB@(IEN)="",@CRIT@("PROB",IEN,PIEN)="" Q
  1.  ... I PROP="&" S PRPT(IEN,PROB)=PIEN
  1.  ;
  1.  ; if no additional entries to filter by, build list by problem only to filter on
  1.  NEW IEN,DFN,VSDTM,STAT
  1.  S IEN=""
  1.  F  S IEN=$O(^AUPNPROB("B",PROB,IEN)) Q:IEN=""  D
  1.  . S DFN=$P($G(^AUPNPROB(IEN,0)),U,2)
  1.  . S VSDTM=$$PROB^BQIUL1(IEN)
  1.  . I FDT'="",VSDTM<FDT!(VSDTM>TDT) Q
  1.  . S STAT=$P(^AUPNPROB(IEN,0),U,12)
  1.  . I PRSTAT'="",STAT'=PRSTAT Q
  1.  . I $D(MPARMS("PRSTAT")),'$D(MPARMS("PRSTAT",STAT)) Q
  1.  . I DFN'="",PROP="!" S @TGLOB@(DFN)="",@CRIT@("PROB",DFN,IEN)="" Q
  1.  . I DFN'="",PROP="&" S PRPT(DFN,PROB)=IEN
  1.  ;
  1.  Q
  1.  ;
  1. NRV(FGLOB,TGLOB,FDT,TDT) ;EP - problems not reviewed
  1.  NEW DFN,BGT,EDT,OK
  1.  I $G(FGLOB)="" D
  1.  . S DFN=0
  1.  . F  S DFN=$O(^AUPNPAT(DFN)) Q:'DFN  D
  1.  .. I $G(^AUPNPAT(DFN,0))="" Q
  1.  .. I '$D(^AUPNVRUP("AA",DFN,1)) S @TGLOB@(DFN)="" Q
  1.  .. S OK=0
  1.  .. I FDT'="" D  Q
  1.  ... S BGT=(9999999-TDT)-.0001,EDT=9999999-FDT
  1.  ... F  S BGT=$O(^AUPNVRUP("AA",DFN,1,BGT)) Q:BGT=""!(BGT\1>EDT)  S OK=1
  1.  .. I 'OK S @TGLOB@(DFN)=""
  1.  ;
  1.  I $G(FGLOB)'="" D
  1.  . S DFN=""
  1.  . F  S DFN=$O(@FGLOB@(DFN)) Q:DFN=""  D
  1.  .. I '$D(^AUPNVRUP("AA",DFN,1)) S @TGLOB@(DFN)="" Q
  1.  .. S OK=0
  1.  .. I FDT'="" D
  1.  ... S BGT=(9999999-TDT)-.0001,EDT=9999999-FDT
  1.  ... F  S BGT=$O(^AUPNVRUP("AA",DFN,1,BGT)) Q:BGT=""!(BGT\1>EDT)  S OK=1
  1.  .. I 'OK S @TGLOB@(DFN)=""
  1.  Q
  1.  ;
  1. VCHK ;EP
  1.  I '$D(^AUPNVRUP("AC",DFN)) S @TGLOB@(DFN)="" Q
  1.  I '$D(^AUPNVRUP("AA",DFN,1)) S @TGLOB@(DFN)=""
  1.  Q
  1.  ;
  1. NAC(FGLOB,TGLOB,FDT,TDT) ;EP - No active problems
  1.  NEW DFN
  1.  I $G(FGLOB)="" D
  1.  . S DFN=0
  1.  . F  S DFN=$O(^AUPNPAT(DFN)) Q:'DFN  D
  1.  .. I $G(^AUPNPAT(DFN,0))="" Q
  1.  .. I $D(^AUPNVRUP("AA",DFN,3)) D
  1.  ... I FDT'="" D  Q
  1.  .... S BGT=(9999999-TDT)-.0001,EDT=9999999-FDT
  1.  .... F  S BGT=$O(^AUPNVRUP("AA",DFN,3,BGT)) Q:BGT=""!(BGT\1>EDT)  S @TGLOB@(DFN)=""
  1.  ... S @TGLOB@(DFN)=""
  1.  ;
  1.  I $G(FGLOB)'="" D
  1.  . S DFN=""
  1.  . F  S DFN=$O(@FGLOB@(DFN)) Q:DFN=""  D
  1.  .. I $D(^AUPNVRUP("AA",DFN,3)) D
  1.  ... I FDT'="" D  Q
  1.  .... S BGT=(9999999-TDT)-.0001,EDT=9999999-FDT
  1.  .... F  S BGT=$O(^AUPNVRUP("AA",DFN,3,BGT)) Q:BGT=""!(BGT\1>EDT)  S @TGLOB@(DFN)=""
  1.  ... S @TGLOB@(DFN)=""
  1.  Q
  1.  ;
  1. NDC(FGLOB,TGLOB) ;EP - No documented problems
  1.  NEW DFN
  1.  I $G(FGLOB)="" D
  1.  . S DFN=0
  1.  . F  S DFN=$O(^AUPNPAT(DFN)) Q:'DFN  D
  1.  .. I $G(^AUPNPAT(DFN,0))="" Q
  1.  .. I '$D(^AUPNPROB("AC",DFN)) S @TGLOB@(DFN)=""
  1.  I $G(FGLOB)'="" D
  1.  . S DFN=""
  1.  . F  S DFN=$O(@FGLOB@(DFN)) Q:DFN=""  D
  1.  .. I '$D(^AUPNPROB("AC",DFN)) S @TGLOB@(DFN)=""
  1.  Q
  1.  ;
  1. MND(FGLOB,TGLOB) ;EP - No documented medications
  1.  NEW DFN
  1.  I $G(FGLOB)="" D
  1.  . S DFN=0
  1.  . F  S DFN=$O(^AUPNPAT(DFN)) Q:'DFN  D
  1.  .. I $G(^AUPNPAT(DFN,0))="" Q
  1.  .. I '$D(^AUPNVMED("AC",DFN)) S @TGLOB@(DFN)=""
  1.  I $G(FGLOB)'="" D
  1.  . S DFN=""
  1.  . F  S DFN=$O(@FGLOB@(DFN)) Q:DFN=""  D
  1.  .. I '$D(^AUPNVMED("AC",DFN)) S @TGLOB@(DFN)=""
  1.  Q
  1.  ;
  1. NAM(FGLOB,TGLOB,FDT,TDT) ;EP - no active medications
  1.  NEW DFN
  1.  I $G(FGLOB)="" D
  1.  . S DFN=0
  1.  . F  S DFN=$O(^AUPNPAT(DFN)) Q:'DFN  D
  1.  .. I $G(^AUPNPAT(DFN,0))="" Q
  1.  .. I $D(^AUPNVRUP("AA",DFN,7)) D
  1.  ... I FDT'="" D  Q
  1.  .... S BGT=(9999999-TDT)-.0001,EDT=9999999-FDT
  1.  .... F  S BGT=$O(^AUPNVRUP("AA",DFN,7,BGT)) Q:BGT=""!(BGT\1>EDT)  S @TGLOB@(DFN)=""
  1.  ... S @TGLOB@(DFN)=""
  1.  ;
  1.  I $G(FGLOB)'="" D
  1.  . S DFN=""
  1.  . F  S DFN=$O(@FGLOB@(DFN)) Q:DFN=""  D
  1.  .. I $D(^AUPNVRUP("AA",DFN,7)) D
  1.  ... I FDT'="" D  Q
  1.  .... S BGT=(9999999-TDT)-.0001,EDT=9999999-FDT
  1.  .... F  S BGT=$O(^AUPNVRUP("AA",DFN,7,BGT)) Q:BGT=""!(BGT\1>EDT)  S @TGLOB@(DFN)=""
  1.  ... S @TGLOB@(DFN)=""
  1.  Q
  1.  ;
  1. MLR(FGLOB,TGLOB,FDT,TDT) ;EP - medications not reviewed
  1.  NEW DFN,BGT,EDT,OK
  1.  I $G(FGLOB)="" D
  1.  . S DFN=0
  1.  . F  S DFN=$O(^AUPNPAT(DFN)) Q:'DFN  D
  1.  .. I $G(^AUPNPAT(DFN,0))="" Q
  1.  .. I '$D(^AUPNVRUP("AA",DFN,5)) S @TGLOB@(DFN)="" Q
  1.  .. S OK=0
  1.  .. I FDT'="" D  Q
  1.  ... S BGT=(9999999-TDT)-.0001,EDT=9999999-FDT
  1.  ... F  S BGT=$O(^AUPNVRUP("AA",DFN,5,BGT)) Q:BGT=""!(BGT\1>EDT)  S OK=1
  1.  .. I 'OK S @TGLOB@(DFN)=""
  1.  ;
  1.  I $G(FGLOB)'="" D
  1.  . S DFN=""
  1.  . F  S DFN=$O(@FGLOB@(DFN)) Q:DFN=""  D
  1.  .. I '$D(^AUPNVRUP("AA",DFN,5)) S @TGLOB@(DFN)="" Q
  1.  .. S OK=0
  1.  .. I FDT'="" D
  1.  ... S BGT=(9999999-TDT)-.0001,EDT=9999999-FDT
  1.  ... F  S BGT=$O(^AUPNVRUP("AA",DFN,5,BGT)) Q:BGT=""!(BGT\1>EDT)  S OK=1
  1.  .. I 'OK S @TGLOB@(DFN)=""
  1.  Q
  1.  ;
  1. EMP(FGLOB,TGLOB,EMPL,MPARMS) ;EP - Employer search
  1.  I $G(TGLOB)="" Q
  1.  I $G(EMPL)'="" D
  1.  . S EMPL=""
  1.  . F  S EMPL=$O(^BQI(90508,1,18,"B",EMPL)) Q:EMPL=""  D EMD
  1.  Q
  1.  ;
  1. EMD ;EP
  1.  NEW IEN,DFN
  1.  I $G(FGLOB)'="" D
  1.  . S IEN=""
  1.  . F  S IEN=$O(@FGLOB@(IEN)) Q:'IEN  I $P($G(^AUPNPAT(IEN,0)),U,19)=EMPL S @TGLOB@(IEN)=""
  1.  ;
  1.  I $G(FGLOB)="" D
  1.  . S DFN=""
  1.  . F  S DFN=$O(^AUPNPAT("AF",EMPL,DFN)) Q:DFN=""  S @TGLOB@(DFN)=""
  1.  Q
  1.  ;
  1. PNL(FGLOB,TGLOB,PLIDEN,MPARMS) ;EP - Panel search
  1.  I $G(TGLOB)="" Q
  1.  I PLIDEN]"" D PLD
  1.  I $D(MPARMS("PLIDEN")) S PLIDEN="" F  S PLIDEN=$O(MPARMS("PLIDEN",PLIDEN)) Q:PLIDEN=""  D PLD
  1.  Q
  1.  ;
  1. PLD ;EP
  1.  NEW OWNR,PLNME,DA,IENS,PLIEN
  1.  S OWNR=$P(PLIDEN,$C(26),1),PLNME=$P(PLIDEN,$C(26),2)
  1.  S DA="",DA(1)=OWNR,IENS=$$IENS^DILF(.DA)
  1.  S PLIEN=$$FIND1^DIC(90505.01,IENS,"X",PLNME,"","","ERROR")
  1.  I PLIEN="" Q
  1.  I $G(FGLOB)'="" D
  1.  . S IEN=""
  1.  . F  S IEN=$O(@FGLOB@(IEN)) Q:'IEN  D
  1.  .. I $D(^BQICARE(OWNR,1,PLIEN,40,IEN)),$P(^BQICARE(OWNR,1,PLIEN,40,IEN,0),U,2)'="R" S @TGLOB@(IEN)=""
  1.  ;
  1.  NEW DFN,IEN
  1.  I $G(FGLOB)="" D
  1.  . S DFN=0
  1.  . F  S DFN=$O(^BQICARE(OWNR,1,PLIEN,40,DFN)) Q:'DFN  D
  1.  .. I $P(^BQICARE(OWNR,1,PLIEN,40,DFN,0),U,2)="R" Q
  1.  .. S @TGLOB@(DFN)=""
  1.  Q