Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BQITRUT2

BQITRUT2.m

Go to the documentation of this file.
  1. BQITRUT2 ;GDIT/HS/ALA-Lab search ; 03 Mar 2015 9:46 AM
  1. ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
  1. ;
  1. ;
  1. LAB(TMFRAME,RECENT,BQDFN,TAX,SEARCH,TREF) ;EP
  1. ; Check for a lab test result
  1. ;
  1. ; Input
  1. ; TMFRAME - Time frame to search data for
  1. ; RECENT - 1=Only check most recent lab,0=Check all within timeframe
  1. ; BQDFN - Patient internal entry number
  1. ; TAX - Lab taxonomy to search
  1. ; RESULT - Lab result to check for
  1. ; OPER - Operand to use for result check
  1. ; RES2 - If range, the other result value
  1. ; OPER2 - If range, the other result operand
  1. ; TREF - Multiple same resulting taxonomies built
  1. ; into reference (usually global)
  1. ;
  1. NEW TEMP,EDATE,BDATE,LIEN,QFL,RES,CT,VALUE,VIEN,VSDTM
  1. S BDATE=$$DATE^BQIUL1(TMFRAME),EDATE=DT
  1. S TEMP=$NA(^TMP("BQITEMP",UID)) K @TEMP
  1. S TAX=$G(TAX,""),RECENT=$G(RECENT,0)
  1. I TAX'="" D
  1. . S TREF=$NA(^TMP("BQITAX",UID))
  1. . K @TREF
  1. . D BLD^BQITUTL(TAX,TREF)
  1. ;
  1. S LIEN="",QFL=0,RES=0_U_"No Test",CT=0
  1. I $G(TMFRAME)'="" D
  1. . S TIEN=""
  1. . F S TIEN=$O(@TREF@(TIEN)) Q:TIEN="" D
  1. .. S EDT=9999999-BDATE,BDT=(9999999-EDATE)-.001
  1. .. I $P($G(^LAB(60,TIEN,0)),U,4)="MI" D Q
  1. ... D MIC(BQDFN,TIEN,EDT,BDT,.MICRO)
  1. ... M @TEMP=MICRO
  1. ... K MICRO
  1. .. F S BDT=$O(^AUPNVLAB("AA",BQDFN,TIEN,BDT)) Q:BDT=""!(BDT>EDT) D
  1. ... S LIEN=""
  1. ... F S LIEN=$O(^AUPNVLAB("AA",BQDFN,TIEN,BDT,LIEN)) Q:LIEN="" D
  1. .... S FLAG=$P($G(^AUPNVLAB(LIEN,11)),U,9) I FLAG="" Q
  1. .... I FLAG'="R"&(FLAG'="M") Q
  1. .... S VSDTM=$$GET1^DIQ(9000010,VIEN_",",.01,"I")\1 I VSDTM=0 Q
  1. .... ;I $G(TMFRAME)'="",VSDTM<BDATE Q
  1. .... ; quit if deleted flag
  1. .... I $P($G(^AUPNVSIT(VIEN,0)),U,11)=1 Q
  1. .... I $P($G(^AUPNVLAB(LIEN,11)),U,9)="D" Q
  1. .... S VIEN=$P(^AUPNVLAB(LIEN,0),U,3) I VIEN="" Q
  1. .... NEW LN,LTMP,GLB
  1. .... S LN="",LTMP="BQILAB" K @LTMP
  1. .... F S LN=$O(^AUPNVLAB("AD",VIEN,LN)) Q:LN="" D
  1. ..... S GLB=$P($G(^AUPNVLAB(LN,12)),"^",8)
  1. ..... I GLB'=LIEN Q
  1. ..... S VALUE=$P(^AUPNVLAB(LN,0),U,4) I VALUE="" Q
  1. ..... I GLB'="" S @LTMP@(VSDTM,VIEN,LIEN,LN)=VALUE_U_"9000010.09"_U_TIEN
  1. .... ;
  1. .... S @TEMP@(VSDTM,VIEN,LIEN)=VALUE_U_"9000010.09"_U_TIEN
  1. ;
  1. I $G(TMFRAME)="" D
  1. . S LIEN="",LTMP="BQILAB" K @LTMP
  1. . F S LIEN=$O(^AUPNVLAB("AC",BQDFN,LIEN),-1) Q:LIEN="" D
  1. .. S TIEN=$P($G(^AUPNVLAB(LIEN,0)),U,1) I TIEN="" Q
  1. .. I '$D(@TREF@(TIEN)) Q
  1. .. ;S VALUE=$P(^AUPNVLAB(LIEN,0),U,4) I VALUE="" Q
  1. .. S VIEN=$P(^AUPNVLAB(LIEN,0),U,3) I VIEN="" Q
  1. .. S VSDTM=$$GET1^DIQ(9000010,VIEN_",",.01,"I")\1 I VSDTM=0 Q
  1. .. ;I $G(TMFRAME)'="",VSDTM<BDATE Q
  1. .. ; quit if deleted flag
  1. .. I $P($G(^AUPNVSIT(VIEN,0)),U,11)=1 Q
  1. .. I $P($G(^AUPNVLAB(LIEN,11)),U,9)="D" Q
  1. .. NEW LN,GLB
  1. .. S LN=""
  1. .. F S LN=$O(^AUPNVLAB("AD",VIEN,LN)) Q:LN="" D
  1. ... S GLB=$P($G(^AUPNVLAB(LN,12)),"^",8)
  1. ... I GLB'=LIEN Q
  1. ... S VALUE=$P(^AUPNVLAB(LN,0),U,4) I VALUE="" Q
  1. ... I GLB'="" S @LTMP@(VSDTM,LIEN,LN)=VALUE_U_"9000010.09"_U_TIEN
  1. .. I $D(@LTMP) D ;
  1. ... S VSDTM=""
  1. ... S VSDTM=$O(@LTMP@(VSDTM),-1),LIEN=$O(@LTMP@(VSDTM,""),-1)
  1. ... S LN="" F S LN=$O(@LTMP@(VSDTM,LIEN,LN),-1) Q:LN="" D
  1. .... S VALUE=$P(@LTMP@(VSDTM,LIEN,LN),U,1)
  1. .... S FILE=$P(@LTMP@(VSDTM,LIEN,LN),U,2)
  1. .... K ROPER
  1. .... S RN=""
  1. .... F S RN=$O(SEARCH(RN)) Q:RN="" D Q:QFL
  1. ..... 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)
  1. ..... D LCHK
  1. .. ;S @TEMP@(VSDTM,VIEN,LIEN)=VALUE_U_"9000010.09"_U_TIEN
  1. . F S LIEN=$O(^AUPNVMIC("AC",BQDFN,LIEN),-1) Q:LIEN="" D
  1. .. S TIEN=$P($G(^AUPNVMIC(LIEN,0)),U,1) I TIEN="" Q
  1. .. I '$D(@TREF@(TIEN)) Q
  1. .. S VALUE=$P(^AUPNVMIC(LIEN,0),U,7) I VALUE="" Q
  1. .. S VIEN=$P(^AUPNVMIC(LIEN,0),U,3) I VIEN="" Q
  1. .. S VSDTM=$$GET1^DIQ(9000010,VIEN_",",.01,"I")\1 I VSDTM=0 Q
  1. .. ; quit if deleted flag
  1. .. I $P($G(^AUPNVSIT(VIEN,0)),U,11)=1 Q
  1. .. S FLAG=$P($G(^AUPNVMIC(LIEN,11)),U,9)
  1. .. I FLAG'="R"&(FLAG'="M") Q
  1. .. S @TEMP@(VSDTM,VIEN,LIEN)=VALUE_U_"9000010.25"_U_TIEN
  1. ;
  1. S VSDTM=""
  1. F S VSDTM=$O(@TEMP@(VSDTM),-1) Q:VSDTM="" D Q:QFL
  1. . S VIEN=""
  1. . F S VIEN=$O(@TEMP@(VSDTM,""),-1) Q:VIEN="" D Q:QFL
  1. .. S LIEN=""
  1. .. F S LIEN=$O(@TEMP@(VSDTM,VIEN,""),-1) Q:LIEN="" D Q:QFL
  1. ... S VALUE=$P(@TEMP@(VSDTM,VIEN,LIEN),U,1),OVALUE=VALUE
  1. ... S FILE=$P(@TEMP@(VSDTM,VIEN,LIEN),U,2)
  1. ... S TIEN=$P(@TEMP@(VSDTM,VIEN,LIEN),U,3)
  1. ... K ROPER
  1. ... S RN=""
  1. ... F S RN=$O(SEARCH(RN)) Q:RN="" D Q:QFL
  1. .... 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)
  1. .... D RCHK
  1. K @TEMP
  1. Q RES
  1. ;
  1. RCHK ;
  1. I OPER="'=",RESULT="",VALUE'="" S RES=1_U_$$FMTE^BQIUL1(VSDTM)_U_VALUE_U_VIEN_U_LIEN_U_TIEN_U_FILE,QFL=1 Q
  1. ;
  1. I RESULT'?.N,VALUE?.N Q
  1. ;
  1. I RESULT="POS",$E(VALUE,1)'?.N,'$$POSITIVE^BQITRUTL(VALUE) Q
  1. I RESULT="POS",$E(VALUE,1)'?.N,$$POSITIVE^BQITRUTL(VALUE) D Q
  1. . S RES=1_U_$$FMTE^BQIUL1(VSDTM)_U_VALUE_U_VIEN_U_LIEN_U_TIEN_U_FILE,QFL=1
  1. I RESULT="NEG",$E(VALUE,1)'?.N,'$$NEGATIVE^BQITRUTL(VALUE) Q
  1. I RESULT="NEG",$E(VALUE,1)'?.N,$$NEGATIVE^BQITRUTL(VALUE) D
  1. . S RES=1_U_$$FMTE^BQIUL1(VSDTM)_U_VALUE_U_VIEN_U_LIEN_U_TIEN_U_FILE,QFL=1
  1. I VALUE'?.PN,VALUE'?.N Q
  1. ;I $E(VALUE,$L(VALUE))?.P S VALUE=VALUE_"0"
  1. I $E(VALUE,$L(VALUE),$L(VALUE))?.P S VALUE=$E(VALUE,1,$L(VALUE)-1)
  1. ; if value starts with a punctuation e.g. < or >
  1. I $E(VALUE,1,1)?.P S ROPER=$E(VALUE,1,1),VALUE=$E(VALUE,2,$L(VALUE))
  1. I RES2="" D
  1. . I $G(ROPER)="",@("VALUE"_OPER_"RESULT") D Q
  1. .. S RES=1_U_$$FMTE^BQIUL1(VSDTM)_U_OVALUE_U_VIEN_U_LIEN_U_TIEN_U_FILE,QFL=1
  1. . I $G(ROPER)'="",OPER=ROPER,@("VALUE"_OPER_"RESULT") D Q
  1. .. S RES=1_U_$$FMTE^BQIUL1(VSDTM)_U_OVALUE_U_VIEN_U_LIEN_U_TIEN_U_FILE,QFL=1
  1. . I $G(ROPER)'="",OPER'=ROPER Q
  1. I RES2'="" D
  1. . I @("VALUE"_OPER_"RESULT"),@("VALUE"_OPER2_"RES2") D
  1. .. S RES=1_U_$$FMTE^BQIUL1(VSDTM)_U_OVALUE_U_VIEN_U_LIEN_U_TIEN_U_FILE,QFL=1
  1. Q
  1. ;
  1. LCHK ;
  1. I OPER="'=",RESULT="",VALUE'="" S @TEMP@(VSDTM,VIEN,LN)=VALUE_U_FILE_U_TIEN Q
  1. ;
  1. I RESULT'?.N,VALUE?.N Q
  1. ;
  1. I RESULT="POS",$E(VALUE,1)'?.N,'$$POSITIVE^BQITRUTL(VALUE) Q
  1. I RESULT="POS",$E(VALUE,1)'?.N,$$POSITIVE^BQITRUTL(VALUE) D Q
  1. . S @TEMP@(VSDTM,VIEN,LN)=VALUE_U_"9000010.25"_U_TIEN
  1. I RESULT="NEG",$E(VALUE,1)'?.N,'$$NEGATIVE^BQITRUTL(VALUE) Q
  1. I RESULT="NEG",$E(VALUE,1)'?.N,$$NEGATIVE^BQITRUTL(VALUE) D
  1. . S @TEMP@(VSDTM,VIEN,LN)=VALUE_U_FILE_U_TIEN
  1. I VALUE'?.PN,VALUE'?.N Q
  1. ;I $E(VALUE,$L(VALUE))?.P S VALUE=VALUE_"0"
  1. I $E(VALUE,$L(VALUE),$L(VALUE))?.P S VALUE=$E(VALUE,1,$L(VALUE)-1)
  1. ; if value starts with a punctuation e.g. < or >
  1. I $E(VALUE,1,1)?.P S ROPER=$E(VALUE,1,1),VALUE=$E(VALUE,2,$L(VALUE))
  1. I RES2="" D
  1. . I $G(ROPER)="",@("VALUE"_OPER_"RESULT") D Q
  1. .. S @TEMP@(VSDTM,VIEN,LN)=VALUE_U_FILE_U_TIEN
  1. . I $G(ROPER)'="",OPER=ROPER,@("VALUE"_OPER_"RESULT") D Q
  1. .. S @TEMP@(VSDTM,VIEN,LN)=VALUE_U_FILE_U_TIEN
  1. . I $G(ROPER)'="",OPER'=ROPER Q
  1. I RES2'="" D
  1. . I @("VALUE"_OPER_"RESULT"),@("VALUE"_OPER2_"RES2") D
  1. .. S @TEMP@(VSDTM,VIEN,LN)=VALUE_U_FILE_U_TIEN
  1. Q
  1. ;
  1. MIC(BQDFN,TIEN,EDT,BDT,MICRO) ;EP - Look through Microbiology file
  1. NEW FLAG,LIEN,VALUE,VIEN,VSDTM
  1. K MICRO
  1. F S BDT=$O(^AUPNVMIC("AA",BQDFN,TIEN,BDT)) Q:BDT=""!(BDT>EDT) D
  1. . S LIEN=""
  1. . F S LIEN=$O(^AUPNVMIC("AA",BQDFN,TIEN,BDT,LIEN)) Q:LIEN="" D
  1. .. S VALUE=$P(^AUPNVMIC(LIEN,0),U,7) I VALUE="" Q
  1. .. S VIEN=$P(^AUPNVMIC(LIEN,0),U,3) I VIEN="" Q
  1. .. S VSDTM=$$GET1^DIQ(9000010,VIEN_",",.01,"I")\1 I VSDTM=0 Q
  1. .. ; quit if deleted flag
  1. .. I $P($G(^AUPNVSIT(VIEN,0)),U,11)=1 Q
  1. .. S FLAG=$P($G(^AUPNVMIC(LIEN,11)),U,9)
  1. .. I FLAG'="R"&(FLAG'="M") Q
  1. .. S MICRO(VSDTM,VIEN,LIEN)=VALUE_U_"9000010.25"_U_TIEN
  1. Q
  1. ;
  1. LBB(TMFRAME,RECENT,DATE,BQDFN,TAX,SEARCH,TREF) ;EP
  1. I $G(TMFRAME)'="" D
  1. . I TMFRAME'["-" Q
  1. . S TMFRAME=$P(TMFRAME,"-",2)
  1. S BDATE=$$FMADD^XLFDT(DATE,-TMFRAME),EDATE=$$FMADD^XLFDT(DATE,TMFRAME)
  1. S TEMP=$NA(^TMP("BQITEMP",UID)) K @TEMP
  1. S TAX=$G(TAX,""),RECENT=$G(RECENT,0)
  1. I TAX'="" D
  1. . S TREF=$NA(^TMP("BQITAX",UID))
  1. . K @TREF
  1. . D BLD^BQITUTL(TAX,TREF)
  1. ;
  1. S LIEN="",QFL=0,RES=0_U_"No Test",CT=0
  1. D
  1. . S TIEN=""
  1. . F S TIEN=$O(@TREF@(TIEN)) Q:TIEN="" D
  1. .. S EDT=9999999-BDATE,BDT=(9999999-EDATE)-.001
  1. .. I $P($G(^LAB(60,TIEN,0)),U,4)="MI" D Q
  1. ... D MIC(BQDFN,TIEN,EDT,BDT,.MICRO)
  1. ... M @TEMP=MICRO
  1. ... K MICRO
  1. .. F S BDT=$O(^AUPNVLAB("AA",BQDFN,TIEN,BDT)) Q:BDT=""!(BDT>EDT) D
  1. ... S LIEN=""
  1. ... F S LIEN=$O(^AUPNVLAB("AA",BQDFN,TIEN,BDT,LIEN)) Q:LIEN="" D
  1. .... S VALUE=$P(^AUPNVLAB(LIEN,0),U,4) I VALUE="" Q
  1. .... S VIEN=$P(^AUPNVLAB(LIEN,0),U,3) I VIEN="" Q
  1. .... S FLAG=$P($G(^AUPNVLAB(LIEN,11)),U,9) I FLAG="" Q
  1. .... I FLAG'="R"&(FLAG'="M") Q
  1. .... S VSDTM=$$GET1^DIQ(9000010,VIEN_",",.01,"I")\1 I VSDTM=0 Q
  1. .... ;I $G(TMFRAME)'="",VSDTM<BDATE Q
  1. .... ; quit if deleted flag
  1. .... I $P($G(^AUPNVSIT(VIEN,0)),U,11)=1 Q
  1. .... I $P($G(^AUPNVLAB(LIEN,11)),U,9)="D" Q
  1. .... S @TEMP@(VSDTM,VIEN,LIEN)=VALUE_U_"9000010.09"_U_TIEN
  1. ;
  1. S VSDTM=""
  1. F S VSDTM=$O(@TEMP@(VSDTM),-1) Q:VSDTM="" D Q:QFL
  1. . S VIEN=$O(@TEMP@(VSDTM,""),-1)
  1. . S LIEN=$O(@TEMP@(VSDTM,VIEN,""),-1)
  1. . S VALUE=$P(@TEMP@(VSDTM,VIEN,LIEN),U,1),OVALUE=VALUE
  1. . S FILE=$P(@TEMP@(VSDTM,VIEN,LIEN),U,2)
  1. . S TIEN=$P(@TEMP@(VSDTM,VIEN,LIEN),U,3)
  1. . K ROPER
  1. . S RN=""
  1. . F S RN=$O(SEARCH(RN)) Q:RN="" D Q:QFL
  1. .. 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)
  1. .. D RCHK
  1. K @TEMP
  1. Q RES