BQIDCAH ;PRXM/HC/ALA-Ad Hoc Search ; 16 Nov 2005 6:26 PM
;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
;
Q
;
PARMS(DATA,CDATA,FGLOB,PARMS,MPARMS,APARMS,MAPARMS) ;EP - Execute Ad Hoc Search
;
;Description
; Ad Hoc Search which can be an assortment of parameters including;
; GENDER, COMMUNITY, PROVIDER, VISIT DATES, AGE
;Input
; FGLOB = From global (only sent for filters)
; PARMS = Array of parameters and their values
; MPARMS = Multiple array of a parameter
;Expected to return DATA
;
NEW JJ,KK,UID,TGLOB,SEX,COMM,PROV,FROM,THRU,AGE,CRIT1,MRANGE,MRFROM,MRTHRU
NEW CRIT2,NM,DXCAT,PLIDEN,NUMVIS,COMMTX,BEN,VDATA,VNDATA,VODATA,EMPL,VISOP
NEW CLIN,DXOP,RANGE,RFROM,RTHRU,DEC,DECCOD,BNEW,VCRIT1,VCRIT2,DECFDT,DECTDT
NEW ALLERGY,ALLOP,LFROM,LTHRU,LRANGE,LRFROM,LRTHRU,LAB,MED,MFROM,MTHRU,VSDTM
NEW VIS,MEDTX,LABTX,MDOP,LIV,LBOP,INAC,IEN,CPOP,CFROM,CTHRU,CRANGE,CPT,CPTX
NEW PROB,PROP,PPFROM,PPTHRU,PRANGE,PRSTAT,NUMLAB,SETLAB,ETHN,RACE,PLANG,PCOMM
NEW DBFROM,DBTHRU,PRNDC,PRNRV,PRNAC,CRIT,ALNAS,ALNKN,LNOT,MNOT,PFROM,PTHRU
NEW CNOT,CPTTX,CPFROM,CPTHRU,MD,PRFROM,PRTHRU,PROBTX,EDUFROM,EDUTHRU,EDURANGE
NEW EDUTX,EDUC,EDUPICK,EDUTOP,EDUNOT,EDUOP,EDFROM,EDTHRU,EFROM,ETHRU,MDNAC
NEW MDNDC,MDNRV,REMCODE,RMDFROM,RMDTHRU,RMDRANGE,OVD,FUT,RMFROM,RDFROM,RMTHRU
NEW RDTHRU,DEMO,POV,POVTX,PVFROM,PVTHRU,PVRANGE,POVS,POVSB,MEAS,MSNOT,MSFROM,MSTHRU
NEW MSRANGE,MSOP,PVOP,BPOP,ABPOP
;
I '$D(PARMS),'$D(MPARMS),'$D(APARMS),'$D(MAPARMS) Q
S NM=""
F S NM=$O(PARMS(NM)) Q:NM="" S @NM=PARMS(NM)
;
S SEX=$G(SEX,""),COMM=$G(COMM,"")
S ETHN=$G(ETHN,""),RACE=$G(RACE,""),PLANG=$G(PLANG,""),PCOMM=$G(PCOMM,"")
S DBFROM=$G(DBFROM,""),DBTHRU=$G(DBTHRU,"")
S FROM=$G(FROM,""),THRU=$G(THRU,""),FGLOB=$G(FGLOB,"")
S DXCAT=$G(DXCAT,""),PLIDEN=$G(PLIDEN,"")
S BEN=$G(BEN,"") ; Beneficiary
S DXOP=$G(DXOP,"!"),VISOP=$G(VISOP,"!"),BPOP=$G(BPOP,"!"),ABPOP=$G(ABPOP,"!")
S RANGE=$G(RANGE,"")
S DEC=$G(DEC,"N"),DECCOD=$G(DECCOD,"") ; Deceased
S LIV=$G(LIV,"Y") ; Living
S DEMO=$G(DEMO,"E") ; Demo patients
S INAC=$G(INAC,"N") ; Inactive patients
S DECFDT=$G(DECFDT,""),DECTDT=$G(DECTDT,"") ;Deceased Date Range
S DECCOD=$G(DECCOD,"")
S ALLERGY=$G(ALLERGY,""),ALLOP=$G(ALLOP,"!"),ALNAS=$G(ALNAS,""),ALNKN=$G(ALNKN,"")
S LAB=$G(LAB,""),MED=$G(MED,""),CPT=$G(CPT,""),POV=$G(POV,""),POVS=$G(POVS,""),MEAS=$G(MEAS,"")
S LABTX=$G(LABTX,""),MEDTX=$G(MEDTX,""),CPTTX=$G(CPTTX,""),POVTX=$G(POVTX,""),POVSB=$G(POVSB,"")
S LBOP=$G(LBOP,"!"),MDOP=$G(MDOP,"!"),CPOP=$G(CPOP,"!"),PROP=$G(PROP,"!"),EDUOP=$G(EDUOP,"!"),PVOP=$G(PVOP,"!"),MSOP=$G(MSOP,"!")
S EMPL=$G(EMPL,"")
S LNOT=$S($G(LNOT)="Y":1,1:0),MNOT=$S($G(MNOT)="Y":1,1:0),CNOT=$S($G(CNOT)="Y":1,1:0),EDUNOT=$S($G(EDUNOT)="Y":1,1:0)
S MSNOT=$S($G(MSNOT)="Y":1,1:0)
S PROB=$G(PROB,""),PRSTAT=$G(PRSTAT,""),PRNDC=$G(PRNDC,""),PRNRV=$G(PRNRV,""),PRNAC=$G(PRNAC,"")
S PROBTX=$G(PROBTX,"")
S EDUTX=$G(EDUTX,""),EDUC=$G(EDUC,""),EDUPICK=$G(EDUPICK,""),EDUTOP=$G(EDUTOP,"")
S OVD=$G(OVD,0),FUT=$G(FUT,0)
;
; If timeframe is selected populate start and end dates
I RANGE'="",$G(PPIEN)'="" D RANGE^BQIDCAH1(RANGE,PPIEN,"RANGE") S RFROM=$G(RFROM,""),RTHRU=$G(RTHRU,"")
S FROM=$S($G(RFROM)'="":RFROM,1:$G(FROM))
S THRU=$S($G(RTHRU)'="":RTHRU,1:$G(THRU))
K RFROM,RTHRU
;
I $G(LRANGE)'="",$G(PPIEN)'="" D RANGE^BQIDCAH1(LRANGE,PPIEN,"LRANGE") S LRFROM=$G(RFROM,""),LRTHRU=$G(RTHRU,"")
S LFROM=$S($G(LRFROM)'="":LRFROM,1:$G(LFROM))
S LTHRU=$S($G(LRTHRU)'="":LRTHRU,1:$G(LTHRU))
K RFROM,RTHRU
;
I $G(MRANGE)'="",$G(PPIEN)'="" D RANGE^BQIDCAH1(MRANGE,PPIEN,"MRANGE") S MRFROM=$G(RFROM,""),MRTHRU=$G(RTHRU,"")
S MFROM=$S($G(MRFROM)'="":MRFROM,1:$G(MFROM))
S MTHRU=$S($G(MRTHRU)'="":MRTHRU,1:$G(MTHRU))
K RFROM,RTHRU
;
I $G(CRANGE)'="",$G(PPIEN)'="" D RANGE^BQIDCAH1(CRANGE,PPIEN,"CRANGE") S CPFROM=$G(RFROM,""),CPTHRU=$G(RTHRU,"")
S CFROM=$S($G(CPFROM)'="":CPFROM,1:$G(CFROM))
S CTHRU=$S($G(CPTHRU)'="":CPTHRU,1:$G(CTHRU))
K RFROM,RTHRU
;
I $G(PRANGE)'="",$G(PPIEN)'="" D RANGE^BQIDCAH1(PRANGE,PPIEN,"PRANGE") S PPFROM=$G(RFROM,""),PPTHRU=$G(RTHRU,"")
S PFROM=$S($G(PPFROM)'="":PPFROM,1:$G(PRFROM))
S PTHRU=$S($G(PPTHRU)'="":PPTHRU,1:$G(PRTHRU))
K RFROM,RTHRU
;
I $G(EDURANGE)'="",$G(PPIEN)'="" D RANGE^BQIDCAH1(EDURANGE,PPIEN,"EDURANGE") S EDFROM=$G(RFROM,""),EDTHRU=$G(RTHRU,"")
S EFROM=$S($G(EDFROM)'="":EDFROM,1:$G(EDUFROM))
S ETHRU=$S($G(EDTHRU)'="":EDTHRU,1:$G(EDUTHRU))
K RFROM,RTHRU
;
I $G(RMDRANGE)'="",$G(PPIEN)'="" D RANGE^BQIDCAH1(RMDRANGE,PPIEN,"RMDRANGE") S RDFROM=$G(RFROM,""),RDTHRU=$G(RTHRU,"")
S RMFROM=$S($G(RDFROM)'="":RDFROM,1:$G(RMDFROM))
S RMTHRU=$S($G(RDTHRU)'="":RDTHRU,1:$G(RMDTHRU))
K RFROM,RTHRU,RDFROM,RDTHRU
;
I $G(PVRANGE)'="",$G(PPIEN)'="" D RANGE^BQIDCAH1(PVRANGE,PPIEN,"PVRANGE") S RDFROM=$G(RFROM,""),RDTHRU=$G(RTHRU,"")
S PVFROM=$S($G(RDFROM)'="":RDFROM,1:$G(PVFROM))
S PVTHRU=$S($G(RDTHRU)'="":RDTHRU,1:$G(PVTHRU))
K RFROM,RTHRU,RDFROM,RDTHRU
;
I $G(MSRANGE)'="",$G(PPIEN)'="" D RANGE^BQIDCAH1(MSRANGE,PPIEN,"MSRANGE") S RDFROM=$G(RFROM,""),RDTHRU=$G(RTHRU,"")
S MSFROM=$S($G(RDFROM)'="":RDFROM,1:$G(MSFROM))
S MSTHRU=$S($G(RDTHRU)'="":RDTHRU,1:$G(MSTHRU))
K RFROM,RTHRU,RDFROM,RDTHRU
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
F KK=0:1:10 K ^TMP("BQITO"_KK,UID)
S VDATA=$NA(^TMP("BQIAVIS",UID)),VNDATA=$NA(^TMP("BQINOVIS",UID))
S VODATA=$NA(^TMP("BQIOTHVIS",UID)),CRIT=$NA(^TMP("BQICRIT",UID))
K @VDATA,@VNDATA,@VODATA
;
S JJ=0
S TGLOB=$NA(^TMP("BQITO"_JJ,UID))
;
;If DEMO="O" Only include DEMO patients set up patients in file
I $G(DEMO)="O" D D UPD
. NEW DIEN,DN
. S DIEN=$O(^DIBT("B","RPMS DEMO PATIENT NAMES","")) I DIEN'="" D
.. S DN="" F S DN=$O(^DIBT(DIEN,1,DN)) Q:DN="" S @TGLOB@(DN)=""
. S DIEN="DEMO,PATIENT",DN="" F S DN=$O(^DPT("B",DIEN,DN)) Q:DN="" S @TGLOB@(DN)=""
. F S DIEN=$O(^DPT("B",DIEN)) Q:DIEN'["DEMO,PATIENT" S DN="" F S DN=$O(^DPT("B",DIEN,DN)) Q:DN="" S @TGLOB@(DN)=""
;
;Alternate cross-reference test
;I $G(FROM)'="",$G(PROV)'="" D PRVS^BQIDCAH2(TGLOB,PROV,FROM,THRU),UPD
;
I $G(EMPL)'="" D EMP^BQIDCAH4(FGLOB,TGLOB,EMPL,.MPARMS),UPD
;
I $G(PLIDEN)'=""!$D(MPARMS("PLIDEN")) D PNL^BQIDCAH4(FGLOB,TGLOB,PLIDEN,.MPARMS),UPD
;
I $G(DXCAT)'=""!$D(MPARMS("DXCAT")) D DIAG^BQIDCAH1(FGLOB,TGLOB,DXCAT,.MPARMS),UPD
;
I $G(COMM)'=""!$D(MPARMS("COMM")) D COMM(FGLOB,TGLOB,COMM,.MPARMS),UPD
;
I $G(COMMTX)'=""!$D(MPARMS("COMMTX")) D
. N COM,COMLST,IEN,PCOMM
. I $G(COMMTX)'="" D COMMTX(COMMTX,.COMLST)
. I $D(MPARMS("COMMTX")) D
.. S COM=""
.. F S COM=$O(MPARMS("COMMTX",COM)) Q:COM="" D COMMTX(COM,.COMLST)
. I $G(FGLOB)="" D
.. S COM=""
.. F S COM=$O(COMLST(COM)) Q:COM="" D COMM(FGLOB,TGLOB,COM,.MPARMS)
. I $G(FGLOB)'="",$D(COMLST) D
.. S IEN=0
.. F S IEN=$O(@FGLOB@(IEN)) Q:'IEN D
... S PCOMM=$P($G(^AUPNPAT(IEN,11)),U,18)
... Q:PCOMM=""
... I $D(COMLST(PCOMM)) S @TGLOB@(IEN)=""
. D UPD
;
I $G(BEN)'=""!$D(MPARMS("BEN")) D BEN^BQIDCAH1(FGLOB,TGLOB,BEN,.MPARMS),UPD
I $G(SEX)'="" D GEN^BQIDCAH5(FGLOB,TGLOB,SEX),UPD
I $G(RACE)'=""!$D(MPARMS("RACE")) D RACE^BQIDCAH5(FGLOB,TGLOB,RACE,.MPARMS),UPD
I $G(ETHN)'=""!$D(MPARMS("ETHN")) D ETHN^BQIDCAH5(FGLOB,TGLOB,ETHN,.MPARMS),UPD
I $G(PCOMM)'="" D PCOMM^BQIDCAH5(FGLOB,TGLOB,PCOMM),UPD
I $G(PLANG)'="" D PLANG^BQIDCAH5(FGLOB,TGLOB,PLANG),UPD
;
I $G(DBFROM)'="" D DOB^BQIDCAH5(FGLOB,TGLOB,DBFROM,DBTHRU),UPD
;
; If age is a single value then that is criteria 1 and criteria 2 is blank
I $G(AGE)'="" D
. S CRIT1=AGE,CRIT2=""
. D AGE(FGLOB,TGLOB,CRIT1,CRIT2),UPD
;
; If age is a multiple value then criteria 1 is the first and criteria 2 is the second MPARMS("AGE",#)
I $D(MPARMS("AGE")) D
. NEW N
. S N="",N=$O(MPARMS("AGE",N)),CRIT1=N
. S N=$O(MPARMS("AGE",N)) I N'="" S CRIT2=N
. S CRIT1=$G(CRIT1,""),CRIT2=$G(CRIT2,"")
. D AGE(FGLOB,TGLOB,CRIT1,CRIT2),UPD
;
I $G(PROB)'=""!$D(MPARMS("PROB"))!($G(PROBTX)'="") D PROB^BQIDCAH4(FGLOB,TGLOB,PROB,PROBTX,PFROM,PTHRU,.MPARMS),UPD
I $G(PRNDC)'="" D NDC^BQIDCAH4(FGLOB,TGLOB),UPD
I $G(PRNRV)'="" S PFROM=$$DATE^BQIUL1("T-365"),PTHRU=DT D NRV^BQIDCAH4(FGLOB,TGLOB,PFROM,PTHRU),UPD
I $G(PRNAC)'="" D NAC^BQIDCAH4(FGLOB,TGLOB,PFROM,PTHRU),UPD
;
I $G(FROM)'="" D VIS^BQIDCAH2(FGLOB,TGLOB,FROM,THRU,.MAPARMS),UPD
I $G(FROM)="",$G(RANGE)'="" D VIS^BQIDCAH2(FGLOB,TGLOB,FROM,THRU,.MAPARMS),UPD
;
I $G(LAB)'=""!$D(MPARMS("LAB"))!($G(LABTX)'="") D LAB^BQIDCAH3(FGLOB,TGLOB,LAB,LABTX,LFROM,LTHRU,LNOT,.MPARMS,.MAPARMS),UPD
;
I $G(EDUC)'=""!($D(MPARMS("EDUC"))!($G(EDUTX)'="")!($G(EDUTOP)'="")!($G(EDUPICK)'="")) D EDU^BQIDCAH5(FGLOB,TGLOB,EDUC,EDUTX,EFROM,ETHRU,EDUNOT,.MPARMS),UPD
;
I $G(MED)'=""!$D(MPARMS("MED"))!($G(MEDTX)'="") D MED^BQIDCAH3(FGLOB,TGLOB,MED,MEDTX,MFROM,MTHRU,MNOT,.MPARMS),UPD
I $G(MDNDC)'="" D MND^BQIDCAH4(FGLOB,TGLOB),UPD
I $G(MDNRV)'="" S MFROM=$$DATE^BQIUL1("T-365"),MTHRU=DT D MLR^BQIDCAH4(FGLOB,TGLOB,MFROM,MTHRU),UPD
I $G(MDNAC)'="" D NAM^BQIDCAH4(FGLOB,TGLOB,MFROM,MTHRU),UPD
;
I $G(CPT)'=""!$D(MPARMS("CPT"))!($G(CPTTX)'="") D CPT^BQIDCAH3(FGLOB,TGLOB,CPT,CPTTX,CFROM,CTHRU,CNOT,.MPARMS),UPD
;
I $G(POV)'=""!$D(MPARMS("POV"))!($G(POVTX)'="") D POV^BQIDCAH6(FGLOB,TGLOB,POV,POVTX,PVFROM,PVTHRU,CNOT,.MPARMS),UPD
I $G(POVS)'=""!$D(MPARMS("POVS"))!($G(POVSB)'="") D POVS^BQIDCAH6(FGLOB,TGLOB,POVS,POVSB,PVFROM,PVTHRU,CNOT,.MPARMS),UPD
;
I $G(MEAS)'=""!($D(MPARMS("MEAS"))) D MEAS^BQIDCAH7(FGLOB,TGLOB,MEAS,MSFROM,MSTHRU,MSNOT,.MPARMS),UPD
I $G(REMCODE)'=""!($D(MPARMS("REMCODE"))) D REM^BQIDCAH6(FGLOB,TGLOB,REMCODE,RMFROM,RMTHRU,OVD,FUT,.MPARMS),UPD
;
;I $G(PROV)'="" D PROV^BQIDCAH2(FGLOB,TGLOB,PROV),UPD
;
I $G(ALLERGY)'=""!$D(MPARMS("ALLERGY"))!($G(ALNAS)'="")!($G(ALNKN)'="") D ALGY^BQIDCAH6(FGLOB,TGLOB,ALLERGY,.MPARMS),UPD
;
D STAT(FGLOB,TGLOB,LIV,DEC,INAC),UPD
;
S DATA=$NA(^TMP("BQIAHOC",UID)),CDATA=$NA(^TMP("BQIAHOCC",UID))
K @DATA,@CDATA
M @CDATA=@CRIT
I $D(@TGLOB)>0 D
. S IEN="" F S IEN=$O(@TGLOB@(IEN)) Q:IEN="" D
.. I $G(DEMO)="E",$$DEMO^APCLUTL(IEN,"E")=1 Q
.. S @DATA@(IEN)=""
;
I $D(@TGLOB)'>0,$G(FGLOB)'="" D
. S IEN="" F S IEN=$O(@FGLOB@(IEN)) Q:IEN="" D
.. I $G(DEMO)="E",$$DEMO^APCLUTL(IEN,"E")=1 Q
.. S @DATA@(IEN)=""
;
F KK=0:1:JJ K ^TMP("BQITO"_KK,UID)
K @VDATA,@VODATA
I $D(@CRIT) K @CRIT
Q
;
UPD ;EP
S JJ=JJ+1,FGLOB=TGLOB,TGLOB=$NA(^TMP("BQITO"_JJ,UID))
Q
;
AGE(FGLOB,TGLOB,CRIT1,CRIT2) ;EP - Age search
I $G(TGLOB)="" Q
I $G(CRIT1)="" Q
;
NEW IEN,AGE,DOD
S IEN=0
I $G(FGLOB)'="" D
. F S IEN=$O(@FGLOB@(IEN)) Q:'IEN D ACHK^BQIDCAH1(.IEN)
;
I $G(FGLOB)="" D
. F S IEN=$O(^AUPNPAT(IEN)) Q:'IEN D ACHK^BQIDCAH1(.IEN)
Q
;
COMM(FGLOB,TGLOB,COM,MPARMS) ;EP - Community search
I $G(TGLOB)="" Q
I $G(COM)]"" D COMM1
I $D(MPARMS("COMM")) S COM="" F S COM=$O(MPARMS("COMM",COM)) Q:COM="" D COMM1
Q
;
COMM1 ;EP
; Get Community Name and use x-ref for speed improvement.
; If community ien is passed use it to determine if patient community matches ***
NEW COMM,COMMNM ;***
S (COMM,COMMNM)=COM ;***
I COMM?1.N S COMMNM=$$GET1^DIQ(9999999.05,COM,.01,"E") ;***
;
NEW IEN
S IEN=0
I $G(FGLOB)'="" D
. F S IEN=$O(@FGLOB@(IEN)) Q:'IEN D
.. I COMM?.N,$P($G(^AUPNPAT(IEN,11)),U,17)'=COMM Q ;***
.. I COMM'?.N,$P($G(^AUPNPAT(IEN,11)),U,18)'=COMMNM Q ;***
.. S @TGLOB@(IEN)=""
;
I $G(FGLOB)="" D
. F S IEN=$O(^AUPNPAT("AC",COMMNM,IEN)) Q:IEN="" D
.. ;I $P($G(^AUPNPAT(IEN,41,DUZ(2),0)),U,3)'="" Q
.. I COMM?.N,$P($G(^AUPNPAT(IEN,11)),U,17)'=COMM Q ;***
.. S @TGLOB@(IEN)=""
Q
;
COMMTX(TAX,COML) ;EP
; Get a list of communities for the specified community taxonomy
I $G(TAX)="" Q
N TAXNM,COMM,IEN
I TAX'?.N S TAXNM=TAX,TAX=$O(^ATXAX("B",TAXNM,"")) I TAX=""!($O(^ATXAX("B",TAXNM,TAX))'="") Q
; Currently CRS only uses community names and matches these to the patient's
; community without regard to state, etc.
S COMM=""
F S COMM=$O(^ATXAX(TAX,21,"B",COMM)) Q:COMM="" D
. I '$D(^AUTTCOM("B",COMM)) Q
. S COML(COMM)=""
Q
;
DECHK(DDFN) ;EP Is patient eligible based on date of death
NEW DOD,DFLG,DCD
S DOD=$P($G(^DPT(DDFN,.35)),U,1)
I DOD="" Q 0
;
;Date of Death Checks
;
;New Method - Date Range
I $G(DECFDT)="",$G(DECTDT)="",DOD'="" S DFLG=1 Q DFLG
I $G(DECFDT)'=""!($G(DECTDT)'="") S DFLG=1 D Q DFLG
. I $G(DECFDT)'="",DOD<DECFDT S DFLG=0 Q
. I $G(DECTDT)'="",DOD>DECTDT S DFLG=0
;
;Old Method - Single Deceased as of Date
;I DECDT="" Q 1
;I $G(DECDT)'="",DOD'>DECDT Q 1
;
; Multiple causes of death
I $D(MPARMS("DECCOD")) S DFLG=0 D Q DFLG
. S DCD="" F S DCD=$O(MPARMS("DECCOD",DCD)) Q:DCD="" I $P($G(^AUPNPAT(DDFN,11)),U,14)=DCD S DFLG=1
; single cause of death
I $G(DECCOD)'="",$P($G(^AUPNPAT(DDFN,11)),U,14)=DECCOD Q 1
;
Q 0
;
STAT(FGLOB,TGLOB,LIV,DEC,INAC) ;EP Check patients status
I $G(TGLOB)="" Q
NEW IEN
S IEN=0
I $G(FGLOB)'="" D Q
. F S IEN=$O(@FGLOB@(IEN)) Q:'IEN D STCK
;
I $G(FGLOB)="" D
. F S IEN=$O(^AUPNPAT(IEN)) Q:'IEN D STCK
Q
;
STCK ;EP - Check
; If all are checked for yes, all patients are included
I LIV="Y",DEC="Y",INAC="Y" S @TGLOB@(IEN)="" Q
; If none are checked, no patients are included
I LIV="N",DEC="N",INAC="N" Q
; if living and deceased are included but not inactives
I LIV="Y",DEC="Y",INAC="N" D
. ; Active HRN, include
. I $$HRN^BQIUL1(IEN) S @TGLOB@(IEN)="" Q
; Include living but not deceased
I LIV="Y",DEC="N",INAC="Y" D
. ; If they are not active and not deceased, include
. I '$$HRN^BQIUL1(IEN),'$$DECHK(IEN) S @TGLOB@(IEN)="" Q
; If living, not deceased and not inactive, include
I LIV="Y",DEC="N",INAC="N" D
. I $$HRN^BQIUL1(IEN),'$$DECHK(IEN) S @TGLOB@(IEN)="" Q
I LIV="N",DEC="Y",INAC="Y" D
. ; Decease but active
. I $$DECHK(IEN),$$HRN^BQIUL1(IEN) S @TGLOB@(IEN)="" Q
I LIV="N",DEC="N",INAC="Y" D
. ; inactive
. I '$$HRN^BQIUL1(IEN) S @TGLOB@(IEN)="" Q
I LIV="N",DEC="Y",INAC="N" D
. ; Deceased but not inactive
. I $$DECHK(IEN),$$HRN^BQIUL1(IEN) S @TGLOB@(IEN)="" Q
Q
BQIDCAH ;PRXM/HC/ALA-Ad Hoc Search ; 16 Nov 2005 6:26 PM
+1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
+2 ;
+3 QUIT
+4 ;
PARMS(DATA,CDATA,FGLOB,PARMS,MPARMS,APARMS,MAPARMS) ;EP - Execute Ad Hoc Search
+1 ;
+2 ;Description
+3 ; Ad Hoc Search which can be an assortment of parameters including;
+4 ; GENDER, COMMUNITY, PROVIDER, VISIT DATES, AGE
+5 ;Input
+6 ; FGLOB = From global (only sent for filters)
+7 ; PARMS = Array of parameters and their values
+8 ; MPARMS = Multiple array of a parameter
+9 ;Expected to return DATA
+10 ;
+11 NEW JJ,KK,UID,TGLOB,SEX,COMM,PROV,FROM,THRU,AGE,CRIT1,MRANGE,MRFROM,MRTHRU
+12 NEW CRIT2,NM,DXCAT,PLIDEN,NUMVIS,COMMTX,BEN,VDATA,VNDATA,VODATA,EMPL,VISOP
+13 NEW CLIN,DXOP,RANGE,RFROM,RTHRU,DEC,DECCOD,BNEW,VCRIT1,VCRIT2,DECFDT,DECTDT
+14 NEW ALLERGY,ALLOP,LFROM,LTHRU,LRANGE,LRFROM,LRTHRU,LAB,MED,MFROM,MTHRU,VSDTM
+15 NEW VIS,MEDTX,LABTX,MDOP,LIV,LBOP,INAC,IEN,CPOP,CFROM,CTHRU,CRANGE,CPT,CPTX
+16 NEW PROB,PROP,PPFROM,PPTHRU,PRANGE,PRSTAT,NUMLAB,SETLAB,ETHN,RACE,PLANG,PCOMM
+17 NEW DBFROM,DBTHRU,PRNDC,PRNRV,PRNAC,CRIT,ALNAS,ALNKN,LNOT,MNOT,PFROM,PTHRU
+18 NEW CNOT,CPTTX,CPFROM,CPTHRU,MD,PRFROM,PRTHRU,PROBTX,EDUFROM,EDUTHRU,EDURANGE
+19 NEW EDUTX,EDUC,EDUPICK,EDUTOP,EDUNOT,EDUOP,EDFROM,EDTHRU,EFROM,ETHRU,MDNAC
+20 NEW MDNDC,MDNRV,REMCODE,RMDFROM,RMDTHRU,RMDRANGE,OVD,FUT,RMFROM,RDFROM,RMTHRU
+21 NEW RDTHRU,DEMO,POV,POVTX,PVFROM,PVTHRU,PVRANGE,POVS,POVSB,MEAS,MSNOT,MSFROM,MSTHRU
+22 NEW MSRANGE,MSOP,PVOP,BPOP,ABPOP
+23 ;
+24 IF '$DATA(PARMS)
IF '$DATA(MPARMS)
IF '$DATA(APARMS)
IF '$DATA(MAPARMS)
QUIT
+25 SET NM=""
+26 FOR
SET NM=$ORDER(PARMS(NM))
IF NM=""
QUIT
SET @NM=PARMS(NM)
+27 ;
+28 SET SEX=$GET(SEX,"")
SET COMM=$GET(COMM,"")
+29 SET ETHN=$GET(ETHN,"")
SET RACE=$GET(RACE,"")
SET PLANG=$GET(PLANG,"")
SET PCOMM=$GET(PCOMM,"")
+30 SET DBFROM=$GET(DBFROM,"")
SET DBTHRU=$GET(DBTHRU,"")
+31 SET FROM=$GET(FROM,"")
SET THRU=$GET(THRU,"")
SET FGLOB=$GET(FGLOB,"")
+32 SET DXCAT=$GET(DXCAT,"")
SET PLIDEN=$GET(PLIDEN,"")
+33 ; Beneficiary
SET BEN=$GET(BEN,"")
+34 SET DXOP=$GET(DXOP,"!")
SET VISOP=$GET(VISOP,"!")
SET BPOP=$GET(BPOP,"!")
SET ABPOP=$GET(ABPOP,"!")
+35 SET RANGE=$GET(RANGE,"")
+36 ; Deceased
SET DEC=$GET(DEC,"N")
SET DECCOD=$GET(DECCOD,"")
+37 ; Living
SET LIV=$GET(LIV,"Y")
+38 ; Demo patients
SET DEMO=$GET(DEMO,"E")
+39 ; Inactive patients
SET INAC=$GET(INAC,"N")
+40 ;Deceased Date Range
SET DECFDT=$GET(DECFDT,"")
SET DECTDT=$GET(DECTDT,"")
+41 SET DECCOD=$GET(DECCOD,"")
+42 SET ALLERGY=$GET(ALLERGY,"")
SET ALLOP=$GET(ALLOP,"!")
SET ALNAS=$GET(ALNAS,"")
SET ALNKN=$GET(ALNKN,"")
+43 SET LAB=$GET(LAB,"")
SET MED=$GET(MED,"")
SET CPT=$GET(CPT,"")
SET POV=$GET(POV,"")
SET POVS=$GET(POVS,"")
SET MEAS=$GET(MEAS,"")
+44 SET LABTX=$GET(LABTX,"")
SET MEDTX=$GET(MEDTX,"")
SET CPTTX=$GET(CPTTX,"")
SET POVTX=$GET(POVTX,"")
SET POVSB=$GET(POVSB,"")
+45 SET LBOP=$GET(LBOP,"!")
SET MDOP=$GET(MDOP,"!")
SET CPOP=$GET(CPOP,"!")
SET PROP=$GET(PROP,"!")
SET EDUOP=$GET(EDUOP,"!")
SET PVOP=$GET(PVOP,"!")
SET MSOP=$GET(MSOP,"!")
+46 SET EMPL=$GET(EMPL,"")
+47 SET LNOT=$SELECT($GET(LNOT)="Y":1,1:0)
SET MNOT=$SELECT($GET(MNOT)="Y":1,1:0)
SET CNOT=$SELECT($GET(CNOT)="Y":1,1:0)
SET EDUNOT=$SELECT($GET(EDUNOT)="Y":1,1:0)
+48 SET MSNOT=$SELECT($GET(MSNOT)="Y":1,1:0)
+49 SET PROB=$GET(PROB,"")
SET PRSTAT=$GET(PRSTAT,"")
SET PRNDC=$GET(PRNDC,"")
SET PRNRV=$GET(PRNRV,"")
SET PRNAC=$GET(PRNAC,"")
+50 SET PROBTX=$GET(PROBTX,"")
+51 SET EDUTX=$GET(EDUTX,"")
SET EDUC=$GET(EDUC,"")
SET EDUPICK=$GET(EDUPICK,"")
SET EDUTOP=$GET(EDUTOP,"")
+52 SET OVD=$GET(OVD,0)
SET FUT=$GET(FUT,0)
+53 ;
+54 ; If timeframe is selected populate start and end dates
+55 IF RANGE'=""
IF $GET(PPIEN)'=""
DO RANGE^BQIDCAH1(RANGE,PPIEN,"RANGE")
SET RFROM=$GET(RFROM,"")
SET RTHRU=$GET(RTHRU,"")
+56 SET FROM=$SELECT($GET(RFROM)'="":RFROM,1:$GET(FROM))
+57 SET THRU=$SELECT($GET(RTHRU)'="":RTHRU,1:$GET(THRU))
+58 KILL RFROM,RTHRU
+59 ;
+60 IF $GET(LRANGE)'=""
IF $GET(PPIEN)'=""
DO RANGE^BQIDCAH1(LRANGE,PPIEN,"LRANGE")
SET LRFROM=$GET(RFROM,"")
SET LRTHRU=$GET(RTHRU,"")
+61 SET LFROM=$SELECT($GET(LRFROM)'="":LRFROM,1:$GET(LFROM))
+62 SET LTHRU=$SELECT($GET(LRTHRU)'="":LRTHRU,1:$GET(LTHRU))
+63 KILL RFROM,RTHRU
+64 ;
+65 IF $GET(MRANGE)'=""
IF $GET(PPIEN)'=""
DO RANGE^BQIDCAH1(MRANGE,PPIEN,"MRANGE")
SET MRFROM=$GET(RFROM,"")
SET MRTHRU=$GET(RTHRU,"")
+66 SET MFROM=$SELECT($GET(MRFROM)'="":MRFROM,1:$GET(MFROM))
+67 SET MTHRU=$SELECT($GET(MRTHRU)'="":MRTHRU,1:$GET(MTHRU))
+68 KILL RFROM,RTHRU
+69 ;
+70 IF $GET(CRANGE)'=""
IF $GET(PPIEN)'=""
DO RANGE^BQIDCAH1(CRANGE,PPIEN,"CRANGE")
SET CPFROM=$GET(RFROM,"")
SET CPTHRU=$GET(RTHRU,"")
+71 SET CFROM=$SELECT($GET(CPFROM)'="":CPFROM,1:$GET(CFROM))
+72 SET CTHRU=$SELECT($GET(CPTHRU)'="":CPTHRU,1:$GET(CTHRU))
+73 KILL RFROM,RTHRU
+74 ;
+75 IF $GET(PRANGE)'=""
IF $GET(PPIEN)'=""
DO RANGE^BQIDCAH1(PRANGE,PPIEN,"PRANGE")
SET PPFROM=$GET(RFROM,"")
SET PPTHRU=$GET(RTHRU,"")
+76 SET PFROM=$SELECT($GET(PPFROM)'="":PPFROM,1:$GET(PRFROM))
+77 SET PTHRU=$SELECT($GET(PPTHRU)'="":PPTHRU,1:$GET(PRTHRU))
+78 KILL RFROM,RTHRU
+79 ;
+80 IF $GET(EDURANGE)'=""
IF $GET(PPIEN)'=""
DO RANGE^BQIDCAH1(EDURANGE,PPIEN,"EDURANGE")
SET EDFROM=$GET(RFROM,"")
SET EDTHRU=$GET(RTHRU,"")
+81 SET EFROM=$SELECT($GET(EDFROM)'="":EDFROM,1:$GET(EDUFROM))
+82 SET ETHRU=$SELECT($GET(EDTHRU)'="":EDTHRU,1:$GET(EDUTHRU))
+83 KILL RFROM,RTHRU
+84 ;
+85 IF $GET(RMDRANGE)'=""
IF $GET(PPIEN)'=""
DO RANGE^BQIDCAH1(RMDRANGE,PPIEN,"RMDRANGE")
SET RDFROM=$GET(RFROM,"")
SET RDTHRU=$GET(RTHRU,"")
+86 SET RMFROM=$SELECT($GET(RDFROM)'="":RDFROM,1:$GET(RMDFROM))
+87 SET RMTHRU=$SELECT($GET(RDTHRU)'="":RDTHRU,1:$GET(RMDTHRU))
+88 KILL RFROM,RTHRU,RDFROM,RDTHRU
+89 ;
+90 IF $GET(PVRANGE)'=""
IF $GET(PPIEN)'=""
DO RANGE^BQIDCAH1(PVRANGE,PPIEN,"PVRANGE")
SET RDFROM=$GET(RFROM,"")
SET RDTHRU=$GET(RTHRU,"")
+91 SET PVFROM=$SELECT($GET(RDFROM)'="":RDFROM,1:$GET(PVFROM))
+92 SET PVTHRU=$SELECT($GET(RDTHRU)'="":RDTHRU,1:$GET(PVTHRU))
+93 KILL RFROM,RTHRU,RDFROM,RDTHRU
+94 ;
+95 IF $GET(MSRANGE)'=""
IF $GET(PPIEN)'=""
DO RANGE^BQIDCAH1(MSRANGE,PPIEN,"MSRANGE")
SET RDFROM=$GET(RFROM,"")
SET RDTHRU=$GET(RTHRU,"")
+96 SET MSFROM=$SELECT($GET(RDFROM)'="":RDFROM,1:$GET(MSFROM))
+97 SET MSTHRU=$SELECT($GET(RDTHRU)'="":RDTHRU,1:$GET(MSTHRU))
+98 KILL RFROM,RTHRU,RDFROM,RDTHRU
+99 ;
+100 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+101 FOR KK=0:1:10
KILL ^TMP("BQITO"_KK,UID)
+102 SET VDATA=$NAME(^TMP("BQIAVIS",UID))
SET VNDATA=$NAME(^TMP("BQINOVIS",UID))
+103 SET VODATA=$NAME(^TMP("BQIOTHVIS",UID))
SET CRIT=$NAME(^TMP("BQICRIT",UID))
+104 KILL @VDATA,@VNDATA,@VODATA
+105 ;
+106 SET JJ=0
+107 SET TGLOB=$NAME(^TMP("BQITO"_JJ,UID))
+108 ;
+109 ;If DEMO="O" Only include DEMO patients set up patients in file
+110 IF $GET(DEMO)="O"
Begin DoDot:1
+111 NEW DIEN,DN
+112 SET DIEN=$ORDER(^DIBT("B","RPMS DEMO PATIENT NAMES",""))
IF DIEN'=""
Begin DoDot:2
+113 SET DN=""
FOR
SET DN=$ORDER(^DIBT(DIEN,1,DN))
IF DN=""
QUIT
SET @TGLOB@(DN)=""
End DoDot:2
+114 SET DIEN="DEMO,PATIENT"
SET DN=""
FOR
SET DN=$ORDER(^DPT("B",DIEN,DN))
IF DN=""
QUIT
SET @TGLOB@(DN)=""
+115 FOR
SET DIEN=$ORDER(^DPT("B",DIEN))
IF DIEN'["DEMO,PATIENT"
QUIT
SET DN=""
FOR
SET DN=$ORDER(^DPT("B",DIEN,DN))
IF DN=""
QUIT
SET @TGLOB@(DN)=""
End DoDot:1
DO UPD
+116 ;
+117 ;Alternate cross-reference test
+118 ;I $G(FROM)'="",$G(PROV)'="" D PRVS^BQIDCAH2(TGLOB,PROV,FROM,THRU),UPD
+119 ;
+120 IF $GET(EMPL)'=""
DO EMP^BQIDCAH4(FGLOB,TGLOB,EMPL,.MPARMS)
DO UPD
+121 ;
+122 IF $GET(PLIDEN)'=""!$DATA(MPARMS("PLIDEN"))
DO PNL^BQIDCAH4(FGLOB,TGLOB,PLIDEN,.MPARMS)
DO UPD
+123 ;
+124 IF $GET(DXCAT)'=""!$DATA(MPARMS("DXCAT"))
DO DIAG^BQIDCAH1(FGLOB,TGLOB,DXCAT,.MPARMS)
DO UPD
+125 ;
+126 IF $GET(COMM)'=""!$DATA(MPARMS("COMM"))
DO COMM(FGLOB,TGLOB,COMM,.MPARMS)
DO UPD
+127 ;
+128 IF $GET(COMMTX)'=""!$DATA(MPARMS("COMMTX"))
Begin DoDot:1
+129 NEW COM,COMLST,IEN,PCOMM
+130 IF $GET(COMMTX)'=""
DO COMMTX(COMMTX,.COMLST)
+131 IF $DATA(MPARMS("COMMTX"))
Begin DoDot:2
+132 SET COM=""
+133 FOR
SET COM=$ORDER(MPARMS("COMMTX",COM))
IF COM=""
QUIT
DO COMMTX(COM,.COMLST)
End DoDot:2
+134 IF $GET(FGLOB)=""
Begin DoDot:2
+135 SET COM=""
+136 FOR
SET COM=$ORDER(COMLST(COM))
IF COM=""
QUIT
DO COMM(FGLOB,TGLOB,COM,.MPARMS)
End DoDot:2
+137 IF $GET(FGLOB)'=""
IF $DATA(COMLST)
Begin DoDot:2
+138 SET IEN=0
+139 FOR
SET IEN=$ORDER(@FGLOB@(IEN))
IF 'IEN
QUIT
Begin DoDot:3
+140 SET PCOMM=$PIECE($GET(^AUPNPAT(IEN,11)),U,18)
+141 IF PCOMM=""
QUIT
+142 IF $DATA(COMLST(PCOMM))
SET @TGLOB@(IEN)=""
End DoDot:3
End DoDot:2
+143 DO UPD
End DoDot:1
+144 ;
+145 IF $GET(BEN)'=""!$DATA(MPARMS("BEN"))
DO BEN^BQIDCAH1(FGLOB,TGLOB,BEN,.MPARMS)
DO UPD
+146 IF $GET(SEX)'=""
DO GEN^BQIDCAH5(FGLOB,TGLOB,SEX)
DO UPD
+147 IF $GET(RACE)'=""!$DATA(MPARMS("RACE"))
DO RACE^BQIDCAH5(FGLOB,TGLOB,RACE,.MPARMS)
DO UPD
+148 IF $GET(ETHN)'=""!$DATA(MPARMS("ETHN"))
DO ETHN^BQIDCAH5(FGLOB,TGLOB,ETHN,.MPARMS)
DO UPD
+149 IF $GET(PCOMM)'=""
DO PCOMM^BQIDCAH5(FGLOB,TGLOB,PCOMM)
DO UPD
+150 IF $GET(PLANG)'=""
DO PLANG^BQIDCAH5(FGLOB,TGLOB,PLANG)
DO UPD
+151 ;
+152 IF $GET(DBFROM)'=""
DO DOB^BQIDCAH5(FGLOB,TGLOB,DBFROM,DBTHRU)
DO UPD
+153 ;
+154 ; If age is a single value then that is criteria 1 and criteria 2 is blank
+155 IF $GET(AGE)'=""
Begin DoDot:1
+156 SET CRIT1=AGE
SET CRIT2=""
+157 DO AGE(FGLOB,TGLOB,CRIT1,CRIT2)
DO UPD
End DoDot:1
+158 ;
+159 ; If age is a multiple value then criteria 1 is the first and criteria 2 is the second MPARMS("AGE",#)
+160 IF $DATA(MPARMS("AGE"))
Begin DoDot:1
+161 NEW N
+162 SET N=""
SET N=$ORDER(MPARMS("AGE",N))
SET CRIT1=N
+163 SET N=$ORDER(MPARMS("AGE",N))
IF N'=""
SET CRIT2=N
+164 SET CRIT1=$GET(CRIT1,"")
SET CRIT2=$GET(CRIT2,"")
+165 DO AGE(FGLOB,TGLOB,CRIT1,CRIT2)
DO UPD
End DoDot:1
+166 ;
+167 IF $GET(PROB)'=""!$DATA(MPARMS("PROB"))!($GET(PROBTX)'="")
DO PROB^BQIDCAH4(FGLOB,TGLOB,PROB,PROBTX,PFROM,PTHRU,.MPARMS)
DO UPD
+168 IF $GET(PRNDC)'=""
DO NDC^BQIDCAH4(FGLOB,TGLOB)
DO UPD
+169 IF $GET(PRNRV)'=""
SET PFROM=$$DATE^BQIUL1("T-365")
SET PTHRU=DT
DO NRV^BQIDCAH4(FGLOB,TGLOB,PFROM,PTHRU)
DO UPD
+170 IF $GET(PRNAC)'=""
DO NAC^BQIDCAH4(FGLOB,TGLOB,PFROM,PTHRU)
DO UPD
+171 ;
+172 IF $GET(FROM)'=""
DO VIS^BQIDCAH2(FGLOB,TGLOB,FROM,THRU,.MAPARMS)
DO UPD
+173 IF $GET(FROM)=""
IF $GET(RANGE)'=""
DO VIS^BQIDCAH2(FGLOB,TGLOB,FROM,THRU,.MAPARMS)
DO UPD
+174 ;
+175 IF $GET(LAB)'=""!$DATA(MPARMS("LAB"))!($GET(LABTX)'="")
DO LAB^BQIDCAH3(FGLOB,TGLOB,LAB,LABTX,LFROM,LTHRU,LNOT,.MPARMS,.MAPARMS)
DO UPD
+176 ;
+177 IF $GET(EDUC)'=""!($DATA(MPARMS("EDUC"))!($GET(EDUTX)'="")!($GET(EDUTOP)'="")!($GET(EDUPICK)'=""))
DO EDU^BQIDCAH5(FGLOB,TGLOB,EDUC,EDUTX,EFROM,ETHRU,EDUNOT,.MPARMS)
DO UPD
+178 ;
+179 IF $GET(MED)'=""!$DATA(MPARMS("MED"))!($GET(MEDTX)'="")
DO MED^BQIDCAH3(FGLOB,TGLOB,MED,MEDTX,MFROM,MTHRU,MNOT,.MPARMS)
DO UPD
+180 IF $GET(MDNDC)'=""
DO MND^BQIDCAH4(FGLOB,TGLOB)
DO UPD
+181 IF $GET(MDNRV)'=""
SET MFROM=$$DATE^BQIUL1("T-365")
SET MTHRU=DT
DO MLR^BQIDCAH4(FGLOB,TGLOB,MFROM,MTHRU)
DO UPD
+182 IF $GET(MDNAC)'=""
DO NAM^BQIDCAH4(FGLOB,TGLOB,MFROM,MTHRU)
DO UPD
+183 ;
+184 IF $GET(CPT)'=""!$DATA(MPARMS("CPT"))!($GET(CPTTX)'="")
DO CPT^BQIDCAH3(FGLOB,TGLOB,CPT,CPTTX,CFROM,CTHRU,CNOT,.MPARMS)
DO UPD
+185 ;
+186 IF $GET(POV)'=""!$DATA(MPARMS("POV"))!($GET(POVTX)'="")
DO POV^BQIDCAH6(FGLOB,TGLOB,POV,POVTX,PVFROM,PVTHRU,CNOT,.MPARMS)
DO UPD
+187 IF $GET(POVS)'=""!$DATA(MPARMS("POVS"))!($GET(POVSB)'="")
DO POVS^BQIDCAH6(FGLOB,TGLOB,POVS,POVSB,PVFROM,PVTHRU,CNOT,.MPARMS)
DO UPD
+188 ;
+189 IF $GET(MEAS)'=""!($DATA(MPARMS("MEAS")))
DO MEAS^BQIDCAH7(FGLOB,TGLOB,MEAS,MSFROM,MSTHRU,MSNOT,.MPARMS)
DO UPD
+190 IF $GET(REMCODE)'=""!($DATA(MPARMS("REMCODE")))
DO REM^BQIDCAH6(FGLOB,TGLOB,REMCODE,RMFROM,RMTHRU,OVD,FUT,.MPARMS)
DO UPD
+191 ;
+192 ;I $G(PROV)'="" D PROV^BQIDCAH2(FGLOB,TGLOB,PROV),UPD
+193 ;
+194 IF $GET(ALLERGY)'=""!$DATA(MPARMS("ALLERGY"))!($GET(ALNAS)'="")!($GET(ALNKN)'="")
DO ALGY^BQIDCAH6(FGLOB,TGLOB,ALLERGY,.MPARMS)
DO UPD
+195 ;
+196 DO STAT(FGLOB,TGLOB,LIV,DEC,INAC)
DO UPD
+197 ;
+198 SET DATA=$NAME(^TMP("BQIAHOC",UID))
SET CDATA=$NAME(^TMP("BQIAHOCC",UID))
+199 KILL @DATA,@CDATA
+200 MERGE @CDATA=@CRIT
+201 IF $DATA(@TGLOB)>0
Begin DoDot:1
+202 SET IEN=""
FOR
SET IEN=$ORDER(@TGLOB@(IEN))
IF IEN=""
QUIT
Begin DoDot:2
+203 IF $GET(DEMO)="E"
IF $$DEMO^APCLUTL(IEN,"E")=1
QUIT
+204 SET @DATA@(IEN)=""
End DoDot:2
End DoDot:1
+205 ;
+206 IF $DATA(@TGLOB)'>0
IF $GET(FGLOB)'=""
Begin DoDot:1
+207 SET IEN=""
FOR
SET IEN=$ORDER(@FGLOB@(IEN))
IF IEN=""
QUIT
Begin DoDot:2
+208 IF $GET(DEMO)="E"
IF $$DEMO^APCLUTL(IEN,"E")=1
QUIT
+209 SET @DATA@(IEN)=""
End DoDot:2
End DoDot:1
+210 ;
+211 FOR KK=0:1:JJ
KILL ^TMP("BQITO"_KK,UID)
+212 KILL @VDATA,@VODATA
+213 IF $DATA(@CRIT)
KILL @CRIT
+214 QUIT
+215 ;
UPD ;EP
+1 SET JJ=JJ+1
SET FGLOB=TGLOB
SET TGLOB=$NAME(^TMP("BQITO"_JJ,UID))
+2 QUIT
+3 ;
AGE(FGLOB,TGLOB,CRIT1,CRIT2) ;EP - Age search
+1 IF $GET(TGLOB)=""
QUIT
+2 IF $GET(CRIT1)=""
QUIT
+3 ;
+4 NEW IEN,AGE,DOD
+5 SET IEN=0
+6 IF $GET(FGLOB)'=""
Begin DoDot:1
+7 FOR
SET IEN=$ORDER(@FGLOB@(IEN))
IF 'IEN
QUIT
DO ACHK^BQIDCAH1(.IEN)
End DoDot:1
+8 ;
+9 IF $GET(FGLOB)=""
Begin DoDot:1
+10 FOR
SET IEN=$ORDER(^AUPNPAT(IEN))
IF 'IEN
QUIT
DO ACHK^BQIDCAH1(.IEN)
End DoDot:1
+11 QUIT
+12 ;
COMM(FGLOB,TGLOB,COM,MPARMS) ;EP - Community search
+1 IF $GET(TGLOB)=""
QUIT
+2 IF $GET(COM)]""
DO COMM1
+3 IF $DATA(MPARMS("COMM"))
SET COM=""
FOR
SET COM=$ORDER(MPARMS("COMM",COM))
IF COM=""
QUIT
DO COMM1
+4 QUIT
+5 ;
COMM1 ;EP
+1 ; Get Community Name and use x-ref for speed improvement.
+2 ; If community ien is passed use it to determine if patient community matches ***
+3 ;***
NEW COMM,COMMNM
+4 ;***
SET (COMM,COMMNM)=COM
+5 ;***
IF COMM?1.N
SET COMMNM=$$GET1^DIQ(9999999.05,COM,.01,"E")
+6 ;
+7 NEW IEN
+8 SET IEN=0
+9 IF $GET(FGLOB)'=""
Begin DoDot:1
+10 FOR
SET IEN=$ORDER(@FGLOB@(IEN))
IF 'IEN
QUIT
Begin DoDot:2
+11 ;***
IF COMM?.N
IF $PIECE($GET(^AUPNPAT(IEN,11)),U,17)'=COMM
QUIT
+12 ;***
IF COMM'?.N
IF $PIECE($GET(^AUPNPAT(IEN,11)),U,18)'=COMMNM
QUIT
+13 SET @TGLOB@(IEN)=""
End DoDot:2
End DoDot:1
+14 ;
+15 IF $GET(FGLOB)=""
Begin DoDot:1
+16 FOR
SET IEN=$ORDER(^AUPNPAT("AC",COMMNM,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+17 ;I $P($G(^AUPNPAT(IEN,41,DUZ(2),0)),U,3)'="" Q
+18 ;***
IF COMM?.N
IF $PIECE($GET(^AUPNPAT(IEN,11)),U,17)'=COMM
QUIT
+19 SET @TGLOB@(IEN)=""
End DoDot:2
End DoDot:1
+20 QUIT
+21 ;
COMMTX(TAX,COML) ;EP
+1 ; Get a list of communities for the specified community taxonomy
+2 IF $GET(TAX)=""
QUIT
+3 NEW TAXNM,COMM,IEN
+4 IF TAX'?.N
SET TAXNM=TAX
SET TAX=$ORDER(^ATXAX("B",TAXNM,""))
IF TAX=""!($ORDER(^ATXAX("B",TAXNM,TAX))'="")
QUIT
+5 ; Currently CRS only uses community names and matches these to the patient's
+6 ; community without regard to state, etc.
+7 SET COMM=""
+8 FOR
SET COMM=$ORDER(^ATXAX(TAX,21,"B",COMM))
IF COMM=""
QUIT
Begin DoDot:1
+9 IF '$DATA(^AUTTCOM("B",COMM))
QUIT
+10 SET COML(COMM)=""
End DoDot:1
+11 QUIT
+12 ;
DECHK(DDFN) ;EP Is patient eligible based on date of death
+1 NEW DOD,DFLG,DCD
+2 SET DOD=$PIECE($GET(^DPT(DDFN,.35)),U,1)
+3 IF DOD=""
QUIT 0
+4 ;
+5 ;Date of Death Checks
+6 ;
+7 ;New Method - Date Range
+8 IF $GET(DECFDT)=""
IF $GET(DECTDT)=""
IF DOD'=""
SET DFLG=1
QUIT DFLG
+9 IF $GET(DECFDT)'=""!($GET(DECTDT)'="")
SET DFLG=1
Begin DoDot:1
+10 IF $GET(DECFDT)'=""
IF DOD<DECFDT
SET DFLG=0
QUIT
+11 IF $GET(DECTDT)'=""
IF DOD>DECTDT
SET DFLG=0
End DoDot:1
QUIT DFLG
+12 ;
+13 ;Old Method - Single Deceased as of Date
+14 ;I DECDT="" Q 1
+15 ;I $G(DECDT)'="",DOD'>DECDT Q 1
+16 ;
+17 ; Multiple causes of death
+18 IF $DATA(MPARMS("DECCOD"))
SET DFLG=0
Begin DoDot:1
+19 SET DCD=""
FOR
SET DCD=$ORDER(MPARMS("DECCOD",DCD))
IF DCD=""
QUIT
IF $PIECE($GET(^AUPNPAT(DDFN,11)),U,14)=DCD
SET DFLG=1
End DoDot:1
QUIT DFLG
+20 ; single cause of death
+21 IF $GET(DECCOD)'=""
IF $PIECE($GET(^AUPNPAT(DDFN,11)),U,14)=DECCOD
QUIT 1
+22 ;
+23 QUIT 0
+24 ;
STAT(FGLOB,TGLOB,LIV,DEC,INAC) ;EP Check patients status
+1 IF $GET(TGLOB)=""
QUIT
+2 NEW IEN
+3 SET IEN=0
+4 IF $GET(FGLOB)'=""
Begin DoDot:1
+5 FOR
SET IEN=$ORDER(@FGLOB@(IEN))
IF 'IEN
QUIT
DO STCK
End DoDot:1
QUIT
+6 ;
+7 IF $GET(FGLOB)=""
Begin DoDot:1
+8 FOR
SET IEN=$ORDER(^AUPNPAT(IEN))
IF 'IEN
QUIT
DO STCK
End DoDot:1
+9 QUIT
+10 ;
STCK ;EP - Check
+1 ; If all are checked for yes, all patients are included
+2 IF LIV="Y"
IF DEC="Y"
IF INAC="Y"
SET @TGLOB@(IEN)=""
QUIT
+3 ; If none are checked, no patients are included
+4 IF LIV="N"
IF DEC="N"
IF INAC="N"
QUIT
+5 ; if living and deceased are included but not inactives
+6 IF LIV="Y"
IF DEC="Y"
IF INAC="N"
Begin DoDot:1
+7 ; Active HRN, include
+8 IF $$HRN^BQIUL1(IEN)
SET @TGLOB@(IEN)=""
QUIT
End DoDot:1
+9 ; Include living but not deceased
+10 IF LIV="Y"
IF DEC="N"
IF INAC="Y"
Begin DoDot:1
+11 ; If they are not active and not deceased, include
+12 IF '$$HRN^BQIUL1(IEN)
IF '$$DECHK(IEN)
SET @TGLOB@(IEN)=""
QUIT
End DoDot:1
+13 ; If living, not deceased and not inactive, include
+14 IF LIV="Y"
IF DEC="N"
IF INAC="N"
Begin DoDot:1
+15 IF $$HRN^BQIUL1(IEN)
IF '$$DECHK(IEN)
SET @TGLOB@(IEN)=""
QUIT
End DoDot:1
+16 IF LIV="N"
IF DEC="Y"
IF INAC="Y"
Begin DoDot:1
+17 ; Decease but active
+18 IF $$DECHK(IEN)
IF $$HRN^BQIUL1(IEN)
SET @TGLOB@(IEN)=""
QUIT
End DoDot:1
+19 IF LIV="N"
IF DEC="N"
IF INAC="Y"
Begin DoDot:1
+20 ; inactive
+21 IF '$$HRN^BQIUL1(IEN)
SET @TGLOB@(IEN)=""
QUIT
End DoDot:1
+22 IF LIV="N"
IF DEC="Y"
IF INAC="N"
Begin DoDot:1
+23 ; Deceased but not inactive
+24 IF $$DECHK(IEN)
IF $$HRN^BQIUL1(IEN)
SET @TGLOB@(IEN)=""
QUIT
End DoDot:1
+25 QUIT
