BQICAUTL ;VNGT/HS/ALA-Utility for CA ; 29 Mar 2011 4:49 PM
;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
;
TAX(TMFRAME,TAX,NIT,PTDFN,FREF,PRB,SAME,TREF) ;EP
; Find value for a taxonomy (TAX) or list of taxonomies (TREF)
; Input
; TMFRAME - Timeframe to search for data
; TAX - Taxonomy
; NIT - Number of iterations
; PTDFN - Patient IEN
; FREF - File number reference
; PRB - If Active Problem okay
; SAME - If NIT is allowed for the same 30 days or not (1 same 30 days okay)
; TREF - Multiple same resulting taxonomies (e.g. MEDs) built
; into reference (usually global)
;
NEW RESULT,GREF,ENDT,IEN,TIEN,TEMP,QFL
S TMFRAME=$G(TMFRAME,""),NIT=$G(NIT,1),PRB=$G(PRB,0),SAME=$G(SAME,1)
S ENDT=$$DATE^BQIUL1(TMFRAME),RESULT=0,TREF=$G(TREF,""),TAX=$G(TAX,"")
I TAX'="" D
. S TREF=$NA(^TMP("BQITAX",UID))
. K @TREF
. D BLD^BQITUTL(TAX,TREF)
S GREF=$$ROOT^DILFD(FREF,"",1)
S TEMP=$NA(^TMP("BQITEMP",UID)) K @TEMP
;
I PRB D
. S IEN="",QFL=0,RESULT=0
. F S IEN=$O(^AUPNPROB("AC",PTDFN,IEN),-1) Q:IEN="" D Q:QFL
.. S TIEN=$$GET1^DIQ(9000011,IEN,.01,"I") I TIEN="" Q
.. I '$D(@TREF@(TIEN)) Q
.. ; Check class - if Family ignore
.. I $$GET1^DIQ(9000011,IEN,.04,"I")="F" Q
.. I $$GET1^DIQ(9000011,IEN,.12,"I")'="A" Q
.. S VSDTM=$$PROB^BQIUL1(IEN)\1 Q:VSDTM=0
.. I $G(TMFRAME)'="",VSDTM<ENDT Q
.. S RESULT=1_U_VSDTM,$P(RESULT,U,4)=IEN,QFL=1
;
I 'RESULT D
. S IEN="",QFL=0,RESULT=0,CT=0
. I $G(TMFRAME)'="" D
.. S EDT=9999999-ENDT,BDT=""
.. F S BDT=$O(@GREF@("AA",PTDFN,BDT)) Q:BDT=""!(BDT>EDT) D
... S IEN=""
... F S IEN=$O(@GREF@("AA",PTDFN,BDT,IEN)) Q:IEN="" D
.... S TIEN=$$GET1^DIQ(FREF,IEN,.01,"I") I TIEN="" Q
.... I '$D(@TREF@(TIEN)) Q
.... S VISIT=$$GET1^DIQ(FREF,IEN,.03,"I") I VISIT="" Q
.... I $$GET1^DIQ(9000010,VISIT,.11,"I")=1 Q
.... S VSDTM=$$GET1^DIQ(9000010,VISIT,.01,"I")\1 Q:VSDTM=0
.... ;I $G(TMFRAME)'="",VSDTM<ENDT Q
.... ; Set temporary
.... S @TEMP@(VSDTM,VISIT,IEN)=""
. ;
. I $G(TMFRAME)="" D
.. F S IEN=$O(@GREF@("AC",PTDFN,IEN),-1) Q:IEN="" D
... S TIEN=$$GET1^DIQ(FREF,IEN,.01,"I") I TIEN="" Q
... I '$D(@TREF@(TIEN)) Q
... S VISIT=$$GET1^DIQ(FREF,IEN,.03,"I") I VISIT="" Q
... I $$GET1^DIQ(9000010,VISIT,.11,"I")=1 Q
... S VSDTM=$$GET1^DIQ(9000010,VISIT,.01,"I")\1 Q:VSDTM=0
... ;I $G(TMFRAME)'="",VSDTM<ENDT Q
... ; Set temporary
... S @TEMP@(VSDTM,VISIT,IEN)=""
;
S VSDTM="",QFL=0
F S VSDTM=$O(@TEMP@(VSDTM),-1) Q:VSDTM=""!(QFL) D
. S VISIT=""
. F S VISIT=$O(@TEMP@(VSDTM,VISIT),-1) Q:VISIT="" D Q:QFL
.. S IEN=""
.. F S IEN=$O(@TEMP@(VSDTM,VISIT,IEN),-1) Q:IEN="" D Q:QFL
... ; If result cannot be within 30 days, quit
... I 'SAME,$P(RESULT,U,2)=VSDTM Q
... S CT=CT+1
... I $P(RESULT,U,2)'="",(CT'>NIT) D
.... I VSDTM'<STDT,'SAME S CT=CT-1 Q
.... S $P(RESULT,U,2)=$P(RESULT,U,2)_";"_VSDTM
.... S $P(RESULT,U,4)=$P(RESULT,U,4)_";"_VISIT
.... S $P(RESULT,U,5)=$P(RESULT,U,5)_";"_IEN
... I $P(RESULT,U,2)="" S $P(RESULT,U,2)=VSDTM,$P(RESULT,U,4)=VISIT_U_IEN
... ;S $P(RESULT,U,4)=VISIT_U_IEN,CT=CT+1
... ;S RESULT=U_VSDTM_U_U_VISIT_U_IEN,CT=CT+1
... I CT=NIT S QFL=1,$P(RESULT,U,1)=1
K @TREF
Q RESULT
;
MEAS(BQDFN,MEAS,VISIT,RESVAL,OPER) ;EP - Get measurement
I MEAS'?.N S MEAS=$$FIND1^DIC(9999999.07,,"MX",MEAS)
S VALUE=0
S VDATE=$P(^AUPNVSIT(VISIT,0),U,1)\1
S RVDT=9999999-VDATE
S IEN=""
F S IEN=$O(^AUPNVMSR("AA",BQDFN,MEAS,RVDT,IEN)) Q:IEN="" D
. S RESULT=$P($G(^AUPNVMSR(IEN,0)),"^",4) I RESULT="" Q
. I $P($G(^AUPNVMSR(IEN,2)),"^",1)=1 Q
. ; if the new ENTERED IN ERROR field exists, exclude the record if it is marked as an error
. I $$VFIELD^DILFD(9000010.01,2) Q:$$GET1^DIQ(9000010.01,IEN_",",2,"I")=1
. I @(RESULT_OPER_RESVAL) S VALUE="1^"_VDATE_U_RESULT_U_VISIT_U_IEN_U_"9000010.01"
Q VALUE
;
LAB(TMFRAME,RECENT,BQDFN,TAX,SEARCH,TREF) ;EP
; Check for a lab test result
;
; Input
; TMFRAME - Time frame to search data for
; RECENT - 1=Only check most recent lab,0=Check all within timeframe
; BQDFN - Patient internal entry number
; TAX - Lab taxonomy to search
; RESULT - Lab result to check for
; OPER - Operand to use for result check
; RES2 - If range, the other result value
; OPER2 - If range, the other result operand
; TREF - Multiple same resulting taxonomies built
; into reference (usually global)
;
NEW TEMP,EDATE,BDATE,LIEN,QFL,RES,CT,VALUE,VIEN,VSDTM
S BDATE=$$DATE^BQIUL1(TMFRAME),EDATE=DT
S TEMP=$NA(^TMP("BQITEMP",UID)) K @TEMP
S TAX=$G(TAX,""),RECENT=$G(RECENT,0)
I TAX'="" D
. S TREF=$NA(^TMP("BQITAX",UID))
. K @TREF
. D BLD^BQITUTL(TAX,TREF)
;
S LIEN="",QFL=0,RES=0_U_"No Test",CT=0
I $G(TMFRAME)'="" D
. S TIEN=""
. F S TIEN=$O(@TREF@(TIEN)) Q:TIEN="" D
.. S EDT=9999999-BDATE,BDT=(9999999-EDATE)-.001
.. I $P($G(^LAB(60,TIEN,0)),U,4)="MI" D Q
... D MIC(BQDFN,TIEN,EDT,BDT,.MICRO)
... M @TEMP=MICRO
... K MICRO
.. F S BDT=$O(^AUPNVLAB("AA",BQDFN,TIEN,BDT)) Q:BDT=""!(BDT>EDT) D
... S LIEN=""
... F S LIEN=$O(^AUPNVLAB("AA",BQDFN,TIEN,BDT,LIEN)) Q:LIEN="" D
.... S VALUE=$P(^AUPNVLAB(LIEN,0),U,4) I VALUE="" Q
.... S VIEN=$P(^AUPNVLAB(LIEN,0),U,3) I VIEN="" Q
.... S FLAG=$P($G(^AUPNVLAB(LIEN,11)),U,9) I FLAG="" Q
.... I FLAG'="R"&(FLAG'="M") Q
.... S VSDTM=$$GET1^DIQ(9000010,VIEN_",",.01,"I")\1 I VSDTM=0 Q
.... ;I $G(TMFRAME)'="",VSDTM<BDATE Q
.... ; quit if deleted flag
.... I $P($G(^AUPNVSIT(VIEN,0)),U,11)=1 Q
.... I $P($G(^AUPNVLAB(LIEN,11)),U,9)="D" Q
.... S @TEMP@(VSDTM,VIEN,LIEN)=VALUE_U_"9000010.09"_U_TIEN
;
I $G(TMFRAME)="" D
. S LIEN=""
. F S LIEN=$O(^AUPNVLAB("AC",BQDFN,LIEN),-1) Q:LIEN="" D
.. S TIEN=$P($G(^AUPNVLAB(LIEN,0)),U,1) I TIEN="" Q
.. I '$D(@TREF@(TIEN)) Q
.. S VALUE=$P(^AUPNVLAB(LIEN,0),U,4) I VALUE="" Q
.. S VIEN=$P(^AUPNVLAB(LIEN,0),U,3) I VIEN="" Q
.. S VSDTM=$$GET1^DIQ(9000010,VIEN_",",.01,"I")\1 I VSDTM=0 Q
.. ;I $G(TMFRAME)'="",VSDTM<BDATE Q
.. ; quit if deleted flag
.. I $P($G(^AUPNVSIT(VIEN,0)),U,11)=1 Q
.. I $P($G(^AUPNVLAB(LIEN,11)),U,9)="D" Q
.. S @TEMP@(VSDTM,VIEN,LIEN)=VALUE_U_"9000010.09"_U_TIEN
. F S LIEN=$O(^AUPNVMIC("AC",BQDFN,LIEN),-1) Q:LIEN="" D
.. S TIEN=$P($G(^AUPNVMIC(LIEN,0)),U,1) I TIEN="" Q
.. I '$D(@TREF@(TIEN)) Q
.. S VALUE=$P(^AUPNVMIC(LIEN,0),U,7) I VALUE="" Q
.. S VIEN=$P(^AUPNVMIC(LIEN,0),U,3) I VIEN="" Q
.. S VSDTM=$$GET1^DIQ(9000010,VIEN_",",.01,"I")\1 I VSDTM=0 Q
.. ; quit if deleted flag
.. I $P($G(^AUPNVSIT(VIEN,0)),U,11)=1 Q
.. S FLAG=$P($G(^AUPNVMIC(LIEN,11)),U,9)
.. I FLAG'="R"&(FLAG'="M") Q
.. S @TEMP@(VSDTM,VIEN,LIEN)=VALUE_U_"9000010.25"_U_TIEN
;
S VSDTM=""
F S VSDTM=$O(@TEMP@(VSDTM),-1) Q:VSDTM="" D Q:QFL
. S VIEN=$O(@TEMP@(VSDTM,""),-1),LIEN=""
. F S LIEN=$O(@TEMP@(VSDTM,VIEN,LIEN),-1) Q:LIEN=""!(QFL) D
.. S VALUE=$P(@TEMP@(VSDTM,VIEN,LIEN),U,1),OVALUE=VALUE
.. S FILE=$P(@TEMP@(VSDTM,VIEN,LIEN),U,2)
.. S TIEN=$P(@TEMP@(VSDTM,VIEN,LIEN),U,3)
.. K ROPER
.. S RN=""
.. F S RN=$O(SEARCH(RN)) Q:RN="" D Q:QFL
... S OPER=$P(SEARCH(RN),U,2),RESULT=$P(SEARCH(RN),U,1),OPER2=$P(SEARCH(RN),U,4),RES2=$P(SEARCH(RN),U,3)
... D RCHK
K @TEMP
Q RES
;
RCHK ;
I OPER="'=",RESULT="",VALUE'="" S RES=1_U_$$FMTE^BQIUL1(VSDTM)_U_VALUE_U_VIEN_U_LIEN_U_TIEN_U_FILE,QFL=1 Q
;
I RESULT'?.N,VALUE?.N Q
;
I RESULT="POS",$E(VALUE,1)'?.N,'$$POSITIVE^BQITRUTL(VALUE) Q
I RESULT="POS",$E(VALUE,1)'?.N,$$POSITIVE^BQITRUTL(VALUE) D Q
. S RES=1_U_$$FMTE^BQIUL1(VSDTM)_U_VALUE_U_VIEN_U_LIEN_U_TIEN_U_FILE,QFL=1
I RESULT="NEG",$E(VALUE,1)'?.N,'$$NEGATIVE^BQITRUTL(VALUE) Q
I RESULT="NEG",$E(VALUE,1)'?.N,$$NEGATIVE^BQITRUTL(VALUE) D
. S RES=1_U_$$FMTE^BQIUL1(VSDTM)_U_VALUE_U_VIEN_U_LIEN_U_TIEN_U_FILE,QFL=1
I VALUE'?.PN,VALUE'?.N Q
;I $E(VALUE,$L(VALUE))?.P S VALUE=VALUE_"0"
I $E(VALUE,$L(VALUE),$L(VALUE))?.P S VALUE=$E(VALUE,1,$L(VALUE)-1)
; if value starts with a punctuation e.g. < or >
I $E(VALUE,1,1)?.P S ROPER=$E(VALUE,1,1),VALUE=$E(VALUE,2,$L(VALUE))
I RES2="" D
. I $G(ROPER)="",@("VALUE"_OPER_"RESULT") D Q
.. S RES=1_U_$$FMTE^BQIUL1(VSDTM)_U_OVALUE_U_VIEN_U_LIEN_U_TIEN_U_FILE,QFL=1
. I $G(ROPER)'="",OPER=ROPER,@("VALUE"_OPER_"RESULT") D Q
.. S RES=1_U_$$FMTE^BQIUL1(VSDTM)_U_OVALUE_U_VIEN_U_LIEN_U_TIEN_U_FILE,QFL=1
. I $G(ROPER)'="",OPER'=ROPER Q
I RES2'="" D
. I @("VALUE"_OPER_"RESULT"),@("VALUE"_OPER2_"RES2") D
.. S RES=1_U_$$FMTE^BQIUL1(VSDTM)_U_OVALUE_U_VIEN_U_LIEN_U_TIEN_U_FILE,QFL=1
Q
;
MIC(BQDFN,TIEN,EDT,BDT,MICRO) ;EP - Look through Microbiology file
NEW FLAG,LIEN,VALUE,VIEN,VSDTM
K MICRO
F S BDT=$O(^AUPNVMIC("AA",BQDFN,TIEN,BDT)) Q:BDT=""!(BDT>EDT) D
. S LIEN=""
. F S LIEN=$O(^AUPNVMIC("AA",BQDFN,TIEN,BDT,LIEN)) Q:LIEN="" D
.. S VALUE=$P(^AUPNVMIC(LIEN,0),U,7) I VALUE="" Q
.. S VIEN=$P(^AUPNVMIC(LIEN,0),U,3) I VIEN="" Q
.. S VSDTM=$$GET1^DIQ(9000010,VIEN_",",.01,"I")\1 I VSDTM=0 Q
.. ; quit if deleted flag
.. I $P($G(^AUPNVSIT(VIEN,0)),U,11)=1 Q
.. S FLAG=$P($G(^AUPNVMIC(LIEN,11)),U,9)
.. I FLAG'="R"&(FLAG'="M") Q
.. S MICRO(VSDTM,VIEN,LIEN)=VALUE_U_"9000010.25"_U_TIEN
Q
;
LBB(TMFRAME,RECENT,DATE,BQDFN,TAX,SEARCH,TREF) ;EP
I $G(TMFRAME)'="" D
. I TMFRAME'["-" Q
. S TMFRAME=$P(TMFRAME,"-",2)
S BDATE=$$FMADD^XLFDT(DATE,-TMFRAME),EDATE=$$FMADD^XLFDT(DATE,TMFRAME)
S TEMP=$NA(^TMP("BQITEMP",UID)) K @TEMP
S TAX=$G(TAX,""),RECENT=$G(RECENT,0)
I TAX'="" D
. S TREF=$NA(^TMP("BQITAX",UID))
. K @TREF
. D BLD^BQITUTL(TAX,TREF)
;
S LIEN="",QFL=0,RES=0_U_"No Test",CT=0
D
. S TIEN=""
. F S TIEN=$O(@TREF@(TIEN)) Q:TIEN="" D
.. S EDT=9999999-BDATE,BDT=(9999999-EDATE)-.001
.. I $P($G(^LAB(60,TIEN,0)),U,4)="MI" D Q
... D MIC(BQDFN,TIEN,EDT,BDT,.MICRO)
... M @TEMP=MICRO
... K MICRO
.. F S BDT=$O(^AUPNVLAB("AA",BQDFN,TIEN,BDT)) Q:BDT=""!(BDT>EDT) D
... S LIEN=""
... F S LIEN=$O(^AUPNVLAB("AA",BQDFN,TIEN,BDT,LIEN)) Q:LIEN="" D
.... S VALUE=$P(^AUPNVLAB(LIEN,0),U,4) I VALUE="" Q
.... S VIEN=$P(^AUPNVLAB(LIEN,0),U,3) I VIEN="" Q
.... S FLAG=$P($G(^AUPNVLAB(LIEN,11)),U,9) I FLAG="" Q
.... I FLAG'="R"&(FLAG'="M") Q
.... S VSDTM=$$GET1^DIQ(9000010,VIEN_",",.01,"I")\1 I VSDTM=0 Q
.... ;I $G(TMFRAME)'="",VSDTM<BDATE Q
.... ; quit if deleted flag
.... I $P($G(^AUPNVSIT(VIEN,0)),U,11)=1 Q
.... I $P($G(^AUPNVLAB(LIEN,11)),U,9)="D" Q
.... S @TEMP@(VSDTM,VIEN,LIEN)=VALUE_U_"9000010.09"_U_TIEN
;
S VSDTM=""
F S VSDTM=$O(@TEMP@(VSDTM),-1) Q:VSDTM="" D Q:QFL
. S VIEN=$O(@TEMP@(VSDTM,""),-1),LIEN=""
. F S LIEN=$O(@TEMP@(VSDTM,VIEN,LIEN),-1) Q:LIEN=""!(QFL) D
.. S VALUE=$P(@TEMP@(VSDTM,VIEN,LIEN),U,1),OVALUE=VALUE
.. S FILE=$P(@TEMP@(VSDTM,VIEN,LIEN),U,2)
.. S TIEN=$P(@TEMP@(VSDTM,VIEN,LIEN),U,3)
.. K ROPER
.. S RN=""
.. F S RN=$O(SEARCH(RN)) Q:RN="" D Q:QFL
... S OPER=$P(SEARCH(RN),U,2),RESULT=$P(SEARCH(RN),U,1),OPER2=$P(SEARCH(RN),U,4),RES2=$P(SEARCH(RN),U,3)
... D RCHK
K @TEMP
Q RES
BQICAUTL ;VNGT/HS/ALA-Utility for CA ; 29 Mar 2011 4:49 PM
+1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
+2 ;
TAX(TMFRAME,TAX,NIT,PTDFN,FREF,PRB,SAME,TREF) ;EP
+1 ; Find value for a taxonomy (TAX) or list of taxonomies (TREF)
+2 ; Input
+3 ; TMFRAME - Timeframe to search for data
+4 ; TAX - Taxonomy
+5 ; NIT - Number of iterations
+6 ; PTDFN - Patient IEN
+7 ; FREF - File number reference
+8 ; PRB - If Active Problem okay
+9 ; SAME - If NIT is allowed for the same 30 days or not (1 same 30 days okay)
+10 ; TREF - Multiple same resulting taxonomies (e.g. MEDs) built
+11 ; into reference (usually global)
+12 ;
+13 NEW RESULT,GREF,ENDT,IEN,TIEN,TEMP,QFL
+14 SET TMFRAME=$GET(TMFRAME,"")
SET NIT=$GET(NIT,1)
SET PRB=$GET(PRB,0)
SET SAME=$GET(SAME,1)
+15 SET ENDT=$$DATE^BQIUL1(TMFRAME)
SET RESULT=0
SET TREF=$GET(TREF,"")
SET TAX=$GET(TAX,"")
+16 IF TAX'=""
Begin DoDot:1
+17 SET TREF=$NAME(^TMP("BQITAX",UID))
+18 KILL @TREF
+19 DO BLD^BQITUTL(TAX,TREF)
End DoDot:1
+20 SET GREF=$$ROOT^DILFD(FREF,"",1)
+21 SET TEMP=$NAME(^TMP("BQITEMP",UID))
KILL @TEMP
+22 ;
+23 IF PRB
Begin DoDot:1
+24 SET IEN=""
SET QFL=0
SET RESULT=0
+25 FOR
SET IEN=$ORDER(^AUPNPROB("AC",PTDFN,IEN),-1)
IF IEN=""
QUIT
Begin DoDot:2
+26 SET TIEN=$$GET1^DIQ(9000011,IEN,.01,"I")
IF TIEN=""
QUIT
+27 IF '$DATA(@TREF@(TIEN))
QUIT
+28 ; Check class - if Family ignore
+29 IF $$GET1^DIQ(9000011,IEN,.04,"I")="F"
QUIT
+30 IF $$GET1^DIQ(9000011,IEN,.12,"I")'="A"
QUIT
+31 SET VSDTM=$$PROB^BQIUL1(IEN)\1
IF VSDTM=0
QUIT
+32 IF $GET(TMFRAME)'=""
IF VSDTM<ENDT
QUIT
+33 SET RESULT=1_U_VSDTM
SET $PIECE(RESULT,U,4)=IEN
SET QFL=1
End DoDot:2
IF QFL
QUIT
End DoDot:1
+34 ;
+35 IF 'RESULT
Begin DoDot:1
+36 SET IEN=""
SET QFL=0
SET RESULT=0
SET CT=0
+37 IF $GET(TMFRAME)'=""
Begin DoDot:2
+38 SET EDT=9999999-ENDT
SET BDT=""
+39 FOR
SET BDT=$ORDER(@GREF@("AA",PTDFN,BDT))
IF BDT=""!(BDT>EDT)
QUIT
Begin DoDot:3
+40 SET IEN=""
+41 FOR
SET IEN=$ORDER(@GREF@("AA",PTDFN,BDT,IEN))
IF IEN=""
QUIT
Begin DoDot:4
+42 SET TIEN=$$GET1^DIQ(FREF,IEN,.01,"I")
IF TIEN=""
QUIT
+43 IF '$DATA(@TREF@(TIEN))
QUIT
+44 SET VISIT=$$GET1^DIQ(FREF,IEN,.03,"I")
IF VISIT=""
QUIT
+45 IF $$GET1^DIQ(9000010,VISIT,.11,"I")=1
QUIT
+46 SET VSDTM=$$GET1^DIQ(9000010,VISIT,.01,"I")\1
IF VSDTM=0
QUIT
+47 ;I $G(TMFRAME)'="",VSDTM<ENDT Q
+48 ; Set temporary
+49 SET @TEMP@(VSDTM,VISIT,IEN)=""
End DoDot:4
End DoDot:3
End DoDot:2
+50 ;
+51 IF $GET(TMFRAME)=""
Begin DoDot:2
+52 FOR
SET IEN=$ORDER(@GREF@("AC",PTDFN,IEN),-1)
IF IEN=""
QUIT
Begin DoDot:3
+53 SET TIEN=$$GET1^DIQ(FREF,IEN,.01,"I")
IF TIEN=""
QUIT
+54 IF '$DATA(@TREF@(TIEN))
QUIT
+55 SET VISIT=$$GET1^DIQ(FREF,IEN,.03,"I")
IF VISIT=""
QUIT
+56 IF $$GET1^DIQ(9000010,VISIT,.11,"I")=1
QUIT
+57 SET VSDTM=$$GET1^DIQ(9000010,VISIT,.01,"I")\1
IF VSDTM=0
QUIT
+58 ;I $G(TMFRAME)'="",VSDTM<ENDT Q
+59 ; Set temporary
+60 SET @TEMP@(VSDTM,VISIT,IEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+61 ;
+62 SET VSDTM=""
SET QFL=0
+63 FOR
SET VSDTM=$ORDER(@TEMP@(VSDTM),-1)
IF VSDTM=""!(QFL)
QUIT
Begin DoDot:1
+64 SET VISIT=""
+65 FOR
SET VISIT=$ORDER(@TEMP@(VSDTM,VISIT),-1)
IF VISIT=""
QUIT
Begin DoDot:2
+66 SET IEN=""
+67 FOR
SET IEN=$ORDER(@TEMP@(VSDTM,VISIT,IEN),-1)
IF IEN=""
QUIT
Begin DoDot:3
+68 ; If result cannot be within 30 days, quit
+69 IF 'SAME
IF $PIECE(RESULT,U,2)=VSDTM
QUIT
+70 SET CT=CT+1
+71 IF $PIECE(RESULT,U,2)'=""
IF (CT'>NIT)
Begin DoDot:4
+72 IF VSDTM'<STDT
IF 'SAME
SET CT=CT-1
QUIT
+73 SET $PIECE(RESULT,U,2)=$PIECE(RESULT,U,2)_";"_VSDTM
+74 SET $PIECE(RESULT,U,4)=$PIECE(RESULT,U,4)_";"_VISIT
+75 SET $PIECE(RESULT,U,5)=$PIECE(RESULT,U,5)_";"_IEN
End DoDot:4
+76 IF $PIECE(RESULT,U,2)=""
SET $PIECE(RESULT,U,2)=VSDTM
SET $PIECE(RESULT,U,4)=VISIT_U_IEN
+77 ;S $P(RESULT,U,4)=VISIT_U_IEN,CT=CT+1
+78 ;S RESULT=U_VSDTM_U_U_VISIT_U_IEN,CT=CT+1
+79 IF CT=NIT
SET QFL=1
SET $PIECE(RESULT,U,1)=1
End DoDot:3
IF QFL
QUIT
End DoDot:2
IF QFL
QUIT
End DoDot:1
+80 KILL @TREF
+81 QUIT RESULT
+82 ;
MEAS(BQDFN,MEAS,VISIT,RESVAL,OPER) ;EP - Get measurement
+1 IF MEAS'?.N
SET MEAS=$$FIND1^DIC(9999999.07,,"MX",MEAS)
+2 SET VALUE=0
+3 SET VDATE=$PIECE(^AUPNVSIT(VISIT,0),U,1)\1
+4 SET RVDT=9999999-VDATE
+5 SET IEN=""
+6 FOR
SET IEN=$ORDER(^AUPNVMSR("AA",BQDFN,MEAS,RVDT,IEN))
IF IEN=""
QUIT
Begin DoDot:1
+7 SET RESULT=$PIECE($GET(^AUPNVMSR(IEN,0)),"^",4)
IF RESULT=""
QUIT
+8 IF $PIECE($GET(^AUPNVMSR(IEN,2)),"^",1)=1
QUIT
+9 ; if the new ENTERED IN ERROR field exists, exclude the record if it is marked as an error
+10 IF $$VFIELD^DILFD(9000010.01,2)
IF $$GET1^DIQ(9000010.01,IEN_",",2,"I")=1
QUIT
+11 IF @(RESULT_OPER_RESVAL)
SET VALUE="1^"_VDATE_U_RESULT_U_VISIT_U_IEN_U_"9000010.01"
End DoDot:1
+12 QUIT VALUE
+13 ;
LAB(TMFRAME,RECENT,BQDFN,TAX,SEARCH,TREF) ;EP
+1 ; Check for a lab test result
+2 ;
+3 ; Input
+4 ; TMFRAME - Time frame to search data for
+5 ; RECENT - 1=Only check most recent lab,0=Check all within timeframe
+6 ; BQDFN - Patient internal entry number
+7 ; TAX - Lab taxonomy to search
+8 ; RESULT - Lab result to check for
+9 ; OPER - Operand to use for result check
+10 ; RES2 - If range, the other result value
+11 ; OPER2 - If range, the other result operand
+12 ; TREF - Multiple same resulting taxonomies built
+13 ; into reference (usually global)
+14 ;
+15 NEW TEMP,EDATE,BDATE,LIEN,QFL,RES,CT,VALUE,VIEN,VSDTM
+16 SET BDATE=$$DATE^BQIUL1(TMFRAME)
SET EDATE=DT
+17 SET TEMP=$NAME(^TMP("BQITEMP",UID))
KILL @TEMP
+18 SET TAX=$GET(TAX,"")
SET RECENT=$GET(RECENT,0)
+19 IF TAX'=""
Begin DoDot:1
+20 SET TREF=$NAME(^TMP("BQITAX",UID))
+21 KILL @TREF
+22 DO BLD^BQITUTL(TAX,TREF)
End DoDot:1
+23 ;
+24 SET LIEN=""
SET QFL=0
SET RES=0_U_"No Test"
SET CT=0
+25 IF $GET(TMFRAME)'=""
Begin DoDot:1
+26 SET TIEN=""
+27 FOR
SET TIEN=$ORDER(@TREF@(TIEN))
IF TIEN=""
QUIT
Begin DoDot:2
+28 SET EDT=9999999-BDATE
SET BDT=(9999999-EDATE)-.001
+29 IF $PIECE($GET(^LAB(60,TIEN,0)),U,4)="MI"
Begin DoDot:3
+30 DO MIC(BQDFN,TIEN,EDT,BDT,.MICRO)
+31 MERGE @TEMP=MICRO
+32 KILL MICRO
End DoDot:3
QUIT
+33 FOR
SET BDT=$ORDER(^AUPNVLAB("AA",BQDFN,TIEN,BDT))
IF BDT=""!(BDT>EDT)
QUIT
Begin DoDot:3
+34 SET LIEN=""
+35 FOR
SET LIEN=$ORDER(^AUPNVLAB("AA",BQDFN,TIEN,BDT,LIEN))
IF LIEN=""
QUIT
Begin DoDot:4
+36 SET VALUE=$PIECE(^AUPNVLAB(LIEN,0),U,4)
IF VALUE=""
QUIT
+37 SET VIEN=$PIECE(^AUPNVLAB(LIEN,0),U,3)
IF VIEN=""
QUIT
+38 SET FLAG=$PIECE($GET(^AUPNVLAB(LIEN,11)),U,9)
IF FLAG=""
QUIT
+39 IF FLAG'="R"&(FLAG'="M")
QUIT
+40 SET VSDTM=$$GET1^DIQ(9000010,VIEN_",",.01,"I")\1
IF VSDTM=0
QUIT
+41 ;I $G(TMFRAME)'="",VSDTM<BDATE Q
+42 ; quit if deleted flag
+43 IF $PIECE($GET(^AUPNVSIT(VIEN,0)),U,11)=1
QUIT
+44 IF $PIECE($GET(^AUPNVLAB(LIEN,11)),U,9)="D"
QUIT
+45 SET @TEMP@(VSDTM,VIEN,LIEN)=VALUE_U_"9000010.09"_U_TIEN
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+46 ;
+47 IF $GET(TMFRAME)=""
Begin DoDot:1
+48 SET LIEN=""
+49 FOR
SET LIEN=$ORDER(^AUPNVLAB("AC",BQDFN,LIEN),-1)
IF LIEN=""
QUIT
Begin DoDot:2
+50 SET TIEN=$PIECE($GET(^AUPNVLAB(LIEN,0)),U,1)
IF TIEN=""
QUIT
+51 IF '$DATA(@TREF@(TIEN))
QUIT
+52 SET VALUE=$PIECE(^AUPNVLAB(LIEN,0),U,4)
IF VALUE=""
QUIT
+53 SET VIEN=$PIECE(^AUPNVLAB(LIEN,0),U,3)
IF VIEN=""
QUIT
+54 SET VSDTM=$$GET1^DIQ(9000010,VIEN_",",.01,"I")\1
IF VSDTM=0
QUIT
+55 ;I $G(TMFRAME)'="",VSDTM<BDATE Q
+56 ; quit if deleted flag
+57 IF $PIECE($GET(^AUPNVSIT(VIEN,0)),U,11)=1
QUIT
+58 IF $PIECE($GET(^AUPNVLAB(LIEN,11)),U,9)="D"
QUIT
+59 SET @TEMP@(VSDTM,VIEN,LIEN)=VALUE_U_"9000010.09"_U_TIEN
End DoDot:2
+60 FOR
SET LIEN=$ORDER(^AUPNVMIC("AC",BQDFN,LIEN),-1)
IF LIEN=""
QUIT
Begin DoDot:2
+61 SET TIEN=$PIECE($GET(^AUPNVMIC(LIEN,0)),U,1)
IF TIEN=""
QUIT
+62 IF '$DATA(@TREF@(TIEN))
QUIT
+63 SET VALUE=$PIECE(^AUPNVMIC(LIEN,0),U,7)
IF VALUE=""
QUIT
+64 SET VIEN=$PIECE(^AUPNVMIC(LIEN,0),U,3)
IF VIEN=""
QUIT
+65 SET VSDTM=$$GET1^DIQ(9000010,VIEN_",",.01,"I")\1
IF VSDTM=0
QUIT
+66 ; quit if deleted flag
+67 IF $PIECE($GET(^AUPNVSIT(VIEN,0)),U,11)=1
QUIT
+68 SET FLAG=$PIECE($GET(^AUPNVMIC(LIEN,11)),U,9)
+69 IF FLAG'="R"&(FLAG'="M")
QUIT
+70 SET @TEMP@(VSDTM,VIEN,LIEN)=VALUE_U_"9000010.25"_U_TIEN
End DoDot:2
End DoDot:1
+71 ;
+72 SET VSDTM=""
+73 FOR
SET VSDTM=$ORDER(@TEMP@(VSDTM),-1)
IF VSDTM=""
QUIT
Begin DoDot:1
+74 SET VIEN=$ORDER(@TEMP@(VSDTM,""),-1)
SET LIEN=""
+75 FOR
SET LIEN=$ORDER(@TEMP@(VSDTM,VIEN,LIEN),-1)
IF LIEN=""!(QFL)
QUIT
Begin DoDot:2
+76 SET VALUE=$PIECE(@TEMP@(VSDTM,VIEN,LIEN),U,1)
SET OVALUE=VALUE
+77 SET FILE=$PIECE(@TEMP@(VSDTM,VIEN,LIEN),U,2)
+78 SET TIEN=$PIECE(@TEMP@(VSDTM,VIEN,LIEN),U,3)
+79 KILL ROPER
+80 SET RN=""
+81 FOR
SET RN=$ORDER(SEARCH(RN))
IF RN=""
QUIT
Begin DoDot:3
+82 SET OPER=$PIECE(SEARCH(RN),U,2)
SET RESULT=$PIECE(SEARCH(RN),U,1)
SET OPER2=$PIECE(SEARCH(RN),U,4)
SET RES2=$PIECE(SEARCH(RN),U,3)
+83 DO RCHK
End DoDot:3
IF QFL
QUIT
End DoDot:2
End DoDot:1
IF QFL
QUIT
+84 KILL @TEMP
+85 QUIT RES
+86 ;
RCHK ;
+1 IF OPER="'="
IF RESULT=""
IF VALUE'=""
SET RES=1_U_$$FMTE^BQIUL1(VSDTM)_U_VALUE_U_VIEN_U_LIEN_U_TIEN_U_FILE
SET QFL=1
QUIT
+2 ;
+3 IF RESULT'?.N
IF VALUE?.N
QUIT
+4 ;
+5 IF RESULT="POS"
IF $EXTRACT(VALUE,1)'?.N
IF '$$POSITIVE^BQITRUTL(VALUE)
QUIT
+6 IF RESULT="POS"
IF $EXTRACT(VALUE,1)'?.N
IF $$POSITIVE^BQITRUTL(VALUE)
Begin DoDot:1
+7 SET RES=1_U_$$FMTE^BQIUL1(VSDTM)_U_VALUE_U_VIEN_U_LIEN_U_TIEN_U_FILE
SET QFL=1
End DoDot:1
QUIT
+8 IF RESULT="NEG"
IF $EXTRACT(VALUE,1)'?.N
IF '$$NEGATIVE^BQITRUTL(VALUE)
QUIT
+9 IF RESULT="NEG"
IF $EXTRACT(VALUE,1)'?.N
IF $$NEGATIVE^BQITRUTL(VALUE)
Begin DoDot:1
+10 SET RES=1_U_$$FMTE^BQIUL1(VSDTM)_U_VALUE_U_VIEN_U_LIEN_U_TIEN_U_FILE
SET QFL=1
End DoDot:1
+11 IF VALUE'?.PN
IF VALUE'?.N
QUIT
+12 ;I $E(VALUE,$L(VALUE))?.P S VALUE=VALUE_"0"
+13 IF $EXTRACT(VALUE,$LENGTH(VALUE),$LENGTH(VALUE))?.P
SET VALUE=$EXTRACT(VALUE,1,$LENGTH(VALUE)-1)
+14 ; if value starts with a punctuation e.g. < or >
+15 IF $EXTRACT(VALUE,1,1)?.P
SET ROPER=$EXTRACT(VALUE,1,1)
SET VALUE=$EXTRACT(VALUE,2,$LENGTH(VALUE))
+16 IF RES2=""
Begin DoDot:1
+17 IF $GET(ROPER)=""
IF @("VALUE"_OPER_"RESULT")
Begin DoDot:2
+18 SET RES=1_U_$$FMTE^BQIUL1(VSDTM)_U_OVALUE_U_VIEN_U_LIEN_U_TIEN_U_FILE
SET QFL=1
End DoDot:2
QUIT
+19 IF $GET(ROPER)'=""
IF OPER=ROPER
IF @("VALUE"_OPER_"RESULT")
Begin DoDot:2
+20 SET RES=1_U_$$FMTE^BQIUL1(VSDTM)_U_OVALUE_U_VIEN_U_LIEN_U_TIEN_U_FILE
SET QFL=1
End DoDot:2
QUIT
+21 IF $GET(ROPER)'=""
IF OPER'=ROPER
QUIT
End DoDot:1
+22 IF RES2'=""
Begin DoDot:1
+23 IF @("VALUE"_OPER_"RESULT")
IF @("VALUE"_OPER2_"RES2")
Begin DoDot:2
+24 SET RES=1_U_$$FMTE^BQIUL1(VSDTM)_U_OVALUE_U_VIEN_U_LIEN_U_TIEN_U_FILE
SET QFL=1
End DoDot:2
End DoDot:1
+25 QUIT
+26 ;
MIC(BQDFN,TIEN,EDT,BDT,MICRO) ;EP - Look through Microbiology file
+1 NEW FLAG,LIEN,VALUE,VIEN,VSDTM
+2 KILL MICRO
+3 FOR
SET BDT=$ORDER(^AUPNVMIC("AA",BQDFN,TIEN,BDT))
IF BDT=""!(BDT>EDT)
QUIT
Begin DoDot:1
+4 SET LIEN=""
+5 FOR
SET LIEN=$ORDER(^AUPNVMIC("AA",BQDFN,TIEN,BDT,LIEN))
IF LIEN=""
QUIT
Begin DoDot:2
+6 SET VALUE=$PIECE(^AUPNVMIC(LIEN,0),U,7)
IF VALUE=""
QUIT
+7 SET VIEN=$PIECE(^AUPNVMIC(LIEN,0),U,3)
IF VIEN=""
QUIT
+8 SET VSDTM=$$GET1^DIQ(9000010,VIEN_",",.01,"I")\1
IF VSDTM=0
QUIT
+9 ; quit if deleted flag
+10 IF $PIECE($GET(^AUPNVSIT(VIEN,0)),U,11)=1
QUIT
+11 SET FLAG=$PIECE($GET(^AUPNVMIC(LIEN,11)),U,9)
+12 IF FLAG'="R"&(FLAG'="M")
QUIT
+13 SET MICRO(VSDTM,VIEN,LIEN)=VALUE_U_"9000010.25"_U_TIEN
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
LBB(TMFRAME,RECENT,DATE,BQDFN,TAX,SEARCH,TREF) ;EP
+1 IF $GET(TMFRAME)'=""
Begin DoDot:1
+2 IF TMFRAME'["-"
QUIT
+3 SET TMFRAME=$PIECE(TMFRAME,"-",2)
End DoDot:1
+4 SET BDATE=$$FMADD^XLFDT(DATE,-TMFRAME)
SET EDATE=$$FMADD^XLFDT(DATE,TMFRAME)
+5 SET TEMP=$NAME(^TMP("BQITEMP",UID))
KILL @TEMP
+6 SET TAX=$GET(TAX,"")
SET RECENT=$GET(RECENT,0)
+7 IF TAX'=""
Begin DoDot:1
+8 SET TREF=$NAME(^TMP("BQITAX",UID))
+9 KILL @TREF
+10 DO BLD^BQITUTL(TAX,TREF)
End DoDot:1
+11 ;
+12 SET LIEN=""
SET QFL=0
SET RES=0_U_"No Test"
SET CT=0
+13 Begin DoDot:1
+14 SET TIEN=""
+15 FOR
SET TIEN=$ORDER(@TREF@(TIEN))
IF TIEN=""
QUIT
Begin DoDot:2
+16 SET EDT=9999999-BDATE
SET BDT=(9999999-EDATE)-.001
+17 IF $PIECE($GET(^LAB(60,TIEN,0)),U,4)="MI"
Begin DoDot:3
+18 DO MIC(BQDFN,TIEN,EDT,BDT,.MICRO)
+19 MERGE @TEMP=MICRO
+20 KILL MICRO
End DoDot:3
QUIT
+21 FOR
SET BDT=$ORDER(^AUPNVLAB("AA",BQDFN,TIEN,BDT))
IF BDT=""!(BDT>EDT)
QUIT
Begin DoDot:3
+22 SET LIEN=""
+23 FOR
SET LIEN=$ORDER(^AUPNVLAB("AA",BQDFN,TIEN,BDT,LIEN))
IF LIEN=""
QUIT
Begin DoDot:4
+24 SET VALUE=$PIECE(^AUPNVLAB(LIEN,0),U,4)
IF VALUE=""
QUIT
+25 SET VIEN=$PIECE(^AUPNVLAB(LIEN,0),U,3)
IF VIEN=""
QUIT
+26 SET FLAG=$PIECE($GET(^AUPNVLAB(LIEN,11)),U,9)
IF FLAG=""
QUIT
+27 IF FLAG'="R"&(FLAG'="M")
QUIT
+28 SET VSDTM=$$GET1^DIQ(9000010,VIEN_",",.01,"I")\1
IF VSDTM=0
QUIT
+29 ;I $G(TMFRAME)'="",VSDTM<BDATE Q
+30 ; quit if deleted flag
+31 IF $PIECE($GET(^AUPNVSIT(VIEN,0)),U,11)=1
QUIT
+32 IF $PIECE($GET(^AUPNVLAB(LIEN,11)),U,9)="D"
QUIT
+33 SET @TEMP@(VSDTM,VIEN,LIEN)=VALUE_U_"9000010.09"_U_TIEN
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+34 ;
+35 SET VSDTM=""
+36 FOR
SET VSDTM=$ORDER(@TEMP@(VSDTM),-1)
IF VSDTM=""
QUIT
Begin DoDot:1
+37 SET VIEN=$ORDER(@TEMP@(VSDTM,""),-1)
SET LIEN=""
+38 FOR
SET LIEN=$ORDER(@TEMP@(VSDTM,VIEN,LIEN),-1)
IF LIEN=""!(QFL)
QUIT
Begin DoDot:2
+39 SET VALUE=$PIECE(@TEMP@(VSDTM,VIEN,LIEN),U,1)
SET OVALUE=VALUE
+40 SET FILE=$PIECE(@TEMP@(VSDTM,VIEN,LIEN),U,2)
+41 SET TIEN=$PIECE(@TEMP@(VSDTM,VIEN,LIEN),U,3)
+42 KILL ROPER
+43 SET RN=""
+44 FOR
SET RN=$ORDER(SEARCH(RN))
IF RN=""
QUIT
Begin DoDot:3
+45 SET OPER=$PIECE(SEARCH(RN),U,2)
SET RESULT=$PIECE(SEARCH(RN),U,1)
SET OPER2=$PIECE(SEARCH(RN),U,4)
SET RES2=$PIECE(SEARCH(RN),U,3)
+46 DO RCHK
End DoDot:3
IF QFL
QUIT
End DoDot:2
End DoDot:1
IF QFL
QUIT
+47 KILL @TEMP
+48 QUIT RES
