- 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