BQIDCAH3 ;VNGT/HS/ALA-Ad Hoc continued ; 22 Apr 2011 12:02 PM
;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
;
LAB(FGLOB,TGLOB,LAB,LABTX,FDT,TDT,LNOT,MPARMS,MAPARMS) ;EP - Lab test search
NEW LTAX,TREF,NGLOB,LCT,CT,IEN,RVAL,LB
S NGLOB=$NA(^TMP("BQIDCLAB",$J)) K @NGLOB
K LBPT
I $G(TGLOB)="" Q
I $D(APARMS)!($D(MAPARMS)) D Q
. I LBOP="!" D
.. S LAB=""
.. F S LAB=$O(APARMS("LAB",LAB)) Q:LAB="" D
... S RVAL=$O(APARMS("LAB",LAB,""))
... I RVAL="NUMLAB" S NUMLAB=APARMS("LAB",LAB,"NUMLAB")
... I RVAL="SETLAB" S SETLAB=APARMS("LAB",LAB,"SETLAB")
... D LB
.. S LAB=""
.. F S LAB=$O(MAPARMS("LAB",LAB)) Q:LAB="" D LB
. I LBOP="&" D
.. ;K LBPT
.. S LAB="",CT=0
.. F S LAB=$O(APARMS("LAB",LAB)) Q:LAB="" D S CT=CT+1
... S RVAL=$O(APARMS("LAB",LAB,""))
... I RVAL="NUMLAB" S NUMLAB=APARMS("LAB",LAB,"NUMLAB")
... I RVAL="SETLAB" S SETLAB=APARMS("LAB",LAB,"SETLAB")
... D LB
.. S LAB=""
.. F S LAB=$O(MAPARMS("LAB",LAB)) Q:LAB="" D LB
.. S LAB="" K NUMLAB,SETLAB
.. F S LAB=$O(MPARMS("LAB",LAB)) Q:LAB="" D
... S:'$D(APARMS("LAB",LAB)) CT=CT+1
... I '$D(APARMS("LAB",LAB)) D LB
.. S IEN=""
.. F S IEN=$O(LBPT(IEN)) Q:IEN="" D
... S LCT=0,LB=""
... F S LB=$O(LBPT(IEN,LB)) Q:LB="" S LCT=LCT+1
... I LCT=CT,'LNOT D
.... S @TGLOB@(IEN)="",LB=""
.... F S LB=$O(LBPT(IEN,LB)) Q:LB="" D
..... S LIEN=""
..... F S LIEN=$O(LBPT(IEN,LB,LIEN)) Q:LIEN="" S @CRIT@("LAB",IEN,LIEN)=""
... I LCT=CT,LNOT S @NGLOB@(IEN)="" K @CRIT@("LAB",IEN)
I $G(LAB)'="" D LB
I $G(LABTX)'="" D
. S TREF=$NA(MPARMS("LAB"))
. K @TREF
. S LTAX=$P(@("^"_$P(LABTX,";",2)_$P(LABTX,";",1)_",0)"),"^",1)
. I LABTX["ATXAX" D BLD^BQITUTL(LTAX,TREF)
. I LABTX["ATXLAB" D BLD^BQITUTL(LTAX,TREF,"L")
I LBOP="!" D
. I $D(MPARMS("LAB")) S LAB="" F S LAB=$O(MPARMS("LAB",LAB)) Q:LAB="" D LB
I LBOP="&" D
. K LBPT
. S LAB="",CT=0 F S LAB=$O(MPARMS("LAB",LAB)) Q:LAB="" D LB S CT=CT+1
. S IEN=""
. F S IEN=$O(LBPT(IEN)) Q:IEN="" D
.. S LCT=0,LB=""
.. F S LB=$O(LBPT(IEN,LB)) Q:LB="" S LCT=LCT+1
.. I LCT=CT,'LNOT D
... S @TGLOB@(IEN)="",LB=""
... F S LB=$O(LBPT(IEN,LB)) Q:LB="" D
.... S LIEN=""
.... F S LIEN=$O(LBPT(IEN,LB,LIEN)) Q:LIEN="" S @CRIT@("LAB",IEN,LIEN)=""
.. I LCT=CT,LNOT S @NGLOB@(IEN)="" K @CRIT@("LAB",IEN)
;
I LNOT,$G(FGLOB)'="" D
. S IEN="" F S IEN=$O(@FGLOB@(IEN)) Q:IEN="" D
.. I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
I LNOT,$G(FGLOB)="" D
. S IEN=0 F S IEN=$O(^AUPNPAT(IEN)) Q:'IEN I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
K @NGLOB
Q
;
LB ;EP
NEW DFN,IEN,LBRES,RES,LOK,LURES,LBURNP
S TDT=$S(TDT'="":TDT,1:DT)
I $G(FGLOB)'="" D Q
. NEW IEN
. S IEN=""
. F S IEN=$O(@FGLOB@(IEN)) Q:'IEN D
.. I $O(^AUPNVLAB("AA",IEN,LAB,""))="" Q
.. I FDT="" D
... S BDT=""
... F S BDT=$O(^AUPNVLAB("AA",IEN,LAB,BDT)) Q:BDT="" D LBDT
.. I FDT'="" D
... S BGT=9999999-FDT,ENT=9999999-TDT,BDT=ENT-1
... F S BDT=$O(^AUPNVLAB("AA",IEN,LAB,BDT)) Q:BDT=""!(BDT>BGT) D LBDT
;
S IEN=""
F S IEN=$O(^AUPNVLAB("B",LAB,IEN)) Q:IEN="" D
. I $G(^AUPNVLAB(IEN,0))="" Q
. S DFN=$P($G(^AUPNVLAB(IEN,0)),U,2),VIS=$P(^AUPNVLAB(IEN,0),U,3) I VIS="" Q
. I $G(^AUPNVSIT(VIS,0))="" Q
. Q:"DXCT"[$P(^AUPNVSIT(VIS,0),U,7)
. S VSDTM=$P(^AUPNVSIT(VIS,0),U,1)\1
. I FDT'="",VSDTM<FDT!(VSDTM>TDT) Q
. S LBRES=$P($G(^AUPNVLAB(IEN,0)),U,4),LURES=$$UP^XLFSTR(LBRES)
. S LBRSN=$$PUNC^BQIUL3(LBRES),LBURNP=$$PUNC^BQIUL3(LURES)
. ; If looking for a lab result
. S RES=0
. I $G(SETLAB)="",$G(NUMLAB)="",'$D(MAPARMS("LAB",LAB,"SETLAB")),'$D(MAPARMS("LAB",LAB,"NUMLAB")) S ROK=0,RES=1,LOK=1
. I $G(SETLAB)'=""!($G(NUMLAB)'="")!($D(MAPARMS("LAB",LAB,"SETLAB")))!($D(MAPARMS("LAB",LAB,"NUMLAB"))) S ROK=1,LOK=0 D LBR
. I LBOP="!",'LNOT D Q
.. I ROK,'RES Q
.. S @TGLOB@(DFN)=""
.. I LOK S @CRIT@("LAB",DFN,IEN)=""
. I LBOP="!",LNOT D Q
.. I ROK,'RES Q
.. S @NGLOB@(DFN)=""
.. I LOK S @CRIT@("LAB",DFN,IEN)=""
. I LBOP="&" D Q
.. I ROK,'RES Q
.. ;S LBPT(DFN,LAB,IEN)=IEN_U_LBRES B
.. S LBPT(DFN,LAB,IEN)=""
.. I LOK S @CRIT@("LAB",DFN,IEN)=""
;
Q
;
LBDT ;EP - Date search
S LIEN=""
F S LIEN=$O(^AUPNVLAB("AA",IEN,LAB,BDT,LIEN)) Q:LIEN="" D
. S VIS=$P($G(^AUPNVLAB(LIEN,0)),U,3) I VIS="" Q
. I $G(^AUPNVSIT(VIS,0))="" Q
. Q:"DXCT"[$P(^AUPNVSIT(VIS,0),U,7)
. S LBRES=$P($G(^AUPNVLAB(LIEN,0)),U,4),LURES=$$UP^XLFSTR(LBRES)
. S LBRSN=$$PUNC^BQIUL3(LBRES),LBURNP=$$PUNC^BQIUL3(LURES)
. ; If looking for a lab result
. S RES=0
. I $G(SETLAB)="",$G(NUMLAB)="",'$D(MAPARMS("LAB",LAB,"SETLAB")),'$D(MAPARMS("LAB",LAB,"NUMLAB")) S ROK=0,RES=1,LOK=1
. I $G(SETLAB)'=""!($G(NUMLAB)'="")!($D(MAPARMS("LAB",LAB,"SETLAB")))!($D(MAPARMS("LAB",LAB,"NUMLAB"))) S ROK=1,LOK=0 D LBR
. I LBOP="!",'LNOT D Q
.. I ROK,'RES Q
.. S @TGLOB@(IEN)=""
.. I LOK S @CRIT@("LAB",IEN,LIEN)=""
. I LBOP="!",LNOT D Q
.. I ROK,'RES Q
.. S @NGLOB@(IEN)=""
.. I LOK S @CRIT@("LAB",IEN,LIEN)=""
. I LBOP="&" D Q
.. I ROK,'RES Q
.. ;S LBPT(IEN,LAB)=LIEN_U_LBRES
.. S LBPT(IEN,LAB,LIEN)=""
.. I LOK S @CRIT@("LAB",IEN,LIEN)=""
Q
;
LBR ;EP - Lab results
I LBRES="" Q
NEW LBR,VCRIT1,VCRIT2,ROPER,OPER,OPER2,RES1,RES2,SCODE,LI,LBRS,FQL
I $G(SETLAB)'="",LBRES=SETLAB S LOK=1,RES=1 Q
I $G(SETLAB)'="",LBRES'=SETLAB D Q
. I SETLAB=LURES S LOK=1,RES=1 Q
. S SCODE=$$LSET(LAB)
. D SCD
;
;I $G(SETLAB)'="",'$D(MAPARMS("LAB",LAB,"SETLAB")),LBRES=$P(SCODE,":",1)!(LBRES=$P(SCODE,":",2)) S LOK=1,RES=1 Q
I $D(MAPARMS("LAB",LAB,"SETLAB")) D Q
. S LBR="" F S LBR=$O(MAPARMS("LAB",LAB,"SETLAB",LBR)) Q:LBR="" D Q:LOK
.. I LBRES=LBR S LOK=1,RES=1 Q
.. S SCODE=$$LSET(LAB)
.. NEW SETLAB
.. S SETLAB=LBR D SCD
;
I $G(NUMLAB)'="" D Q
. ;NEW REX,R
. ;S R=0,REX=0 F S R=$O(^BQICARE(OWNR,1,PLIEN,5,R)) Q:'R I ^BQICARE(OWNR,1,PLIEN,5,R,0)["exclusive" S REX=1
. NEW REX
. I NUMLAB["~" S REX=1
. I NUMLAB["~",NUMLAB["'" S REX=0
. I LBRES?.ULP Q
. I LBRES'?.PN,LBRES'?.N Q
. I $E(LBRES,$L(LBRES),$L(LBRES))?.P S LBRES=$E(LBRES,1,$L(LBRES)-1)
. ; if value starts with a punctuation e.g. < or >
. I $E(LBRES,1,1)?.P S ROPER=$E(LBRES,1,1),LBRES=$E(LBRES,2,$L(LBRES))
. I NUMLAB["~" S VCRIT1=$P(NUMLAB,"~",1),VCRIT2=$P(NUMLAB,"~",2)
. E S VCRIT1=NUMLAB,VCRIT2=""
. F I=1:1:$L(VCRIT1) Q:$E(VCRIT1,I,I)'?.P
. S OPER=$E(VCRIT1,1,I-1),RES1=$E(VCRIT1,I,$L(VCRIT1))
. I $E(OPER,$L(OPER),$L(OPER))="." D
.. S OPER=$E(OPER,1,$L(OPER)-1),RES1="."_RES1
. I $G(VCRIT2)'="" D
.. F I=1:1:$L(VCRIT2) Q:$E(VCRIT2,I,I)'?.P
.. S OPER2=$E(VCRIT2,1,I-1),RES2=$E(VCRIT2,I,$L(VCRIT2))
.. I $E(OPER2,$L(OPER2),$L(OPER2))="." D
... S OPER2=$E(OPER2,1,$L(OPER2)-1),RES2="."_RES2
. I VCRIT2="" D
.. I $G(ROPER)="",@("LBRES"_OPER_"RES1") S LOK=1,RES=1 Q
.. I $G(ROPER)'="",OPER=ROPER,@("LBRES"_OPER_"RES1") S LOK=1,RES=1 Q
.. I $G(ROPER)'="",OPER'=ROPER Q
. I VCRIT2'="" D
.. I @("LBRES"_OPER_"RES1"),@("LBRES"_OPER2_"RES2") S LOK=1,RES=1
.. I REX D
... I @("LBRES"_OPER_"RES1") S LOK=1,RES=1
... I @("LBRES"_OPER2_"RES2") S LOK=1,RES=1
Q
;
SCD ;EP
NEW LCOD,LCODU,LCODP,LVAL,LVALU,LVALP
F LI=1:1:$L(SCODE,";") S FQL=0 D Q:FQL
. S LBRS=$P(SCODE,";",LI),ROK=1,RES=0
. NEW LCOD,LCODU,LCODP
. ; Set code exactly, set code uppercase, set code no punctuation
. S LCOD=$P(LBRS,":",1),LCODU=$$UP^XLFSTR(LCOD),LCODP=$$PUNC^BQIUL3(LCOD)
. ; Set value exactly, set value uppercase, set value no punctuation
. S LVAL=$P(LBRS,":",2),LVALU=$$UP^XLFSTR(LVAL),LVALP=$$PUNC^BQIUL3(LVAL)
. ;
. ; If the set code matches the actual lab result
. I SETLAB=LCOD D Q
.. I LBRES=LCOD S LOK=1,RES=1,FQL=1 Q
.. I LURES=LCODU S LOK=1,RES=1,FQL=1 Q
.. I LBURNP=LCODP S LOK=1,RES=1,FQL=1 Q
.. I LBRES=LVAL S LOK=1,RES=1,FQL=1 Q
.. I LURES=LVALU S LOK=1,RES=1,FQL=1 Q
.. I LBURNP=LVALP S LOK=1,RES=1,FQL=1 Q
Q
;
LSET(LN) ;EP - Set of codes for lab test
NEW VALUE,TYP
I $G(^LAB(60,LN,0))="" Q VALUE
S TYP=$P(^LAB(60,LN,0),"^",12),VALUE=""
I TYP'="" D
. NEW FLD,TEST
. S FLD=$P(TYP,",",2)
. D FIELD^DID(63.04,FLD,"","*","TEST")
. S VALUE=$G(TEST("POINTER"))
Q VALUE
;
MED(FGLOB,TGLOB,MED,MEDTX,FDT,TDT,MNOT,MPARMS) ;EP - Medication search
NEW MDPT,TREF,MTAX,NGLOB,MIEN,MCT,CT
S NGLOB=$NA(^TMP("BQIDCMED",$J)) K @NGLOB
I $G(TGLOB)="" Q
I $G(MED)'="" D MD
I $G(MEDTX)'="" D
. S TREF=$NA(MPARMS("MED"))
. K @TREF
. S MTAX=$P(@("^"_$P(MEDTX,";",2)_$P(MEDTX,";",1)_",0)"),"^",1)
. D BLD^BQITUTL(MTAX,TREF)
I MDOP="!" D
. I $D(MPARMS("MED")) S MED="" F S MED=$O(MPARMS("MED",MED)) Q:MED="" D MD
I MDOP="&" D
. K MDPT
. S MED="",CT=0 F S MED=$O(MPARMS("MED",MED)) Q:MED="" D MD S CT=CT+1
. S IEN=""
. F S IEN=$O(MDPT(IEN)) Q:IEN="" D
.. S MCT=0,MD=""
.. F S MD=$O(MDPT(IEN,MD)) Q:MD="" S MCT=MCT+1
.. I MCT=CT,'MNOT D
... S @TGLOB@(IEN)=""
... F S MD=$O(MDPT(IEN,MD)) Q:MD="" S MIEN=MDPT(IEN,MD),@CRIT@("MED",IEN,MIEN)=""
.. I MCT=CT,MNOT S @NGLOB@(IEN)="" K @CRIT@("MED",IEN)
;
I MNOT,$G(FGLOB)'="" D
. S IEN="" F S IEN=$O(@FGLOB@(IEN)) Q:IEN="" D
.. I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
I MNOT,$G(FGLOB)="" D
. S IEN=0 F S IEN=$O(^AUPNPAT(IEN)) Q:'IEN I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
K @NGLOB
Q
;
MD ;EP
NEW DFN,IEN
S TDT=$S(TDT'="":TDT,1:DT)
I $G(FGLOB)'="" D Q
. NEW IEN,MDP
. S IEN=""
. F S IEN=$O(@FGLOB@(IEN)) Q:'IEN D
.. I FDT="" D
... S BDT=""
... F S BDT=$O(^AUPNVMED("AA",IEN,BDT)) Q:BDT="" D MDDT
.. I FDT'="" D
... S BGT=9999999-FDT,ENT=9999999-TDT,BDT=ENT-1
... F S BDT=$O(^AUPNVMED("AA",IEN,BDT)) Q:BDT=""!(BDT>BGT) D MDDT
;
S IEN=""
F S IEN=$O(^AUPNVMED("B",MED,IEN)) Q:IEN="" D
. I $G(^AUPNVMED(IEN,0))="" Q
. S DFN=$P(^AUPNVMED(IEN,0),U,2),VIS=$P(^AUPNVMED(IEN,0),U,3) I VIS="" Q
. I $G(^AUPNVSIT(VIS,0))="" Q
. Q:"DXCT"[$P(^AUPNVSIT(VIS,0),U,7)
. S VSDTM=$P(^AUPNVSIT(VIS,0),U,1)\1
. I FDT'="",VSDTM<FDT!(VSDTM>TDT) Q
. I DFN'="",MDOP="!",MNOT S @NGLOB@(DFN)="" Q
. I DFN'="",MDOP="!",'MNOT S @TGLOB@(DFN)="",@CRIT@("MED",DFN,IEN)="" Q
. I DFN'="",MDOP="&" S MDPT(DFN,MED)=IEN
Q
;
MDDT ; EP
S MIEN=""
F S MIEN=$O(^AUPNVMED("AA",IEN,BDT,MIEN)) Q:MIEN="" D
. S MDP=$P($G(^AUPNVMED(MIEN,0)),U,1)
. I MDOP="!",MDP=MED,MNOT S @NGLOB@(IEN)="" Q
. I MDOP="!",MDP=MED,'MNOT S @TGLOB@(IEN)="",@CRIT@("MED",IEN,MIEN)="" Q
. I MDOP="&",MDP=MED S MDPT(IEN,MED)=MIEN
Q
;
CPT(FGLOB,TGLOB,CPT,CPTTX,FDT,TDT,CNOT,MPARMS) ;EP - CPT test search
NEW CPPT,CTAX,TREF,NGLOB,LCT,CT,IEN
S NGLOB=$NA(^TMP("BQIDCCPT",$J)) K @NGLOB
I $G(TGLOB)="" Q
I $G(CPT)'="" D CP
I $G(CPTTX)'="" D
. S TREF=$NA(MPARMS("CPT"))
. K @TREF
. S CTAX=$P(@("^"_$P(CPTTX,";",2)_$P(CPTTX,";",1)_",0)"),"^",1)
. D BLD^BQITUTL(CTAX,TREF)
I CPOP="!" D
. I $D(MPARMS("CPT")) S CPT="" F S CPT=$O(MPARMS("CPT",CPT)) Q:CPT="" D CP
I CPOP="&" D
. K CPPT
. S CPT="",CT=0 F S CPT=$O(MPARMS("CPT",CPT)) Q:CPT="" D CP S CT=CT+1
. S IEN=""
. F S IEN=$O(CPPT(IEN)) Q:IEN="" D
.. S LCT=0,LB=""
.. F S LB=$O(CPPT(IEN,LB)) Q:LB="" S LCT=LCT+1
.. I LCT'=CT K CPPT(IEN),@CRIT@("CPT",IEN) Q
.. I LCT=CT,'CNOT S @TGLOB@(IEN)="" Q
.. I LCT=CT,CNOT S @NGLOB@(IEN)="" K @CRIT@("CPT",IEN)
;
I CNOT,$G(FGLOB)'="" D
. S IEN="" F S IEN=$O(@FGLOB@(IEN)) Q:IEN="" D
.. I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
I CNOT,$G(FGLOB)="" D
. S IEN=0 F S IEN=$O(^AUPNPAT(IEN)) Q:'IEN I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
K @NGLOB
Q
;
CP ;EP
NEW DFN,IEN
S TDT=$S(TDT'="":TDT,1:DT)
I $G(FGLOB)'="" D Q
. NEW IEN
. S IEN=""
. F S IEN=$O(@FGLOB@(IEN)) Q:'IEN D
.. I $O(^AUPNVCPT("AA",IEN,CPT,""))="" Q
.. I FDT="" D
... S BDT=""
... F S BDT=$O(^AUPNVCPT("AA",IEN,CPT,BDT)) Q:BDT="" D CPDT
.. I FDT'="" D
... S BGT=9999999-FDT,ENT=9999999-TDT,BDT=ENT-1
... F S BDT=$O(^AUPNVCPT("AA",IEN,CPT,BDT)) Q:BDT=""!(BDT>BGT) D CPDT
;
S IEN=""
F S IEN=$O(^AUPNVCPT("B",CPT,IEN)) Q:IEN="" D
. I $G(^AUPNVCPT(IEN,0))="" Q
. S DFN=$P($G(^AUPNVCPT(IEN,0)),U,2),VIS=$P(^AUPNVCPT(IEN,0),U,3) I VIS="" Q
. I $G(^AUPNVSIT(VIS,0))="" Q
. Q:"DXCT"[$P(^AUPNVSIT(VIS,0),U,7)
. S VSDTM=$P(^AUPNVSIT(VIS,0),U,1)\1
. I FDT'="",VSDTM<FDT!(VSDTM>TDT) Q
. I DFN'="",CPOP="!",'CNOT S @TGLOB@(DFN)="",@CRIT@("CPT",DFN,IEN)="" Q
. I DFN'="",CPOP="!",CNOT S @NGLOB@(DFN)="" Q
. I DFN'="",CPOP="&" S CPPT(DFN,CPT)=IEN
;
Q
;
CPDT ;EP
S LIEN=""
F S LIEN=$O(^AUPNVCPT("AA",IEN,CPT,BDT,LIEN)) Q:LIEN="" D
. S VIS=$P($G(^AUPNVCPT(LIEN,0)),U,3) I VIS="" Q
. I $G(^AUPNVSIT(VIS,0))="" Q
. Q:"DXCT"[$P(^AUPNVSIT(VIS,0),U,7)
. I CPOP="!",'CNOT S @TGLOB@(IEN)=LIEN,@CRIT@("CPT",IEN,LIEN)="" Q
. I CPOP="!",CNOT S @NGLOB@(IEN)="" Q
. I CPOP="&" S CPPT(IEN,CPT)=LIEN
Q
BQIDCAH3 ;VNGT/HS/ALA-Ad Hoc continued ; 22 Apr 2011 12:02 PM
+1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
+2 ;
LAB(FGLOB,TGLOB,LAB,LABTX,FDT,TDT,LNOT,MPARMS,MAPARMS) ;EP - Lab test search
+1 NEW LTAX,TREF,NGLOB,LCT,CT,IEN,RVAL,LB
+2 SET NGLOB=$NAME(^TMP("BQIDCLAB",$JOB))
KILL @NGLOB
+3 KILL LBPT
+4 IF $GET(TGLOB)=""
QUIT
+5 IF $DATA(APARMS)!($DATA(MAPARMS))
Begin DoDot:1
+6 IF LBOP="!"
Begin DoDot:2
+7 SET LAB=""
+8 FOR
SET LAB=$ORDER(APARMS("LAB",LAB))
IF LAB=""
QUIT
Begin DoDot:3
+9 SET RVAL=$ORDER(APARMS("LAB",LAB,""))
+10 IF RVAL="NUMLAB"
SET NUMLAB=APARMS("LAB",LAB,"NUMLAB")
+11 IF RVAL="SETLAB"
SET SETLAB=APARMS("LAB",LAB,"SETLAB")
+12 DO LB
End DoDot:3
+13 SET LAB=""
+14 FOR
SET LAB=$ORDER(MAPARMS("LAB",LAB))
IF LAB=""
QUIT
DO LB
End DoDot:2
+15 IF LBOP="&"
Begin DoDot:2
+16 ;K LBPT
+17 SET LAB=""
SET CT=0
+18 FOR
SET LAB=$ORDER(APARMS("LAB",LAB))
IF LAB=""
QUIT
Begin DoDot:3
+19 SET RVAL=$ORDER(APARMS("LAB",LAB,""))
+20 IF RVAL="NUMLAB"
SET NUMLAB=APARMS("LAB",LAB,"NUMLAB")
+21 IF RVAL="SETLAB"
SET SETLAB=APARMS("LAB",LAB,"SETLAB")
+22 DO LB
End DoDot:3
SET CT=CT+1
+23 SET LAB=""
+24 FOR
SET LAB=$ORDER(MAPARMS("LAB",LAB))
IF LAB=""
QUIT
DO LB
+25 SET LAB=""
KILL NUMLAB,SETLAB
+26 FOR
SET LAB=$ORDER(MPARMS("LAB",LAB))
IF LAB=""
QUIT
Begin DoDot:3
+27 IF '$DATA(APARMS("LAB",LAB))
SET CT=CT+1
+28 IF '$DATA(APARMS("LAB",LAB))
DO LB
End DoDot:3
+29 SET IEN=""
+30 FOR
SET IEN=$ORDER(LBPT(IEN))
IF IEN=""
QUIT
Begin DoDot:3
+31 SET LCT=0
SET LB=""
+32 FOR
SET LB=$ORDER(LBPT(IEN,LB))
IF LB=""
QUIT
SET LCT=LCT+1
+33 IF LCT=CT
IF 'LNOT
Begin DoDot:4
+34 SET @TGLOB@(IEN)=""
SET LB=""
+35 FOR
SET LB=$ORDER(LBPT(IEN,LB))
IF LB=""
QUIT
Begin DoDot:5
+36 SET LIEN=""
+37 FOR
SET LIEN=$ORDER(LBPT(IEN,LB,LIEN))
IF LIEN=""
QUIT
SET @CRIT@("LAB",IEN,LIEN)=""
End DoDot:5
End DoDot:4
+38 IF LCT=CT
IF LNOT
SET @NGLOB@(IEN)=""
KILL @CRIT@("LAB",IEN)
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+39 IF $GET(LAB)'=""
DO LB
+40 IF $GET(LABTX)'=""
Begin DoDot:1
+41 SET TREF=$NAME(MPARMS("LAB"))
+42 KILL @TREF
+43 SET LTAX=$PIECE(@("^"_$PIECE(LABTX,";",2)_$PIECE(LABTX,";",1)_",0)"),"^",1)
+44 IF LABTX["ATXAX"
DO BLD^BQITUTL(LTAX,TREF)
+45 IF LABTX["ATXLAB"
DO BLD^BQITUTL(LTAX,TREF,"L")
End DoDot:1
+46 IF LBOP="!"
Begin DoDot:1
+47 IF $DATA(MPARMS("LAB"))
SET LAB=""
FOR
SET LAB=$ORDER(MPARMS("LAB",LAB))
IF LAB=""
QUIT
DO LB
End DoDot:1
+48 IF LBOP="&"
Begin DoDot:1
+49 KILL LBPT
+50 SET LAB=""
SET CT=0
FOR
SET LAB=$ORDER(MPARMS("LAB",LAB))
IF LAB=""
QUIT
DO LB
SET CT=CT+1
+51 SET IEN=""
+52 FOR
SET IEN=$ORDER(LBPT(IEN))
IF IEN=""
QUIT
Begin DoDot:2
+53 SET LCT=0
SET LB=""
+54 FOR
SET LB=$ORDER(LBPT(IEN,LB))
IF LB=""
QUIT
SET LCT=LCT+1
+55 IF LCT=CT
IF 'LNOT
Begin DoDot:3
+56 SET @TGLOB@(IEN)=""
SET LB=""
+57 FOR
SET LB=$ORDER(LBPT(IEN,LB))
IF LB=""
QUIT
Begin DoDot:4
+58 SET LIEN=""
+59 FOR
SET LIEN=$ORDER(LBPT(IEN,LB,LIEN))
IF LIEN=""
QUIT
SET @CRIT@("LAB",IEN,LIEN)=""
End DoDot:4
End DoDot:3
+60 IF LCT=CT
IF LNOT
SET @NGLOB@(IEN)=""
KILL @CRIT@("LAB",IEN)
End DoDot:2
End DoDot:1
+61 ;
+62 IF LNOT
IF $GET(FGLOB)'=""
Begin DoDot:1
+63 SET IEN=""
FOR
SET IEN=$ORDER(@FGLOB@(IEN))
IF IEN=""
QUIT
Begin DoDot:2
+64 IF '$DATA(@NGLOB@(IEN))
SET @TGLOB@(IEN)=""
End DoDot:2
End DoDot:1
+65 IF LNOT
IF $GET(FGLOB)=""
Begin DoDot:1
+66 SET IEN=0
FOR
SET IEN=$ORDER(^AUPNPAT(IEN))
IF 'IEN
QUIT
IF '$DATA(@NGLOB@(IEN))
SET @TGLOB@(IEN)=""
End DoDot:1
+67 KILL @NGLOB
+68 QUIT
+69 ;
LB ;EP
+1 NEW DFN,IEN,LBRES,RES,LOK,LURES,LBURNP
+2 SET TDT=$SELECT(TDT'="":TDT,1:DT)
+3 IF $GET(FGLOB)'=""
Begin DoDot:1
+4 NEW IEN
+5 SET IEN=""
+6 FOR
SET IEN=$ORDER(@FGLOB@(IEN))
IF 'IEN
QUIT
Begin DoDot:2
+7 IF $ORDER(^AUPNVLAB("AA",IEN,LAB,""))=""
QUIT
+8 IF FDT=""
Begin DoDot:3
+9 SET BDT=""
+10 FOR
SET BDT=$ORDER(^AUPNVLAB("AA",IEN,LAB,BDT))
IF BDT=""
QUIT
DO LBDT
End DoDot:3
+11 IF FDT'=""
Begin DoDot:3
+12 SET BGT=9999999-FDT
SET ENT=9999999-TDT
SET BDT=ENT-1
+13 FOR
SET BDT=$ORDER(^AUPNVLAB("AA",IEN,LAB,BDT))
IF BDT=""!(BDT>BGT)
QUIT
DO LBDT
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+14 ;
+15 SET IEN=""
+16 FOR
SET IEN=$ORDER(^AUPNVLAB("B",LAB,IEN))
IF IEN=""
QUIT
Begin DoDot:1
+17 IF $GET(^AUPNVLAB(IEN,0))=""
QUIT
+18 SET DFN=$PIECE($GET(^AUPNVLAB(IEN,0)),U,2)
SET VIS=$PIECE(^AUPNVLAB(IEN,0),U,3)
IF VIS=""
QUIT
+19 IF $GET(^AUPNVSIT(VIS,0))=""
QUIT
+20 IF "DXCT"[$PIECE(^AUPNVSIT(VIS,0),U,7)
QUIT
+21 SET VSDTM=$PIECE(^AUPNVSIT(VIS,0),U,1)\1
+22 IF FDT'=""
IF VSDTM<FDT!(VSDTM>TDT)
QUIT
+23 SET LBRES=$PIECE($GET(^AUPNVLAB(IEN,0)),U,4)
SET LURES=$$UP^XLFSTR(LBRES)
+24 SET LBRSN=$$PUNC^BQIUL3(LBRES)
SET LBURNP=$$PUNC^BQIUL3(LURES)
+25 ; If looking for a lab result
+26 SET RES=0
+27 IF $GET(SETLAB)=""
IF $GET(NUMLAB)=""
IF '$DATA(MAPARMS("LAB",LAB,"SETLAB"))
IF '$DATA(MAPARMS("LAB",LAB,"NUMLAB"))
SET ROK=0
SET RES=1
SET LOK=1
+28 IF $GET(SETLAB)'=""!($GET(NUMLAB)'="")!($DATA(MAPARMS("LAB",LAB,"SETLAB")))!($DATA(MAPARMS("LAB",LAB,"NUMLAB")))
SET ROK=1
SET LOK=0
DO LBR
+29 IF LBOP="!"
IF 'LNOT
Begin DoDot:2
+30 IF ROK
IF 'RES
QUIT
+31 SET @TGLOB@(DFN)=""
+32 IF LOK
SET @CRIT@("LAB",DFN,IEN)=""
End DoDot:2
QUIT
+33 IF LBOP="!"
IF LNOT
Begin DoDot:2
+34 IF ROK
IF 'RES
QUIT
+35 SET @NGLOB@(DFN)=""
+36 IF LOK
SET @CRIT@("LAB",DFN,IEN)=""
End DoDot:2
QUIT
+37 IF LBOP="&"
Begin DoDot:2
+38 IF ROK
IF 'RES
QUIT
+39 ;S LBPT(DFN,LAB,IEN)=IEN_U_LBRES B
+40 SET LBPT(DFN,LAB,IEN)=""
+41 IF LOK
SET @CRIT@("LAB",DFN,IEN)=""
End DoDot:2
QUIT
End DoDot:1
+42 ;
+43 QUIT
+44 ;
LBDT ;EP - Date search
+1 SET LIEN=""
+2 FOR
SET LIEN=$ORDER(^AUPNVLAB("AA",IEN,LAB,BDT,LIEN))
IF LIEN=""
QUIT
Begin DoDot:1
+3 SET VIS=$PIECE($GET(^AUPNVLAB(LIEN,0)),U,3)
IF VIS=""
QUIT
+4 IF $GET(^AUPNVSIT(VIS,0))=""
QUIT
+5 IF "DXCT"[$PIECE(^AUPNVSIT(VIS,0),U,7)
QUIT
+6 SET LBRES=$PIECE($GET(^AUPNVLAB(LIEN,0)),U,4)
SET LURES=$$UP^XLFSTR(LBRES)
+7 SET LBRSN=$$PUNC^BQIUL3(LBRES)
SET LBURNP=$$PUNC^BQIUL3(LURES)
+8 ; If looking for a lab result
+9 SET RES=0
+10 IF $GET(SETLAB)=""
IF $GET(NUMLAB)=""
IF '$DATA(MAPARMS("LAB",LAB,"SETLAB"))
IF '$DATA(MAPARMS("LAB",LAB,"NUMLAB"))
SET ROK=0
SET RES=1
SET LOK=1
+11 IF $GET(SETLAB)'=""!($GET(NUMLAB)'="")!($DATA(MAPARMS("LAB",LAB,"SETLAB")))!($DATA(MAPARMS("LAB",LAB,"NUMLAB")))
SET ROK=1
SET LOK=0
DO LBR
+12 IF LBOP="!"
IF 'LNOT
Begin DoDot:2
+13 IF ROK
IF 'RES
QUIT
+14 SET @TGLOB@(IEN)=""
+15 IF LOK
SET @CRIT@("LAB",IEN,LIEN)=""
End DoDot:2
QUIT
+16 IF LBOP="!"
IF LNOT
Begin DoDot:2
+17 IF ROK
IF 'RES
QUIT
+18 SET @NGLOB@(IEN)=""
+19 IF LOK
SET @CRIT@("LAB",IEN,LIEN)=""
End DoDot:2
QUIT
+20 IF LBOP="&"
Begin DoDot:2
+21 IF ROK
IF 'RES
QUIT
+22 ;S LBPT(IEN,LAB)=LIEN_U_LBRES
+23 SET LBPT(IEN,LAB,LIEN)=""
+24 IF LOK
SET @CRIT@("LAB",IEN,LIEN)=""
End DoDot:2
QUIT
End DoDot:1
+25 QUIT
+26 ;
LBR ;EP - Lab results
+1 IF LBRES=""
QUIT
+2 NEW LBR,VCRIT1,VCRIT2,ROPER,OPER,OPER2,RES1,RES2,SCODE,LI,LBRS,FQL
+3 IF $GET(SETLAB)'=""
IF LBRES=SETLAB
SET LOK=1
SET RES=1
QUIT
+4 IF $GET(SETLAB)'=""
IF LBRES'=SETLAB
Begin DoDot:1
+5 IF SETLAB=LURES
SET LOK=1
SET RES=1
QUIT
+6 SET SCODE=$$LSET(LAB)
+7 DO SCD
End DoDot:1
QUIT
+8 ;
+9 ;I $G(SETLAB)'="",'$D(MAPARMS("LAB",LAB,"SETLAB")),LBRES=$P(SCODE,":",1)!(LBRES=$P(SCODE,":",2)) S LOK=1,RES=1 Q
+10 IF $DATA(MAPARMS("LAB",LAB,"SETLAB"))
Begin DoDot:1
+11 SET LBR=""
FOR
SET LBR=$ORDER(MAPARMS("LAB",LAB,"SETLAB",LBR))
IF LBR=""
QUIT
Begin DoDot:2
+12 IF LBRES=LBR
SET LOK=1
SET RES=1
QUIT
+13 SET SCODE=$$LSET(LAB)
+14 NEW SETLAB
+15 SET SETLAB=LBR
DO SCD
End DoDot:2
IF LOK
QUIT
End DoDot:1
QUIT
+16 ;
+17 IF $GET(NUMLAB)'=""
Begin DoDot:1
+18 ;NEW REX,R
+19 ;S R=0,REX=0 F S R=$O(^BQICARE(OWNR,1,PLIEN,5,R)) Q:'R I ^BQICARE(OWNR,1,PLIEN,5,R,0)["exclusive" S REX=1
+20 NEW REX
+21 IF NUMLAB["~"
SET REX=1
+22 IF NUMLAB["~"
IF NUMLAB["'"
SET REX=0
+23 IF LBRES?.ULP
QUIT
+24 IF LBRES'?.PN
IF LBRES'?.N
QUIT
+25 IF $EXTRACT(LBRES,$LENGTH(LBRES),$LENGTH(LBRES))?.P
SET LBRES=$EXTRACT(LBRES,1,$LENGTH(LBRES)-1)
+26 ; if value starts with a punctuation e.g. < or >
+27 IF $EXTRACT(LBRES,1,1)?.P
SET ROPER=$EXTRACT(LBRES,1,1)
SET LBRES=$EXTRACT(LBRES,2,$LENGTH(LBRES))
+28 IF NUMLAB["~"
SET VCRIT1=$PIECE(NUMLAB,"~",1)
SET VCRIT2=$PIECE(NUMLAB,"~",2)
+29 IF '$TEST
SET VCRIT1=NUMLAB
SET VCRIT2=""
+30 FOR I=1:1:$LENGTH(VCRIT1)
IF $EXTRACT(VCRIT1,I,I)'?.P
QUIT
+31 SET OPER=$EXTRACT(VCRIT1,1,I-1)
SET RES1=$EXTRACT(VCRIT1,I,$LENGTH(VCRIT1))
+32 IF $EXTRACT(OPER,$LENGTH(OPER),$LENGTH(OPER))="."
Begin DoDot:2
+33 SET OPER=$EXTRACT(OPER,1,$LENGTH(OPER)-1)
SET RES1="."_RES1
End DoDot:2
+34 IF $GET(VCRIT2)'=""
Begin DoDot:2
+35 FOR I=1:1:$LENGTH(VCRIT2)
IF $EXTRACT(VCRIT2,I,I)'?.P
QUIT
+36 SET OPER2=$EXTRACT(VCRIT2,1,I-1)
SET RES2=$EXTRACT(VCRIT2,I,$LENGTH(VCRIT2))
+37 IF $EXTRACT(OPER2,$LENGTH(OPER2),$LENGTH(OPER2))="."
Begin DoDot:3
+38 SET OPER2=$EXTRACT(OPER2,1,$LENGTH(OPER2)-1)
SET RES2="."_RES2
End DoDot:3
End DoDot:2
+39 IF VCRIT2=""
Begin DoDot:2
+40 IF $GET(ROPER)=""
IF @("LBRES"_OPER_"RES1")
SET LOK=1
SET RES=1
QUIT
+41 IF $GET(ROPER)'=""
IF OPER=ROPER
IF @("LBRES"_OPER_"RES1")
SET LOK=1
SET RES=1
QUIT
+42 IF $GET(ROPER)'=""
IF OPER'=ROPER
QUIT
End DoDot:2
+43 IF VCRIT2'=""
Begin DoDot:2
+44 IF @("LBRES"_OPER_"RES1")
IF @("LBRES"_OPER2_"RES2")
SET LOK=1
SET RES=1
+45 IF REX
Begin DoDot:3
+46 IF @("LBRES"_OPER_"RES1")
SET LOK=1
SET RES=1
+47 IF @("LBRES"_OPER2_"RES2")
SET LOK=1
SET RES=1
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+48 QUIT
+49 ;
SCD ;EP
+1 NEW LCOD,LCODU,LCODP,LVAL,LVALU,LVALP
+2 FOR LI=1:1:$LENGTH(SCODE,";")
SET FQL=0
Begin DoDot:1
+3 SET LBRS=$PIECE(SCODE,";",LI)
SET ROK=1
SET RES=0
+4 NEW LCOD,LCODU,LCODP
+5 ; Set code exactly, set code uppercase, set code no punctuation
+6 SET LCOD=$PIECE(LBRS,":",1)
SET LCODU=$$UP^XLFSTR(LCOD)
SET LCODP=$$PUNC^BQIUL3(LCOD)
+7 ; Set value exactly, set value uppercase, set value no punctuation
+8 SET LVAL=$PIECE(LBRS,":",2)
SET LVALU=$$UP^XLFSTR(LVAL)
SET LVALP=$$PUNC^BQIUL3(LVAL)
+9 ;
+10 ; If the set code matches the actual lab result
+11 IF SETLAB=LCOD
Begin DoDot:2
+12 IF LBRES=LCOD
SET LOK=1
SET RES=1
SET FQL=1
QUIT
+13 IF LURES=LCODU
SET LOK=1
SET RES=1
SET FQL=1
QUIT
+14 IF LBURNP=LCODP
SET LOK=1
SET RES=1
SET FQL=1
QUIT
+15 IF LBRES=LVAL
SET LOK=1
SET RES=1
SET FQL=1
QUIT
+16 IF LURES=LVALU
SET LOK=1
SET RES=1
SET FQL=1
QUIT
+17 IF LBURNP=LVALP
SET LOK=1
SET RES=1
SET FQL=1
QUIT
End DoDot:2
QUIT
End DoDot:1
IF FQL
QUIT
+18 QUIT
+19 ;
LSET(LN) ;EP - Set of codes for lab test
+1 NEW VALUE,TYP
+2 IF $GET(^LAB(60,LN,0))=""
QUIT VALUE
+3 SET TYP=$PIECE(^LAB(60,LN,0),"^",12)
SET VALUE=""
+4 IF TYP'=""
Begin DoDot:1
+5 NEW FLD,TEST
+6 SET FLD=$PIECE(TYP,",",2)
+7 DO FIELD^DID(63.04,FLD,"","*","TEST")
+8 SET VALUE=$GET(TEST("POINTER"))
End DoDot:1
+9 QUIT VALUE
+10 ;
MED(FGLOB,TGLOB,MED,MEDTX,FDT,TDT,MNOT,MPARMS) ;EP - Medication search
+1 NEW MDPT,TREF,MTAX,NGLOB,MIEN,MCT,CT
+2 SET NGLOB=$NAME(^TMP("BQIDCMED",$JOB))
KILL @NGLOB
+3 IF $GET(TGLOB)=""
QUIT
+4 IF $GET(MED)'=""
DO MD
+5 IF $GET(MEDTX)'=""
Begin DoDot:1
+6 SET TREF=$NAME(MPARMS("MED"))
+7 KILL @TREF
+8 SET MTAX=$PIECE(@("^"_$PIECE(MEDTX,";",2)_$PIECE(MEDTX,";",1)_",0)"),"^",1)
+9 DO BLD^BQITUTL(MTAX,TREF)
End DoDot:1
+10 IF MDOP="!"
Begin DoDot:1
+11 IF $DATA(MPARMS("MED"))
SET MED=""
FOR
SET MED=$ORDER(MPARMS("MED",MED))
IF MED=""
QUIT
DO MD
End DoDot:1
+12 IF MDOP="&"
Begin DoDot:1
+13 KILL MDPT
+14 SET MED=""
SET CT=0
FOR
SET MED=$ORDER(MPARMS("MED",MED))
IF MED=""
QUIT
DO MD
SET CT=CT+1
+15 SET IEN=""
+16 FOR
SET IEN=$ORDER(MDPT(IEN))
IF IEN=""
QUIT
Begin DoDot:2
+17 SET MCT=0
SET MD=""
+18 FOR
SET MD=$ORDER(MDPT(IEN,MD))
IF MD=""
QUIT
SET MCT=MCT+1
+19 IF MCT=CT
IF 'MNOT
Begin DoDot:3
+20 SET @TGLOB@(IEN)=""
+21 FOR
SET MD=$ORDER(MDPT(IEN,MD))
IF MD=""
QUIT
SET MIEN=MDPT(IEN,MD)
SET @CRIT@("MED",IEN,MIEN)=""
End DoDot:3
+22 IF MCT=CT
IF MNOT
SET @NGLOB@(IEN)=""
KILL @CRIT@("MED",IEN)
End DoDot:2
End DoDot:1
+23 ;
+24 IF MNOT
IF $GET(FGLOB)'=""
Begin DoDot:1
+25 SET IEN=""
FOR
SET IEN=$ORDER(@FGLOB@(IEN))
IF IEN=""
QUIT
Begin DoDot:2
+26 IF '$DATA(@NGLOB@(IEN))
SET @TGLOB@(IEN)=""
End DoDot:2
End DoDot:1
+27 IF MNOT
IF $GET(FGLOB)=""
Begin DoDot:1
+28 SET IEN=0
FOR
SET IEN=$ORDER(^AUPNPAT(IEN))
IF 'IEN
QUIT
IF '$DATA(@NGLOB@(IEN))
SET @TGLOB@(IEN)=""
End DoDot:1
+29 KILL @NGLOB
+30 QUIT
+31 ;
MD ;EP
+1 NEW DFN,IEN
+2 SET TDT=$SELECT(TDT'="":TDT,1:DT)
+3 IF $GET(FGLOB)'=""
Begin DoDot:1
+4 NEW IEN,MDP
+5 SET IEN=""
+6 FOR
SET IEN=$ORDER(@FGLOB@(IEN))
IF 'IEN
QUIT
Begin DoDot:2
+7 IF FDT=""
Begin DoDot:3
+8 SET BDT=""
+9 FOR
SET BDT=$ORDER(^AUPNVMED("AA",IEN,BDT))
IF BDT=""
QUIT
DO MDDT
End DoDot:3
+10 IF FDT'=""
Begin DoDot:3
+11 SET BGT=9999999-FDT
SET ENT=9999999-TDT
SET BDT=ENT-1
+12 FOR
SET BDT=$ORDER(^AUPNVMED("AA",IEN,BDT))
IF BDT=""!(BDT>BGT)
QUIT
DO MDDT
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+13 ;
+14 SET IEN=""
+15 FOR
SET IEN=$ORDER(^AUPNVMED("B",MED,IEN))
IF IEN=""
QUIT
Begin DoDot:1
+16 IF $GET(^AUPNVMED(IEN,0))=""
QUIT
+17 SET DFN=$PIECE(^AUPNVMED(IEN,0),U,2)
SET VIS=$PIECE(^AUPNVMED(IEN,0),U,3)
IF VIS=""
QUIT
+18 IF $GET(^AUPNVSIT(VIS,0))=""
QUIT
+19 IF "DXCT"[$PIECE(^AUPNVSIT(VIS,0),U,7)
QUIT
+20 SET VSDTM=$PIECE(^AUPNVSIT(VIS,0),U,1)\1
+21 IF FDT'=""
IF VSDTM<FDT!(VSDTM>TDT)
QUIT
+22 IF DFN'=""
IF MDOP="!"
IF MNOT
SET @NGLOB@(DFN)=""
QUIT
+23 IF DFN'=""
IF MDOP="!"
IF 'MNOT
SET @TGLOB@(DFN)=""
SET @CRIT@("MED",DFN,IEN)=""
QUIT
+24 IF DFN'=""
IF MDOP="&"
SET MDPT(DFN,MED)=IEN
End DoDot:1
+25 QUIT
+26 ;
MDDT ; EP
+1 SET MIEN=""
+2 FOR
SET MIEN=$ORDER(^AUPNVMED("AA",IEN,BDT,MIEN))
IF MIEN=""
QUIT
Begin DoDot:1
+3 SET MDP=$PIECE($GET(^AUPNVMED(MIEN,0)),U,1)
+4 IF MDOP="!"
IF MDP=MED
IF MNOT
SET @NGLOB@(IEN)=""
QUIT
+5 IF MDOP="!"
IF MDP=MED
IF 'MNOT
SET @TGLOB@(IEN)=""
SET @CRIT@("MED",IEN,MIEN)=""
QUIT
+6 IF MDOP="&"
IF MDP=MED
SET MDPT(IEN,MED)=MIEN
End DoDot:1
+7 QUIT
+8 ;
CPT(FGLOB,TGLOB,CPT,CPTTX,FDT,TDT,CNOT,MPARMS) ;EP - CPT test search
+1 NEW CPPT,CTAX,TREF,NGLOB,LCT,CT,IEN
+2 SET NGLOB=$NAME(^TMP("BQIDCCPT",$JOB))
KILL @NGLOB
+3 IF $GET(TGLOB)=""
QUIT
+4 IF $GET(CPT)'=""
DO CP
+5 IF $GET(CPTTX)'=""
Begin DoDot:1
+6 SET TREF=$NAME(MPARMS("CPT"))
+7 KILL @TREF
+8 SET CTAX=$PIECE(@("^"_$PIECE(CPTTX,";",2)_$PIECE(CPTTX,";",1)_",0)"),"^",1)
+9 DO BLD^BQITUTL(CTAX,TREF)
End DoDot:1
+10 IF CPOP="!"
Begin DoDot:1
+11 IF $DATA(MPARMS("CPT"))
SET CPT=""
FOR
SET CPT=$ORDER(MPARMS("CPT",CPT))
IF CPT=""
QUIT
DO CP
End DoDot:1
+12 IF CPOP="&"
Begin DoDot:1
+13 KILL CPPT
+14 SET CPT=""
SET CT=0
FOR
SET CPT=$ORDER(MPARMS("CPT",CPT))
IF CPT=""
QUIT
DO CP
SET CT=CT+1
+15 SET IEN=""
+16 FOR
SET IEN=$ORDER(CPPT(IEN))
IF IEN=""
QUIT
Begin DoDot:2
+17 SET LCT=0
SET LB=""
+18 FOR
SET LB=$ORDER(CPPT(IEN,LB))
IF LB=""
QUIT
SET LCT=LCT+1
+19 IF LCT'=CT
KILL CPPT(IEN),@CRIT@("CPT",IEN)
QUIT
+20 IF LCT=CT
IF 'CNOT
SET @TGLOB@(IEN)=""
QUIT
+21 IF LCT=CT
IF CNOT
SET @NGLOB@(IEN)=""
KILL @CRIT@("CPT",IEN)
End DoDot:2
End DoDot:1
+22 ;
+23 IF CNOT
IF $GET(FGLOB)'=""
Begin DoDot:1
+24 SET IEN=""
FOR
SET IEN=$ORDER(@FGLOB@(IEN))
IF IEN=""
QUIT
Begin DoDot:2
+25 IF '$DATA(@NGLOB@(IEN))
SET @TGLOB@(IEN)=""
End DoDot:2
End DoDot:1
+26 IF CNOT
IF $GET(FGLOB)=""
Begin DoDot:1
+27 SET IEN=0
FOR
SET IEN=$ORDER(^AUPNPAT(IEN))
IF 'IEN
QUIT
IF '$DATA(@NGLOB@(IEN))
SET @TGLOB@(IEN)=""
End DoDot:1
+28 KILL @NGLOB
+29 QUIT
+30 ;
CP ;EP
+1 NEW DFN,IEN
+2 SET TDT=$SELECT(TDT'="":TDT,1:DT)
+3 IF $GET(FGLOB)'=""
Begin DoDot:1
+4 NEW IEN
+5 SET IEN=""
+6 FOR
SET IEN=$ORDER(@FGLOB@(IEN))
IF 'IEN
QUIT
Begin DoDot:2
+7 IF $ORDER(^AUPNVCPT("AA",IEN,CPT,""))=""
QUIT
+8 IF FDT=""
Begin DoDot:3
+9 SET BDT=""
+10 FOR
SET BDT=$ORDER(^AUPNVCPT("AA",IEN,CPT,BDT))
IF BDT=""
QUIT
DO CPDT
End DoDot:3
+11 IF FDT'=""
Begin DoDot:3
+12 SET BGT=9999999-FDT
SET ENT=9999999-TDT
SET BDT=ENT-1
+13 FOR
SET BDT=$ORDER(^AUPNVCPT("AA",IEN,CPT,BDT))
IF BDT=""!(BDT>BGT)
QUIT
DO CPDT
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+14 ;
+15 SET IEN=""
+16 FOR
SET IEN=$ORDER(^AUPNVCPT("B",CPT,IEN))
IF IEN=""
QUIT
Begin DoDot:1
+17 IF $GET(^AUPNVCPT(IEN,0))=""
QUIT
+18 SET DFN=$PIECE($GET(^AUPNVCPT(IEN,0)),U,2)
SET VIS=$PIECE(^AUPNVCPT(IEN,0),U,3)
IF VIS=""
QUIT
+19 IF $GET(^AUPNVSIT(VIS,0))=""
QUIT
+20 IF "DXCT"[$PIECE(^AUPNVSIT(VIS,0),U,7)
QUIT
+21 SET VSDTM=$PIECE(^AUPNVSIT(VIS,0),U,1)\1
+22 IF FDT'=""
IF VSDTM<FDT!(VSDTM>TDT)
QUIT
+23 IF DFN'=""
IF CPOP="!"
IF 'CNOT
SET @TGLOB@(DFN)=""
SET @CRIT@("CPT",DFN,IEN)=""
QUIT
+24 IF DFN'=""
IF CPOP="!"
IF CNOT
SET @NGLOB@(DFN)=""
QUIT
+25 IF DFN'=""
IF CPOP="&"
SET CPPT(DFN,CPT)=IEN
End DoDot:1
+26 ;
+27 QUIT
+28 ;
CPDT ;EP
+1 SET LIEN=""
+2 FOR
SET LIEN=$ORDER(^AUPNVCPT("AA",IEN,CPT,BDT,LIEN))
IF LIEN=""
QUIT
Begin DoDot:1
+3 SET VIS=$PIECE($GET(^AUPNVCPT(LIEN,0)),U,3)
IF VIS=""
QUIT
+4 IF $GET(^AUPNVSIT(VIS,0))=""
QUIT
+5 IF "DXCT"[$PIECE(^AUPNVSIT(VIS,0),U,7)
QUIT
+6 IF CPOP="!"
IF 'CNOT
SET @TGLOB@(IEN)=LIEN
SET @CRIT@("CPT",IEN,LIEN)=""
QUIT
+7 IF CPOP="!"
IF CNOT
SET @NGLOB@(IEN)=""
QUIT
+8 IF CPOP="&"
SET CPPT(IEN,CPT)=LIEN
End DoDot:1
+9 QUIT
