BQITRUT2 ;GDIT/HS/ALA-Lab search ; 03 Mar 2015 9:46 AM
;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
;
;
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 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 VIEN=$P(^AUPNVLAB(LIEN,0),U,3) I VIEN="" Q
.... NEW LN,LTMP,GLB
.... S LN="",LTMP="BQILAB" K @LTMP
.... F S LN=$O(^AUPNVLAB("AD",VIEN,LN)) Q:LN="" D
..... S GLB=$P($G(^AUPNVLAB(LN,12)),"^",8)
..... I GLB'=LIEN Q
..... S VALUE=$P(^AUPNVLAB(LN,0),U,4) I VALUE="" Q
..... I GLB'="" S @LTMP@(VSDTM,VIEN,LIEN,LN)=VALUE_U_"9000010.09"_U_TIEN
.... ;
.... S @TEMP@(VSDTM,VIEN,LIEN)=VALUE_U_"9000010.09"_U_TIEN
;
I $G(TMFRAME)="" D
. S LIEN="",LTMP="BQILAB" K @LTMP
. 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
.. NEW LN,GLB
.. S LN=""
.. F S LN=$O(^AUPNVLAB("AD",VIEN,LN)) Q:LN="" D
... S GLB=$P($G(^AUPNVLAB(LN,12)),"^",8)
... I GLB'=LIEN Q
... S VALUE=$P(^AUPNVLAB(LN,0),U,4) I VALUE="" Q
... I GLB'="" S @LTMP@(VSDTM,LIEN,LN)=VALUE_U_"9000010.09"_U_TIEN
.. I $D(@LTMP) D ;
... S VSDTM=""
... S VSDTM=$O(@LTMP@(VSDTM),-1),LIEN=$O(@LTMP@(VSDTM,""),-1)
... S LN="" F S LN=$O(@LTMP@(VSDTM,LIEN,LN),-1) Q:LN="" D
.... S VALUE=$P(@LTMP@(VSDTM,LIEN,LN),U,1)
.... S FILE=$P(@LTMP@(VSDTM,LIEN,LN),U,2)
.... 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 LCHK
.. ;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=""
. F S VIEN=$O(@TEMP@(VSDTM,""),-1) Q:VIEN="" D Q:QFL
.. S LIEN=""
.. F S LIEN=$O(@TEMP@(VSDTM,VIEN,""),-1) Q:LIEN="" D Q:QFL
... 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
;
LCHK ;
I OPER="'=",RESULT="",VALUE'="" S @TEMP@(VSDTM,VIEN,LN)=VALUE_U_FILE_U_TIEN 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 @TEMP@(VSDTM,VIEN,LN)=VALUE_U_"9000010.25"_U_TIEN
I RESULT="NEG",$E(VALUE,1)'?.N,'$$NEGATIVE^BQITRUTL(VALUE) Q
I RESULT="NEG",$E(VALUE,1)'?.N,$$NEGATIVE^BQITRUTL(VALUE) D
. S @TEMP@(VSDTM,VIEN,LN)=VALUE_U_FILE_U_TIEN
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 @TEMP@(VSDTM,VIEN,LN)=VALUE_U_FILE_U_TIEN
. I $G(ROPER)'="",OPER=ROPER,@("VALUE"_OPER_"RESULT") D Q
.. S @TEMP@(VSDTM,VIEN,LN)=VALUE_U_FILE_U_TIEN
. I $G(ROPER)'="",OPER'=ROPER Q
I RES2'="" D
. I @("VALUE"_OPER_"RESULT"),@("VALUE"_OPER2_"RES2") D
.. S @TEMP@(VSDTM,VIEN,LN)=VALUE_U_FILE_U_TIEN
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)
. S LIEN=$O(@TEMP@(VSDTM,VIEN,""),-1)
. 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
BQITRUT2 ;GDIT/HS/ALA-Lab search ; 03 Mar 2015 9:46 AM
+1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
+2 ;
+3 ;
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 FLAG=$PIECE($GET(^AUPNVLAB(LIEN,11)),U,9)
IF FLAG=""
QUIT
+37 IF FLAG'="R"&(FLAG'="M")
QUIT
+38 SET VSDTM=$$GET1^DIQ(9000010,VIEN_",",.01,"I")\1
IF VSDTM=0
QUIT
+39 ;I $G(TMFRAME)'="",VSDTM<BDATE Q
+40 ; quit if deleted flag
+41 IF $PIECE($GET(^AUPNVSIT(VIEN,0)),U,11)=1
QUIT
+42 IF $PIECE($GET(^AUPNVLAB(LIEN,11)),U,9)="D"
QUIT
+43 SET VIEN=$PIECE(^AUPNVLAB(LIEN,0),U,3)
IF VIEN=""
QUIT
+44 NEW LN,LTMP,GLB
+45 SET LN=""
SET LTMP="BQILAB"
KILL @LTMP
+46 FOR
SET LN=$ORDER(^AUPNVLAB("AD",VIEN,LN))
IF LN=""
QUIT
Begin DoDot:5
+47 SET GLB=$PIECE($GET(^AUPNVLAB(LN,12)),"^",8)
+48 IF GLB'=LIEN
QUIT
+49 SET VALUE=$PIECE(^AUPNVLAB(LN,0),U,4)
IF VALUE=""
QUIT
+50 IF GLB'=""
SET @LTMP@(VSDTM,VIEN,LIEN,LN)=VALUE_U_"9000010.09"_U_TIEN
End DoDot:5
+51 ;
+52 SET @TEMP@(VSDTM,VIEN,LIEN)=VALUE_U_"9000010.09"_U_TIEN
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+53 ;
+54 IF $GET(TMFRAME)=""
Begin DoDot:1
+55 SET LIEN=""
SET LTMP="BQILAB"
KILL @LTMP
+56 FOR
SET LIEN=$ORDER(^AUPNVLAB("AC",BQDFN,LIEN),-1)
IF LIEN=""
QUIT
Begin DoDot:2
+57 SET TIEN=$PIECE($GET(^AUPNVLAB(LIEN,0)),U,1)
IF TIEN=""
QUIT
+58 IF '$DATA(@TREF@(TIEN))
QUIT
+59 ;S VALUE=$P(^AUPNVLAB(LIEN,0),U,4) I VALUE="" Q
+60 SET VIEN=$PIECE(^AUPNVLAB(LIEN,0),U,3)
IF VIEN=""
QUIT
+61 SET VSDTM=$$GET1^DIQ(9000010,VIEN_",",.01,"I")\1
IF VSDTM=0
QUIT
+62 ;I $G(TMFRAME)'="",VSDTM<BDATE Q
+63 ; quit if deleted flag
+64 IF $PIECE($GET(^AUPNVSIT(VIEN,0)),U,11)=1
QUIT
+65 IF $PIECE($GET(^AUPNVLAB(LIEN,11)),U,9)="D"
QUIT
+66 NEW LN,GLB
+67 SET LN=""
+68 FOR
SET LN=$ORDER(^AUPNVLAB("AD",VIEN,LN))
IF LN=""
QUIT
Begin DoDot:3
+69 SET GLB=$PIECE($GET(^AUPNVLAB(LN,12)),"^",8)
+70 IF GLB'=LIEN
QUIT
+71 SET VALUE=$PIECE(^AUPNVLAB(LN,0),U,4)
IF VALUE=""
QUIT
+72 IF GLB'=""
SET @LTMP@(VSDTM,LIEN,LN)=VALUE_U_"9000010.09"_U_TIEN
End DoDot:3
+73 ;
IF $DATA(@LTMP)
Begin DoDot:3
+74 SET VSDTM=""
+75 SET VSDTM=$ORDER(@LTMP@(VSDTM),-1)
SET LIEN=$ORDER(@LTMP@(VSDTM,""),-1)
+76 SET LN=""
FOR
SET LN=$ORDER(@LTMP@(VSDTM,LIEN,LN),-1)
IF LN=""
QUIT
Begin DoDot:4
+77 SET VALUE=$PIECE(@LTMP@(VSDTM,LIEN,LN),U,1)
+78 SET FILE=$PIECE(@LTMP@(VSDTM,LIEN,LN),U,2)
+79 KILL ROPER
+80 SET RN=""
+81 FOR
SET RN=$ORDER(SEARCH(RN))
IF RN=""
QUIT
Begin DoDot:5
+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 LCHK
End DoDot:5
IF QFL
QUIT
End DoDot:4
End DoDot:3
+84 ;S @TEMP@(VSDTM,VIEN,LIEN)=VALUE_U_"9000010.09"_U_TIEN
End DoDot:2
+85 FOR
SET LIEN=$ORDER(^AUPNVMIC("AC",BQDFN,LIEN),-1)
IF LIEN=""
QUIT
Begin DoDot:2
+86 SET TIEN=$PIECE($GET(^AUPNVMIC(LIEN,0)),U,1)
IF TIEN=""
QUIT
+87 IF '$DATA(@TREF@(TIEN))
QUIT
+88 SET VALUE=$PIECE(^AUPNVMIC(LIEN,0),U,7)
IF VALUE=""
QUIT
+89 SET VIEN=$PIECE(^AUPNVMIC(LIEN,0),U,3)
IF VIEN=""
QUIT
+90 SET VSDTM=$$GET1^DIQ(9000010,VIEN_",",.01,"I")\1
IF VSDTM=0
QUIT
+91 ; quit if deleted flag
+92 IF $PIECE($GET(^AUPNVSIT(VIEN,0)),U,11)=1
QUIT
+93 SET FLAG=$PIECE($GET(^AUPNVMIC(LIEN,11)),U,9)
+94 IF FLAG'="R"&(FLAG'="M")
QUIT
+95 SET @TEMP@(VSDTM,VIEN,LIEN)=VALUE_U_"9000010.25"_U_TIEN
End DoDot:2
End DoDot:1
+96 ;
+97 SET VSDTM=""
+98 FOR
SET VSDTM=$ORDER(@TEMP@(VSDTM),-1)
IF VSDTM=""
QUIT
Begin DoDot:1
+99 SET VIEN=""
+100 FOR
SET VIEN=$ORDER(@TEMP@(VSDTM,""),-1)
IF VIEN=""
QUIT
Begin DoDot:2
+101 SET LIEN=""
+102 FOR
SET LIEN=$ORDER(@TEMP@(VSDTM,VIEN,""),-1)
IF LIEN=""
QUIT
Begin DoDot:3
+103 SET VALUE=$PIECE(@TEMP@(VSDTM,VIEN,LIEN),U,1)
SET OVALUE=VALUE
+104 SET FILE=$PIECE(@TEMP@(VSDTM,VIEN,LIEN),U,2)
+105 SET TIEN=$PIECE(@TEMP@(VSDTM,VIEN,LIEN),U,3)
+106 KILL ROPER
+107 SET RN=""
+108 FOR
SET RN=$ORDER(SEARCH(RN))
IF RN=""
QUIT
Begin DoDot:4
+109 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)
+110 DO RCHK
End DoDot:4
IF QFL
QUIT
End DoDot:3
IF QFL
QUIT
End DoDot:2
IF QFL
QUIT
End DoDot:1
IF QFL
QUIT
+111 KILL @TEMP
+112 QUIT RES
+113 ;
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 ;
LCHK ;
+1 IF OPER="'="
IF RESULT=""
IF VALUE'=""
SET @TEMP@(VSDTM,VIEN,LN)=VALUE_U_FILE_U_TIEN
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 @TEMP@(VSDTM,VIEN,LN)=VALUE_U_"9000010.25"_U_TIEN
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 @TEMP@(VSDTM,VIEN,LN)=VALUE_U_FILE_U_TIEN
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 @TEMP@(VSDTM,VIEN,LN)=VALUE_U_FILE_U_TIEN
End DoDot:2
QUIT
+19 IF $GET(ROPER)'=""
IF OPER=ROPER
IF @("VALUE"_OPER_"RESULT")
Begin DoDot:2
+20 SET @TEMP@(VSDTM,VIEN,LN)=VALUE_U_FILE_U_TIEN
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 @TEMP@(VSDTM,VIEN,LN)=VALUE_U_FILE_U_TIEN
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)
+38 SET LIEN=$ORDER(@TEMP@(VSDTM,VIEN,""),-1)
+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:2
+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:2
IF QFL
QUIT
End DoDot:1
IF QFL
QUIT
+47 KILL @TEMP
+48 QUIT RES
