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

BQIDCAH7.m

Go to the documentation of this file.
  1. BQIDCAH7 ;GDHD/HCD/ALA-Ad Hoc Logic ; 17 Jan 2017 3:44 PM
  1. ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
  1. ;
  1. MEAS(FGLOB,TGLOB,MEAS,FDT,TDT,MSNOT,MPARMS) ;EP - Measurement search
  1. NEW NGLOB,LCT,CT,IEN,LOK,MSRES,MSRSN,MSURNP,MURES,RES,ROK,RVAL,LB,LIEN
  1. NEW CMEAS,BBOTH,ABOTH,BMEAS,BPARMS,CPAR,BQMEAS,CPARMS,PPARMS,BNUMMEAS,FLG
  1. NEW BPRES,COD,NUMMEAS,SETMEAS,SRES,TCT
  1. S NGLOB=$NA(^TMP("BQIDCMEAS",$J)) K @NGLOB
  1. S MSGLOB=$NA(^TMP("BQIMSOP",$J)) K @MSGLOB
  1. I $G(TGLOB)="" Q
  1. ;
  1. S BBOTH=0,ABOTH=0,TCT=0
  1. ;
  1. I $G(MEAS)'="" D
  1. . NEW BMEAS
  1. . S COD=$P(^BQI(90507.2,MEAS,0),"^",2),CMEAS=$P(^(0),"^",3),BMEAS=MEAS
  1. . I $D(APARMS) D
  1. .. I COD="SYS" S BBOTH=BBOTH+1 D VL Q
  1. .. I COD="DIA" S BBOTH=BBOTH+1 D VL Q
  1. .. I COD="ASYS" S ABOTH=ABOTH+1 D VL Q
  1. .. I COD="ADIA" S ABOTH=ABOTH+1 D VL Q
  1. .. S RVAL=$O(APARMS("MEAS",MEAS,""))
  1. .. I RVAL="NUMMEAS" S NUMMEAS=APARMS("MEAS",MEAS,"NUMMEAS"),CPARMS("MEAS",CMEAS,"NUMMEAS")=NUMMEAS
  1. .. I RVAL="SETMEAS" S SETMEAS=APARMS("MEAS",MEAS,"SETMEAS"),CPARMS("MEAS",CMEAS,"SETMEAS")=SETMEAS
  1. . I $D(MAPARMS) D
  1. .. S RVAL=$O(MAPARMS("MEAS",MEAS,""))
  1. .. I RVAL="SETMEAS" S PPARMS("MEAS",CMEAS)=RVAL D
  1. ... S RV="" F S RV=$O(MAPARMS("MEAS",MEAS,RVAL,RV)) Q:RV="" S CPARMS("MEAS",CMEAS,"SETMEAS",RV)=""
  1. ... K MAPARMS
  1. ... M MAPARMS=CPARMS
  1. ... K CPARMS
  1. . I '$D(APARMS),'$D(MAPARMS) S PPARMS("MEAS",CMEAS)=""
  1. ;
  1. D
  1. . S BMEAS="" F S BMEAS=$O(MPARMS("MEAS",BMEAS)) Q:BMEAS="" D
  1. .. S COD=$P(^BQI(90507.2,BMEAS,0),"^",2),CMEAS=$P(^(0),"^",3)
  1. .. I $D(APARMS("MEAS",BMEAS)) D Q
  1. ... I COD="SYS" S BBOTH=BBOTH+1 D VL Q
  1. ... I COD="DIA" S BBOTH=BBOTH+1 D VL Q
  1. ... I COD="ASYS" S ABOTH=ABOTH+1 D VL Q
  1. ... I COD="ADIA" S ABOTH=ABOTH+1 D VL Q
  1. ... S RVAL=$O(APARMS("MEAS",BMEAS,""))
  1. ... I RVAL="NUMMEAS" S NUMMEAS=APARMS("MEAS",BMEAS,"NUMMEAS"),CPARMS("MEAS",CMEAS,"NUMMEAS")=NUMMEAS
  1. ... I RVAL="SETMEAS" S SETMEAS=APARMS("MEAS",BMEAS,"SETMEAS"),CPARMS("MEAS",CMEAS,"SETMEAS")=SETMEAS
  1. .. S PPARMS("MEAS",CMEAS)=""
  1. ;
  1. S BMEAS="" F S BMEAS=$O(CPARMS("MEAS",BMEAS)) Q:BMEAS="" D
  1. . K RVAL,NUMMEAS,SETMEAS
  1. . S RVAL=$O(CPARMS("MEAS",BMEAS,"")),TCT=TCT+1
  1. . I RVAL="NUMMEAS" S NUMMEAS=CPARMS("MEAS",BMEAS,"NUMMEAS")
  1. . I RVAL="SETMEAS" S SETMEAS=CPARMS("MEAS",BMEAS,"SETMEAS")
  1. . D MS(BMEAS,1)
  1. . K RVAL,NUMMEAS,SETMEAS
  1. ;
  1. S BMEAS="" F S BMEAS=$O(PPARMS("MEAS",BMEAS)) Q:BMEAS="" D
  1. . S RVAL=PPARMS("MEAS",BMEAS),TCT=TCT+1
  1. . I RVAL="NUMMEAS" S NUMMEAS=1
  1. . I RVAL="SETMEAS" S SETMEAS=1
  1. . D MS(BMEAS,0)
  1. ;
  1. I MSOP="!" D
  1. . S IEN=""
  1. . F S IEN=$O(@MSGLOB@(IEN)) Q:IEN="" S @TGLOB@(IEN)=""
  1. I MSOP="&" D
  1. . S IEN=""
  1. . F S IEN=$O(@MSGLOB@(IEN)) Q:IEN="" D
  1. .. S LCT=0,LB=""
  1. .. F S LB=$O(@MSGLOB@(IEN,LB)) Q:LB="" S LCT=LCT+1
  1. .. I LCT'=TCT K @CRIT@("MEAS",IEN) Q
  1. .. I LCT=TCT,'MSNOT D
  1. ... S @TGLOB@(IEN)="",LB=""
  1. ... F S LB=$O(@MSGLOB@(IEN,LB)) Q:LB="" D
  1. .... S LIEN=""
  1. .... F S LIEN=$O(@MSGLOB@(IEN,LB,LIEN)) Q:LIEN="" S @CRIT@("MEAS",IEN,LIEN)=""
  1. .. I LCT=TCT,MSNOT S @NGLOB@(IEN)="" K @CRIT@("MEAS",IEN)
  1. ;
  1. I MSNOT,$G(FGLOB)'="" D
  1. . S IEN="" F S IEN=$O(@FGLOB@(IEN)) Q:IEN="" D
  1. .. I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
  1. I MSNOT,$G(FGLOB)="" D
  1. . S IEN=0 F S IEN=$O(^AUPNPAT(IEN)) Q:'IEN I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
  1. K @NGLOB,@MSGLOB
  1. Q
  1. ;
  1. VL ;EP
  1. S RVAL=$O(APARMS("MEAS",BMEAS,"")),BPARMS("MEAS",COD,RVAL)=APARMS("MEAS",BMEAS,RVAL),CPAR(COD)=CMEAS
  1. S PPARMS("MEAS",CMEAS)=RVAL
  1. Q
  1. ;
  1. MS(MEAS,FLG) ;EP
  1. NEW DFN,IEN,BGT,BDT,ENT,VIS,VSDTM
  1. S TDT=$S(TDT'="":TDT,1:DT)
  1. I $G(FGLOB)'="" D Q
  1. . NEW IEN
  1. . S IEN=""
  1. . F S IEN=$O(@FGLOB@(IEN)) Q:'IEN D
  1. .. I FDT="" D
  1. ... S BDT=""
  1. ... F S BDT=$O(^AUPNVMSR("AA",IEN,MEAS,BDT)) Q:BDT="" D MSDT
  1. .. I FDT'="" D
  1. ... S BGT=9999999-FDT,ENT=9999999-TDT,BDT=ENT-1
  1. ... F S BDT=$O(^AUPNVMSR("AA",IEN,MEAS,BDT)) Q:BDT=""!(BDT>BGT) D MSDT
  1. ;
  1. S IEN=""
  1. F S IEN=$O(^AUPNVMSR("B",MEAS,IEN),-1) Q:IEN="" D
  1. . I $G(^AUPNVMSR(IEN,0))="" Q
  1. . ; if the new ENTERED IN ERROR field exists, exclude the record if it is marked as an error
  1. . I $$VFIELD^DILFD(9000010.01,2) Q:$$GET1^DIQ(9000010.01,IEN_",",2,"I")=1
  1. . S DFN=$P($G(^AUPNVMSR(IEN,0)),U,2),VIS=$P(^AUPNVMSR(IEN,0),U,3) I VIS="" Q
  1. . I $G(^AUPNVSIT(VIS,0))="" Q
  1. . Q:"DXCT"[$P(^AUPNVSIT(VIS,0),U,7)
  1. . S VSDTM=$P(^AUPNVSIT(VIS,0),U,1)\1
  1. . I FDT'="",VSDTM<FDT!(VSDTM>TDT) Q
  1. . ;B:MEAS=2
  1. . S MSRES=$P($G(^AUPNVMSR(IEN,0)),U,4),MURES=$$UP^XLFSTR(MSRES)
  1. . S MSRSN=$$PUNC^BQIUL3(MSRES),MSURNP=$$PUNC^BQIUL3(MURES)
  1. . ;
  1. . ; If looking for a MEAS result
  1. . S RES=0
  1. . I $G(SETMEAS)="",$G(NUMMEAS)="" S ROK=1,RES=1,LOK=1
  1. . I $G(SETMEAS)'=""!($G(NUMMEAS)'="") S ROK=1,LOK=0 D MSR
  1. . ;I $G(SETMEAS)'=""!($G(NUMMEAS)'="")!($D(BPARMS("MEAS"))) S ROK=1,LOK=0 D MSR
  1. . I 'MSNOT D Q
  1. .. I ROK,'RES Q
  1. .. S @MSGLOB@(DFN,MEAS,IEN)=MSRES
  1. .. I LOK S @CRIT@("MEAS",DFN,IEN)=""
  1. . I MSNOT D Q
  1. .. I ROK,'RES Q
  1. .. S @NGLOB@(DFN)=""
  1. .. I LOK S @CRIT@("MEAS",DFN,IEN)=""
  1. Q
  1. ;
  1. MSDT ;EP
  1. S LIEN=""
  1. F S LIEN=$O(^AUPNVMSR("AA",IEN,MEAS,BDT,LIEN)) Q:LIEN="" D
  1. . S VIS=$P($G(^AUPNVMSR(LIEN,0)),U,3) I VIS="" Q
  1. . I $G(^AUPNVSIT(VIS,0))="" Q
  1. . ; if the new ENTERED IN ERROR field exists, exclude the record if it is marked as an error
  1. . I $$VFIELD^DILFD(9000010.01,2) Q:$$GET1^DIQ(9000010.01,LIEN_",",2,"I")=1
  1. . Q:"DXCT"[$P(^AUPNVSIT(VIS,0),U,7)
  1. . S MSRES=$P($G(^AUPNVMSR(LIEN,0)),U,4),MURES=$$UP^XLFSTR(MSRES)
  1. . S MSRSN=$$PUNC^BQIUL3(MSRES),MSURNP=$$PUNC^BQIUL3(MURES)
  1. . ; If looking for a MEAS result
  1. . S RES=0
  1. . I $G(SETMEAS)="",$G(NUMMEAS)="" S ROK=1,RES=1,LOK=1
  1. . I $G(SETMEAS)'=""!($G(NUMMEAS)'="") S ROK=1,LOK=0 D MSR
  1. . ;I $G(SETMEAS)'=""!($G(NUMMEAS)'="")!($D(BPARMS("MEAS"))) S ROK=1,LOK=0 D MSR
  1. . I 'MSNOT D Q
  1. .. I ROK,'RES Q
  1. .. S @MSGLOB@(IEN,MEAS,LIEN)=MSRES
  1. .. I LOK S @CRIT@("MEAS",IEN,LIEN)=""
  1. . I MSNOT D Q
  1. .. I ROK,'RES Q
  1. .. S @NGLOB@(IEN)=""
  1. .. I LOK S @CRIT@("MEAS",IEN,LIEN)=""
  1. Q
  1. ;
  1. MSR ;EP - Measurement results
  1. I MSRES="" Q
  1. NEW MSR,VCRIT1,VCRIT2,ROPER,OPER,OPER2,RES1,RES2,SCODE,LI,MSRS,FQL,I
  1. I $D(MAPARMS("MEAS",MEAS,"SETMEAS")) D Q
  1. . S MSR="" F S MSR=$O(MAPARMS("MEAS",MEAS,"SETMEAS",MSR)) Q:MSR="" D Q:LOK
  1. .. I MSRES=MSR S LOK=1,RES=1 Q
  1. .. S SCODE=$$MSET(MEAS)
  1. .. NEW SETMEAS
  1. .. S SETMEAS=MSR D SCD
  1. . ;
  1. I $G(SETMEAS)'="",MSRES=SETMEAS S LOK=1,RES=1 Q
  1. I $G(SETMEAS)'="",MSRES'=SETMEAS D Q
  1. . I SETMEAS=MURES S LOK=1,RES=1 Q
  1. . S SCODE=$$MSET(MEAS)
  1. . D SCD
  1. ;
  1. ;I $G(SETMEAS)'="",'$D(MAPARMS("MEAS",MEAS,"SETMEAS")),MSRES=$P(SCODE,":",1)!(MSRES=$P(SCODE,":",2)) S LOK=1,RES=1 Q
  1. ;
  1. I $G(NUMMEAS)'="",$G(FLG)=1 D Q
  1. . NEW REX,SRES,DRES,BPRES,BQMEAS,BNUMMEAS
  1. . I $G(NUMMEAS)["~" S REX=1
  1. . I $G(NUMMEAS)["~",$G(NUMMEAS)["'" S REX=0
  1. . I MSRES?.ULP Q
  1. . I MSRES'?.PN,MSRES'?.N Q
  1. . I $E(MSRES,$L(MSRES),$L(MSRES))?.P S MSRES=$E(MSRES,1,$L(MSRES)-1)
  1. . ; if value starts with a punctuation e.g. < or >
  1. . I $E(MSRES,1,1)?.P S ROPER=$E(MSRES,1,1),MSRES=$E(MSRES,2,$L(MSRES))
  1. . I $P(^AUTTMSR(MEAS,0),"^",1)="EGA" D
  1. .. I MSRES["/" S MSRES=$P(MSRES," ",1)
  1. . D NCHK(NUMMEAS)
  1. ;
  1. I $G(NUMMEAS)'="",$G(FLG)=0 D Q
  1. . I $G(BBOTH)!($G(ABOTH)) D Q
  1. .. S BPRES=MSRES,SRES=0,DRES=0
  1. .. I $G(BBOTH)'=0 F BQMEAS="DIA","SYS" S LOK=0,RES=0 D
  1. ... I $G(CPAR(BQMEAS))'=MEAS Q
  1. ... S BNUMMEAS=$G(BPARMS("MEAS",BQMEAS,"NUMMEAS"))
  1. ... I BNUMMEAS="" Q
  1. ... I BNUMMEAS["~" S REX=1
  1. ... I BNUMMEAS["~",BNUMMEAS["'" S REX=0
  1. ... I $G(BQMEAS)["SYS" S MSRES=$P(MSRES,"/",1) D NCHK(BNUMMEAS) S SRES=RES,MSRES=BPRES
  1. ... I $G(BQMEAS)["DIA" S MSRES=$P(MSRES,"/",2) D NCHK(BNUMMEAS) S DRES=RES,MSRES=BPRES
  1. .. I $G(ABOTH)'=0 F BQMEAS="ADIA","ASYS" S LOK=0,RES=0 D
  1. ... I $G(CPAR(BQMEAS))'=MEAS Q
  1. ... S BNUMMEAS=$G(BPARMS("MEAS",BQMEAS,"NUMMEAS"))
  1. ... I BNUMMEAS="" Q
  1. ... I BNUMMEAS["~" S REX=1
  1. ... I BNUMMEAS["~",BNUMMEAS["'" S REX=0
  1. ... I $G(BQMEAS)["SYS" S MSRES=$P(MSRES,"/",1) D NCHK(BNUMMEAS) S SRES=RES,MSRES=BPRES
  1. ... I $G(BQMEAS)["DIA" S MSRES=$P(MSRES,"/",2) D NCHK(BNUMMEAS) S DRES=RES,MSRES=BPRES
  1. .. S LOK=0,RES=0
  1. .. I $G(BBOTH)'=0,BPOP="&" D Q
  1. ... I SRES=1,DRES=1 S LOK=1,RES=1
  1. .. I $G(ABOTH)'=0,ABPOP="&" D Q
  1. ... I SRES=1,DRES=1 S LOK=1,RES=1
  1. .. I BPOP="!"!(ABPOP="!") D
  1. ... I SRES=1!(DRES=1) S LOK=1,RES=1
  1. Q
  1. ;
  1. NCHK(NUMMEAS) ;
  1. I NUMMEAS["~" S VCRIT1=$P(NUMMEAS,"~",1),VCRIT2=$P(NUMMEAS,"~",2)
  1. E S VCRIT1=NUMMEAS,VCRIT2=""
  1. F I=1:1:$L(VCRIT1) Q:$E(VCRIT1,I,I)'?.P
  1. S OPER=$E(VCRIT1,1,I-1),RES1=$E(VCRIT1,I,$L(VCRIT1))
  1. I $E(OPER,$L(OPER),$L(OPER))="." D
  1. . S OPER=$E(OPER,1,$L(OPER)-1),RES1="."_RES1
  1. I $G(VCRIT2)'="" D
  1. . F I=1:1:$L(VCRIT2) Q:$E(VCRIT2,I,I)'?.P
  1. . S OPER2=$E(VCRIT2,1,I-1),RES2=$E(VCRIT2,I,$L(VCRIT2))
  1. . I $E(OPER2,$L(OPER2),$L(OPER2))="." D
  1. .. S OPER2=$E(OPER2,1,$L(OPER2)-1),RES2="."_RES2
  1. I VCRIT2="" D
  1. . I $G(ROPER)="",@("MSRES"_OPER_"RES1") S LOK=1,RES=1 Q
  1. . I $G(ROPER)'="",OPER=ROPER,@("MSRES"_OPER_"RES1") S LOK=1,RES=1 Q
  1. . I $G(ROPER)'="",OPER'=ROPER Q
  1. I VCRIT2'="" D
  1. . I @("MSRES"_OPER_"RES1"),@("MSRES"_OPER2_"RES2") S LOK=1,RES=1
  1. . I REX D
  1. .. I @("MSRES"_OPER_"RES1") S LOK=1,RES=1
  1. .. I @("MSRES"_OPER2_"RES2") S LOK=1,RES=1
  1. Q
  1. ;
  1. SCD ;EP
  1. NEW LCOD,LCODU,LCODP,LVAL,LVALU,LVALP
  1. F LI=1:1:$L(SCODE,";") S FQL=0 D Q:FQL
  1. . S MSRS=$P(SCODE,";",LI),ROK=1,RES=0
  1. . NEW LCOD,LCODU,LCODP
  1. . ; Set code exactly, set code uppercase, set code no punctuation
  1. . S LCOD=$P(MSRS,":",1),LCODU=$$UP^XLFSTR(LCOD),LCODP=$$PUNC^BQIUL3(LCOD)
  1. . ; Set value exactly, set value uppercase, set value no punctuation
  1. . S LVAL=$P(MSRS,":",2),LVALU=$$UP^XLFSTR(LVAL),LVALP=$$PUNC^BQIUL3(LVAL)
  1. . ;
  1. . ; If the set code matches the actual MEAS result
  1. . I SETMEAS=LCOD D Q
  1. .. I MSRES=LCOD S LOK=1,RES=1,FQL=1 Q
  1. .. I MURES=LCODU S LOK=1,RES=1,FQL=1 Q
  1. .. I MSURNP=LCODP S LOK=1,RES=1,FQL=1 Q
  1. .. I MSRES=LVAL S LOK=1,RES=1,FQL=1 Q
  1. .. I MURES=LVALU S LOK=1,RES=1,FQL=1 Q
  1. .. I MSURNP=LVALP S LOK=1,RES=1,FQL=1 Q
  1. Q
  1. ;
  1. MSET(LN) ;EP - Set of codes
  1. NEW COD,IEN,VALUE,TYPE
  1. S VALUE=""
  1. S COD=$P(^AUTTMSR(LN,0),U,1),IEN=$O(^BQI(90507.2,"C",COD,"")) I IEN="" Q VALUE
  1. S TYPE=$$GET1^DIQ(90507.2,IEN_",",.04,"E")
  1. I TYPE["SET" S VALUE=$G(^BQI(90507.2,IEN,2))
  1. Q VALUE