BQIDCAH7 ;GDHD/HCD/ALA-Ad Hoc Logic ; 17 Jan 2017 3:44 PM
;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
;
MEAS(FGLOB,TGLOB,MEAS,FDT,TDT,MSNOT,MPARMS) ;EP - Measurement search
NEW NGLOB,LCT,CT,IEN,LOK,MSRES,MSRSN,MSURNP,MURES,RES,ROK,RVAL,LB,LIEN
NEW CMEAS,BBOTH,ABOTH,BMEAS,BPARMS,CPAR,BQMEAS,CPARMS,PPARMS,BNUMMEAS,FLG
NEW BPRES,COD,NUMMEAS,SETMEAS,SRES,TCT
S NGLOB=$NA(^TMP("BQIDCMEAS",$J)) K @NGLOB
S MSGLOB=$NA(^TMP("BQIMSOP",$J)) K @MSGLOB
I $G(TGLOB)="" Q
;
S BBOTH=0,ABOTH=0,TCT=0
;
I $G(MEAS)'="" D
. NEW BMEAS
. S COD=$P(^BQI(90507.2,MEAS,0),"^",2),CMEAS=$P(^(0),"^",3),BMEAS=MEAS
. I $D(APARMS) D
.. I COD="SYS" S BBOTH=BBOTH+1 D VL Q
.. I COD="DIA" S BBOTH=BBOTH+1 D VL Q
.. I COD="ASYS" S ABOTH=ABOTH+1 D VL Q
.. I COD="ADIA" S ABOTH=ABOTH+1 D VL Q
.. S RVAL=$O(APARMS("MEAS",MEAS,""))
.. I RVAL="NUMMEAS" S NUMMEAS=APARMS("MEAS",MEAS,"NUMMEAS"),CPARMS("MEAS",CMEAS,"NUMMEAS")=NUMMEAS
.. I RVAL="SETMEAS" S SETMEAS=APARMS("MEAS",MEAS,"SETMEAS"),CPARMS("MEAS",CMEAS,"SETMEAS")=SETMEAS
. I $D(MAPARMS) D
.. S RVAL=$O(MAPARMS("MEAS",MEAS,""))
.. I RVAL="SETMEAS" S PPARMS("MEAS",CMEAS)=RVAL D
... S RV="" F S RV=$O(MAPARMS("MEAS",MEAS,RVAL,RV)) Q:RV="" S CPARMS("MEAS",CMEAS,"SETMEAS",RV)=""
... K MAPARMS
... M MAPARMS=CPARMS
... K CPARMS
. I '$D(APARMS),'$D(MAPARMS) S PPARMS("MEAS",CMEAS)=""
;
D
. S BMEAS="" F S BMEAS=$O(MPARMS("MEAS",BMEAS)) Q:BMEAS="" D
.. S COD=$P(^BQI(90507.2,BMEAS,0),"^",2),CMEAS=$P(^(0),"^",3)
.. I $D(APARMS("MEAS",BMEAS)) D Q
... I COD="SYS" S BBOTH=BBOTH+1 D VL Q
... I COD="DIA" S BBOTH=BBOTH+1 D VL Q
... I COD="ASYS" S ABOTH=ABOTH+1 D VL Q
... I COD="ADIA" S ABOTH=ABOTH+1 D VL Q
... S RVAL=$O(APARMS("MEAS",BMEAS,""))
... I RVAL="NUMMEAS" S NUMMEAS=APARMS("MEAS",BMEAS,"NUMMEAS"),CPARMS("MEAS",CMEAS,"NUMMEAS")=NUMMEAS
... I RVAL="SETMEAS" S SETMEAS=APARMS("MEAS",BMEAS,"SETMEAS"),CPARMS("MEAS",CMEAS,"SETMEAS")=SETMEAS
.. S PPARMS("MEAS",CMEAS)=""
;
S BMEAS="" F S BMEAS=$O(CPARMS("MEAS",BMEAS)) Q:BMEAS="" D
. K RVAL,NUMMEAS,SETMEAS
. S RVAL=$O(CPARMS("MEAS",BMEAS,"")),TCT=TCT+1
. I RVAL="NUMMEAS" S NUMMEAS=CPARMS("MEAS",BMEAS,"NUMMEAS")
. I RVAL="SETMEAS" S SETMEAS=CPARMS("MEAS",BMEAS,"SETMEAS")
. D MS(BMEAS,1)
. K RVAL,NUMMEAS,SETMEAS
;
S BMEAS="" F S BMEAS=$O(PPARMS("MEAS",BMEAS)) Q:BMEAS="" D
. S RVAL=PPARMS("MEAS",BMEAS),TCT=TCT+1
. I RVAL="NUMMEAS" S NUMMEAS=1
. I RVAL="SETMEAS" S SETMEAS=1
. D MS(BMEAS,0)
;
I MSOP="!" D
. S IEN=""
. F S IEN=$O(@MSGLOB@(IEN)) Q:IEN="" S @TGLOB@(IEN)=""
I MSOP="&" D
. S IEN=""
. F S IEN=$O(@MSGLOB@(IEN)) Q:IEN="" D
.. S LCT=0,LB=""
.. F S LB=$O(@MSGLOB@(IEN,LB)) Q:LB="" S LCT=LCT+1
.. I LCT'=TCT K @CRIT@("MEAS",IEN) Q
.. I LCT=TCT,'MSNOT D
... S @TGLOB@(IEN)="",LB=""
... F S LB=$O(@MSGLOB@(IEN,LB)) Q:LB="" D
.... S LIEN=""
.... F S LIEN=$O(@MSGLOB@(IEN,LB,LIEN)) Q:LIEN="" S @CRIT@("MEAS",IEN,LIEN)=""
.. I LCT=TCT,MSNOT S @NGLOB@(IEN)="" K @CRIT@("MEAS",IEN)
;
I MSNOT,$G(FGLOB)'="" D
. S IEN="" F S IEN=$O(@FGLOB@(IEN)) Q:IEN="" D
.. I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
I MSNOT,$G(FGLOB)="" D
. S IEN=0 F S IEN=$O(^AUPNPAT(IEN)) Q:'IEN I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
K @NGLOB,@MSGLOB
Q
;
VL ;EP
S RVAL=$O(APARMS("MEAS",BMEAS,"")),BPARMS("MEAS",COD,RVAL)=APARMS("MEAS",BMEAS,RVAL),CPAR(COD)=CMEAS
S PPARMS("MEAS",CMEAS)=RVAL
Q
;
MS(MEAS,FLG) ;EP
NEW DFN,IEN,BGT,BDT,ENT,VIS,VSDTM
S TDT=$S(TDT'="":TDT,1:DT)
I $G(FGLOB)'="" D Q
. NEW IEN
. S IEN=""
. F S IEN=$O(@FGLOB@(IEN)) Q:'IEN D
.. I FDT="" D
... S BDT=""
... F S BDT=$O(^AUPNVMSR("AA",IEN,MEAS,BDT)) Q:BDT="" D MSDT
.. I FDT'="" D
... S BGT=9999999-FDT,ENT=9999999-TDT,BDT=ENT-1
... F S BDT=$O(^AUPNVMSR("AA",IEN,MEAS,BDT)) Q:BDT=""!(BDT>BGT) D MSDT
;
S IEN=""
F S IEN=$O(^AUPNVMSR("B",MEAS,IEN),-1) Q:IEN="" D
. I $G(^AUPNVMSR(IEN,0))="" 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
. S DFN=$P($G(^AUPNVMSR(IEN,0)),U,2),VIS=$P(^AUPNVMSR(IEN,0),U,3) I VIS="" Q
. I $G(^AUPNVSIT(VIS,0))="" Q
. Q:"DXCT"[$P(^AUPNVSIT(VIS,0),U,7)
. S VSDTM=$P(^AUPNVSIT(VIS,0),U,1)\1
. I FDT'="",VSDTM<FDT!(VSDTM>TDT) Q
. ;B:MEAS=2
. S MSRES=$P($G(^AUPNVMSR(IEN,0)),U,4),MURES=$$UP^XLFSTR(MSRES)
. S MSRSN=$$PUNC^BQIUL3(MSRES),MSURNP=$$PUNC^BQIUL3(MURES)
. ;
. ; If looking for a MEAS result
. S RES=0
. I $G(SETMEAS)="",$G(NUMMEAS)="" S ROK=1,RES=1,LOK=1
. I $G(SETMEAS)'=""!($G(NUMMEAS)'="") S ROK=1,LOK=0 D MSR
. ;I $G(SETMEAS)'=""!($G(NUMMEAS)'="")!($D(BPARMS("MEAS"))) S ROK=1,LOK=0 D MSR
. I 'MSNOT D Q
.. I ROK,'RES Q
.. S @MSGLOB@(DFN,MEAS,IEN)=MSRES
.. I LOK S @CRIT@("MEAS",DFN,IEN)=""
. I MSNOT D Q
.. I ROK,'RES Q
.. S @NGLOB@(DFN)=""
.. I LOK S @CRIT@("MEAS",DFN,IEN)=""
Q
;
MSDT ;EP
S LIEN=""
F S LIEN=$O(^AUPNVMSR("AA",IEN,MEAS,BDT,LIEN)) Q:LIEN="" D
. S VIS=$P($G(^AUPNVMSR(LIEN,0)),U,3) I VIS="" Q
. I $G(^AUPNVSIT(VIS,0))="" 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,LIEN_",",2,"I")=1
. Q:"DXCT"[$P(^AUPNVSIT(VIS,0),U,7)
. S MSRES=$P($G(^AUPNVMSR(LIEN,0)),U,4),MURES=$$UP^XLFSTR(MSRES)
. S MSRSN=$$PUNC^BQIUL3(MSRES),MSURNP=$$PUNC^BQIUL3(MURES)
. ; If looking for a MEAS result
. S RES=0
. I $G(SETMEAS)="",$G(NUMMEAS)="" S ROK=1,RES=1,LOK=1
. I $G(SETMEAS)'=""!($G(NUMMEAS)'="") S ROK=1,LOK=0 D MSR
. ;I $G(SETMEAS)'=""!($G(NUMMEAS)'="")!($D(BPARMS("MEAS"))) S ROK=1,LOK=0 D MSR
. I 'MSNOT D Q
.. I ROK,'RES Q
.. S @MSGLOB@(IEN,MEAS,LIEN)=MSRES
.. I LOK S @CRIT@("MEAS",IEN,LIEN)=""
. I MSNOT D Q
.. I ROK,'RES Q
.. S @NGLOB@(IEN)=""
.. I LOK S @CRIT@("MEAS",IEN,LIEN)=""
Q
;
MSR ;EP - Measurement results
I MSRES="" Q
NEW MSR,VCRIT1,VCRIT2,ROPER,OPER,OPER2,RES1,RES2,SCODE,LI,MSRS,FQL,I
I $D(MAPARMS("MEAS",MEAS,"SETMEAS")) D Q
. S MSR="" F S MSR=$O(MAPARMS("MEAS",MEAS,"SETMEAS",MSR)) Q:MSR="" D Q:LOK
.. I MSRES=MSR S LOK=1,RES=1 Q
.. S SCODE=$$MSET(MEAS)
.. NEW SETMEAS
.. S SETMEAS=MSR D SCD
. ;
I $G(SETMEAS)'="",MSRES=SETMEAS S LOK=1,RES=1 Q
I $G(SETMEAS)'="",MSRES'=SETMEAS D Q
. I SETMEAS=MURES S LOK=1,RES=1 Q
. S SCODE=$$MSET(MEAS)
. D SCD
;
;I $G(SETMEAS)'="",'$D(MAPARMS("MEAS",MEAS,"SETMEAS")),MSRES=$P(SCODE,":",1)!(MSRES=$P(SCODE,":",2)) S LOK=1,RES=1 Q
;
I $G(NUMMEAS)'="",$G(FLG)=1 D Q
. NEW REX,SRES,DRES,BPRES,BQMEAS,BNUMMEAS
. I $G(NUMMEAS)["~" S REX=1
. I $G(NUMMEAS)["~",$G(NUMMEAS)["'" S REX=0
. I MSRES?.ULP Q
. I MSRES'?.PN,MSRES'?.N Q
. I $E(MSRES,$L(MSRES),$L(MSRES))?.P S MSRES=$E(MSRES,1,$L(MSRES)-1)
. ; if value starts with a punctuation e.g. < or >
. I $E(MSRES,1,1)?.P S ROPER=$E(MSRES,1,1),MSRES=$E(MSRES,2,$L(MSRES))
. I $P(^AUTTMSR(MEAS,0),"^",1)="EGA" D
.. I MSRES["/" S MSRES=$P(MSRES," ",1)
. D NCHK(NUMMEAS)
;
I $G(NUMMEAS)'="",$G(FLG)=0 D Q
. I $G(BBOTH)!($G(ABOTH)) D Q
.. S BPRES=MSRES,SRES=0,DRES=0
.. I $G(BBOTH)'=0 F BQMEAS="DIA","SYS" S LOK=0,RES=0 D
... I $G(CPAR(BQMEAS))'=MEAS Q
... S BNUMMEAS=$G(BPARMS("MEAS",BQMEAS,"NUMMEAS"))
... I BNUMMEAS="" Q
... I BNUMMEAS["~" S REX=1
... I BNUMMEAS["~",BNUMMEAS["'" S REX=0
... I $G(BQMEAS)["SYS" S MSRES=$P(MSRES,"/",1) D NCHK(BNUMMEAS) S SRES=RES,MSRES=BPRES
... I $G(BQMEAS)["DIA" S MSRES=$P(MSRES,"/",2) D NCHK(BNUMMEAS) S DRES=RES,MSRES=BPRES
.. I $G(ABOTH)'=0 F BQMEAS="ADIA","ASYS" S LOK=0,RES=0 D
... I $G(CPAR(BQMEAS))'=MEAS Q
... S BNUMMEAS=$G(BPARMS("MEAS",BQMEAS,"NUMMEAS"))
... I BNUMMEAS="" Q
... I BNUMMEAS["~" S REX=1
... I BNUMMEAS["~",BNUMMEAS["'" S REX=0
... I $G(BQMEAS)["SYS" S MSRES=$P(MSRES,"/",1) D NCHK(BNUMMEAS) S SRES=RES,MSRES=BPRES
... I $G(BQMEAS)["DIA" S MSRES=$P(MSRES,"/",2) D NCHK(BNUMMEAS) S DRES=RES,MSRES=BPRES
.. S LOK=0,RES=0
.. I $G(BBOTH)'=0,BPOP="&" D Q
... I SRES=1,DRES=1 S LOK=1,RES=1
.. I $G(ABOTH)'=0,ABPOP="&" D Q
... I SRES=1,DRES=1 S LOK=1,RES=1
.. I BPOP="!"!(ABPOP="!") D
... I SRES=1!(DRES=1) S LOK=1,RES=1
Q
;
NCHK(NUMMEAS) ;
I NUMMEAS["~" S VCRIT1=$P(NUMMEAS,"~",1),VCRIT2=$P(NUMMEAS,"~",2)
E S VCRIT1=NUMMEAS,VCRIT2=""
F I=1:1:$L(VCRIT1) Q:$E(VCRIT1,I,I)'?.P
S OPER=$E(VCRIT1,1,I-1),RES1=$E(VCRIT1,I,$L(VCRIT1))
I $E(OPER,$L(OPER),$L(OPER))="." D
. S OPER=$E(OPER,1,$L(OPER)-1),RES1="."_RES1
I $G(VCRIT2)'="" D
. F I=1:1:$L(VCRIT2) Q:$E(VCRIT2,I,I)'?.P
. S OPER2=$E(VCRIT2,1,I-1),RES2=$E(VCRIT2,I,$L(VCRIT2))
. I $E(OPER2,$L(OPER2),$L(OPER2))="." D
.. S OPER2=$E(OPER2,1,$L(OPER2)-1),RES2="."_RES2
I VCRIT2="" D
. I $G(ROPER)="",@("MSRES"_OPER_"RES1") S LOK=1,RES=1 Q
. I $G(ROPER)'="",OPER=ROPER,@("MSRES"_OPER_"RES1") S LOK=1,RES=1 Q
. I $G(ROPER)'="",OPER'=ROPER Q
I VCRIT2'="" D
. I @("MSRES"_OPER_"RES1"),@("MSRES"_OPER2_"RES2") S LOK=1,RES=1
. I REX D
.. I @("MSRES"_OPER_"RES1") S LOK=1,RES=1
.. I @("MSRES"_OPER2_"RES2") S LOK=1,RES=1
Q
;
SCD ;EP
NEW LCOD,LCODU,LCODP,LVAL,LVALU,LVALP
F LI=1:1:$L(SCODE,";") S FQL=0 D Q:FQL
. S MSRS=$P(SCODE,";",LI),ROK=1,RES=0
. NEW LCOD,LCODU,LCODP
. ; Set code exactly, set code uppercase, set code no punctuation
. S LCOD=$P(MSRS,":",1),LCODU=$$UP^XLFSTR(LCOD),LCODP=$$PUNC^BQIUL3(LCOD)
. ; Set value exactly, set value uppercase, set value no punctuation
. S LVAL=$P(MSRS,":",2),LVALU=$$UP^XLFSTR(LVAL),LVALP=$$PUNC^BQIUL3(LVAL)
. ;
. ; If the set code matches the actual MEAS result
. I SETMEAS=LCOD D Q
.. I MSRES=LCOD S LOK=1,RES=1,FQL=1 Q
.. I MURES=LCODU S LOK=1,RES=1,FQL=1 Q
.. I MSURNP=LCODP S LOK=1,RES=1,FQL=1 Q
.. I MSRES=LVAL S LOK=1,RES=1,FQL=1 Q
.. I MURES=LVALU S LOK=1,RES=1,FQL=1 Q
.. I MSURNP=LVALP S LOK=1,RES=1,FQL=1 Q
Q
;
MSET(LN) ;EP - Set of codes
NEW COD,IEN,VALUE,TYPE
S VALUE=""
S COD=$P(^AUTTMSR(LN,0),U,1),IEN=$O(^BQI(90507.2,"C",COD,"")) I IEN="" Q VALUE
S TYPE=$$GET1^DIQ(90507.2,IEN_",",.04,"E")
I TYPE["SET" S VALUE=$G(^BQI(90507.2,IEN,2))
Q VALUE
BQIDCAH7 ;GDHD/HCD/ALA-Ad Hoc Logic ; 17 Jan 2017 3:44 PM
+1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
+2 ;
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
+2 NEW CMEAS,BBOTH,ABOTH,BMEAS,BPARMS,CPAR,BQMEAS,CPARMS,PPARMS,BNUMMEAS,FLG
+3 NEW BPRES,COD,NUMMEAS,SETMEAS,SRES,TCT
+4 SET NGLOB=$NAME(^TMP("BQIDCMEAS",$JOB))
KILL @NGLOB
+5 SET MSGLOB=$NAME(^TMP("BQIMSOP",$JOB))
KILL @MSGLOB
+6 IF $GET(TGLOB)=""
QUIT
+7 ;
+8 SET BBOTH=0
SET ABOTH=0
SET TCT=0
+9 ;
+10 IF $GET(MEAS)'=""
Begin DoDot:1
+11 NEW BMEAS
+12 SET COD=$PIECE(^BQI(90507.2,MEAS,0),"^",2)
SET CMEAS=$PIECE(^(0),"^",3)
SET BMEAS=MEAS
+13 IF $DATA(APARMS)
Begin DoDot:2
+14 IF COD="SYS"
SET BBOTH=BBOTH+1
DO VL
QUIT
+15 IF COD="DIA"
SET BBOTH=BBOTH+1
DO VL
QUIT
+16 IF COD="ASYS"
SET ABOTH=ABOTH+1
DO VL
QUIT
+17 IF COD="ADIA"
SET ABOTH=ABOTH+1
DO VL
QUIT
+18 SET RVAL=$ORDER(APARMS("MEAS",MEAS,""))
+19 IF RVAL="NUMMEAS"
SET NUMMEAS=APARMS("MEAS",MEAS,"NUMMEAS")
SET CPARMS("MEAS",CMEAS,"NUMMEAS")=NUMMEAS
+20 IF RVAL="SETMEAS"
SET SETMEAS=APARMS("MEAS",MEAS,"SETMEAS")
SET CPARMS("MEAS",CMEAS,"SETMEAS")=SETMEAS
End DoDot:2
+21 IF $DATA(MAPARMS)
Begin DoDot:2
+22 SET RVAL=$ORDER(MAPARMS("MEAS",MEAS,""))
+23 IF RVAL="SETMEAS"
SET PPARMS("MEAS",CMEAS)=RVAL
Begin DoDot:3
+24 SET RV=""
FOR
SET RV=$ORDER(MAPARMS("MEAS",MEAS,RVAL,RV))
IF RV=""
QUIT
SET CPARMS("MEAS",CMEAS,"SETMEAS",RV)=""
+25 KILL MAPARMS
+26 MERGE MAPARMS=CPARMS
+27 KILL CPARMS
End DoDot:3
End DoDot:2
+28 IF '$DATA(APARMS)
IF '$DATA(MAPARMS)
SET PPARMS("MEAS",CMEAS)=""
End DoDot:1
+29 ;
+30 Begin DoDot:1
+31 SET BMEAS=""
FOR
SET BMEAS=$ORDER(MPARMS("MEAS",BMEAS))
IF BMEAS=""
QUIT
Begin DoDot:2
+32 SET COD=$PIECE(^BQI(90507.2,BMEAS,0),"^",2)
SET CMEAS=$PIECE(^(0),"^",3)
+33 IF $DATA(APARMS("MEAS",BMEAS))
Begin DoDot:3
+34 IF COD="SYS"
SET BBOTH=BBOTH+1
DO VL
QUIT
+35 IF COD="DIA"
SET BBOTH=BBOTH+1
DO VL
QUIT
+36 IF COD="ASYS"
SET ABOTH=ABOTH+1
DO VL
QUIT
+37 IF COD="ADIA"
SET ABOTH=ABOTH+1
DO VL
QUIT
+38 SET RVAL=$ORDER(APARMS("MEAS",BMEAS,""))
+39 IF RVAL="NUMMEAS"
SET NUMMEAS=APARMS("MEAS",BMEAS,"NUMMEAS")
SET CPARMS("MEAS",CMEAS,"NUMMEAS")=NUMMEAS
+40 IF RVAL="SETMEAS"
SET SETMEAS=APARMS("MEAS",BMEAS,"SETMEAS")
SET CPARMS("MEAS",CMEAS,"SETMEAS")=SETMEAS
End DoDot:3
QUIT
+41 SET PPARMS("MEAS",CMEAS)=""
End DoDot:2
End DoDot:1
+42 ;
+43 SET BMEAS=""
FOR
SET BMEAS=$ORDER(CPARMS("MEAS",BMEAS))
IF BMEAS=""
QUIT
Begin DoDot:1
+44 KILL RVAL,NUMMEAS,SETMEAS
+45 SET RVAL=$ORDER(CPARMS("MEAS",BMEAS,""))
SET TCT=TCT+1
+46 IF RVAL="NUMMEAS"
SET NUMMEAS=CPARMS("MEAS",BMEAS,"NUMMEAS")
+47 IF RVAL="SETMEAS"
SET SETMEAS=CPARMS("MEAS",BMEAS,"SETMEAS")
+48 DO MS(BMEAS,1)
+49 KILL RVAL,NUMMEAS,SETMEAS
End DoDot:1
+50 ;
+51 SET BMEAS=""
FOR
SET BMEAS=$ORDER(PPARMS("MEAS",BMEAS))
IF BMEAS=""
QUIT
Begin DoDot:1
+52 SET RVAL=PPARMS("MEAS",BMEAS)
SET TCT=TCT+1
+53 IF RVAL="NUMMEAS"
SET NUMMEAS=1
+54 IF RVAL="SETMEAS"
SET SETMEAS=1
+55 DO MS(BMEAS,0)
End DoDot:1
+56 ;
+57 IF MSOP="!"
Begin DoDot:1
+58 SET IEN=""
+59 FOR
SET IEN=$ORDER(@MSGLOB@(IEN))
IF IEN=""
QUIT
SET @TGLOB@(IEN)=""
End DoDot:1
+60 IF MSOP="&"
Begin DoDot:1
+61 SET IEN=""
+62 FOR
SET IEN=$ORDER(@MSGLOB@(IEN))
IF IEN=""
QUIT
Begin DoDot:2
+63 SET LCT=0
SET LB=""
+64 FOR
SET LB=$ORDER(@MSGLOB@(IEN,LB))
IF LB=""
QUIT
SET LCT=LCT+1
+65 IF LCT'=TCT
KILL @CRIT@("MEAS",IEN)
QUIT
+66 IF LCT=TCT
IF 'MSNOT
Begin DoDot:3
+67 SET @TGLOB@(IEN)=""
SET LB=""
+68 FOR
SET LB=$ORDER(@MSGLOB@(IEN,LB))
IF LB=""
QUIT
Begin DoDot:4
+69 SET LIEN=""
+70 FOR
SET LIEN=$ORDER(@MSGLOB@(IEN,LB,LIEN))
IF LIEN=""
QUIT
SET @CRIT@("MEAS",IEN,LIEN)=""
End DoDot:4
End DoDot:3
+71 IF LCT=TCT
IF MSNOT
SET @NGLOB@(IEN)=""
KILL @CRIT@("MEAS",IEN)
End DoDot:2
End DoDot:1
+72 ;
+73 IF MSNOT
IF $GET(FGLOB)'=""
Begin DoDot:1
+74 SET IEN=""
FOR
SET IEN=$ORDER(@FGLOB@(IEN))
IF IEN=""
QUIT
Begin DoDot:2
+75 IF '$DATA(@NGLOB@(IEN))
SET @TGLOB@(IEN)=""
End DoDot:2
End DoDot:1
+76 IF MSNOT
IF $GET(FGLOB)=""
Begin DoDot:1
+77 SET IEN=0
FOR
SET IEN=$ORDER(^AUPNPAT(IEN))
IF 'IEN
QUIT
IF '$DATA(@NGLOB@(IEN))
SET @TGLOB@(IEN)=""
End DoDot:1
+78 KILL @NGLOB,@MSGLOB
+79 QUIT
+80 ;
VL ;EP
+1 SET RVAL=$ORDER(APARMS("MEAS",BMEAS,""))
SET BPARMS("MEAS",COD,RVAL)=APARMS("MEAS",BMEAS,RVAL)
SET CPAR(COD)=CMEAS
+2 SET PPARMS("MEAS",CMEAS)=RVAL
+3 QUIT
+4 ;
MS(MEAS,FLG) ;EP
+1 NEW DFN,IEN,BGT,BDT,ENT,VIS,VSDTM
+2 SET TDT=$SELECT(TDT'="":TDT,1:DT)
+3 IF $GET(FGLOB)'=""
Begin DoDot:1
+4 NEW IEN
+5 SET IEN=""
+6 FOR
SET IEN=$ORDER(@FGLOB@(IEN))
IF 'IEN
QUIT
Begin DoDot:2
+7 IF FDT=""
Begin DoDot:3
+8 SET BDT=""
+9 FOR
SET BDT=$ORDER(^AUPNVMSR("AA",IEN,MEAS,BDT))
IF BDT=""
QUIT
DO MSDT
End DoDot:3
+10 IF FDT'=""
Begin DoDot:3
+11 SET BGT=9999999-FDT
SET ENT=9999999-TDT
SET BDT=ENT-1
+12 FOR
SET BDT=$ORDER(^AUPNVMSR("AA",IEN,MEAS,BDT))
IF BDT=""!(BDT>BGT)
QUIT
DO MSDT
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+13 ;
+14 SET IEN=""
+15 FOR
SET IEN=$ORDER(^AUPNVMSR("B",MEAS,IEN),-1)
IF IEN=""
QUIT
Begin DoDot:1
+16 IF $GET(^AUPNVMSR(IEN,0))=""
QUIT
+17 ; if the new ENTERED IN ERROR field exists, exclude the record if it is marked as an error
+18 IF $$VFIELD^DILFD(9000010.01,2)
IF $$GET1^DIQ(9000010.01,IEN_",",2,"I")=1
QUIT
+19 SET DFN=$PIECE($GET(^AUPNVMSR(IEN,0)),U,2)
SET VIS=$PIECE(^AUPNVMSR(IEN,0),U,3)
IF VIS=""
QUIT
+20 IF $GET(^AUPNVSIT(VIS,0))=""
QUIT
+21 IF "DXCT"[$PIECE(^AUPNVSIT(VIS,0),U,7)
QUIT
+22 SET VSDTM=$PIECE(^AUPNVSIT(VIS,0),U,1)\1
+23 IF FDT'=""
IF VSDTM<FDT!(VSDTM>TDT)
QUIT
+24 ;B:MEAS=2
+25 SET MSRES=$PIECE($GET(^AUPNVMSR(IEN,0)),U,4)
SET MURES=$$UP^XLFSTR(MSRES)
+26 SET MSRSN=$$PUNC^BQIUL3(MSRES)
SET MSURNP=$$PUNC^BQIUL3(MURES)
+27 ;
+28 ; If looking for a MEAS result
+29 SET RES=0
+30 IF $GET(SETMEAS)=""
IF $GET(NUMMEAS)=""
SET ROK=1
SET RES=1
SET LOK=1
+31 IF $GET(SETMEAS)'=""!($GET(NUMMEAS)'="")
SET ROK=1
SET LOK=0
DO MSR
+32 ;I $G(SETMEAS)'=""!($G(NUMMEAS)'="")!($D(BPARMS("MEAS"))) S ROK=1,LOK=0 D MSR
+33 IF 'MSNOT
Begin DoDot:2
+34 IF ROK
IF 'RES
QUIT
+35 SET @MSGLOB@(DFN,MEAS,IEN)=MSRES
+36 IF LOK
SET @CRIT@("MEAS",DFN,IEN)=""
End DoDot:2
QUIT
+37 IF MSNOT
Begin DoDot:2
+38 IF ROK
IF 'RES
QUIT
+39 SET @NGLOB@(DFN)=""
+40 IF LOK
SET @CRIT@("MEAS",DFN,IEN)=""
End DoDot:2
QUIT
End DoDot:1
+41 QUIT
+42 ;
MSDT ;EP
+1 SET LIEN=""
+2 FOR
SET LIEN=$ORDER(^AUPNVMSR("AA",IEN,MEAS,BDT,LIEN))
IF LIEN=""
QUIT
Begin DoDot:1
+3 SET VIS=$PIECE($GET(^AUPNVMSR(LIEN,0)),U,3)
IF VIS=""
QUIT
+4 IF $GET(^AUPNVSIT(VIS,0))=""
QUIT
+5 ; if the new ENTERED IN ERROR field exists, exclude the record if it is marked as an error
+6 IF $$VFIELD^DILFD(9000010.01,2)
IF $$GET1^DIQ(9000010.01,LIEN_",",2,"I")=1
QUIT
+7 IF "DXCT"[$PIECE(^AUPNVSIT(VIS,0),U,7)
QUIT
+8 SET MSRES=$PIECE($GET(^AUPNVMSR(LIEN,0)),U,4)
SET MURES=$$UP^XLFSTR(MSRES)
+9 SET MSRSN=$$PUNC^BQIUL3(MSRES)
SET MSURNP=$$PUNC^BQIUL3(MURES)
+10 ; If looking for a MEAS result
+11 SET RES=0
+12 IF $GET(SETMEAS)=""
IF $GET(NUMMEAS)=""
SET ROK=1
SET RES=1
SET LOK=1
+13 IF $GET(SETMEAS)'=""!($GET(NUMMEAS)'="")
SET ROK=1
SET LOK=0
DO MSR
+14 ;I $G(SETMEAS)'=""!($G(NUMMEAS)'="")!($D(BPARMS("MEAS"))) S ROK=1,LOK=0 D MSR
+15 IF 'MSNOT
Begin DoDot:2
+16 IF ROK
IF 'RES
QUIT
+17 SET @MSGLOB@(IEN,MEAS,LIEN)=MSRES
+18 IF LOK
SET @CRIT@("MEAS",IEN,LIEN)=""
End DoDot:2
QUIT
+19 IF MSNOT
Begin DoDot:2
+20 IF ROK
IF 'RES
QUIT
+21 SET @NGLOB@(IEN)=""
+22 IF LOK
SET @CRIT@("MEAS",IEN,LIEN)=""
End DoDot:2
QUIT
End DoDot:1
+23 QUIT
+24 ;
MSR ;EP - Measurement results
+1 IF MSRES=""
QUIT
+2 NEW MSR,VCRIT1,VCRIT2,ROPER,OPER,OPER2,RES1,RES2,SCODE,LI,MSRS,FQL,I
+3 IF $DATA(MAPARMS("MEAS",MEAS,"SETMEAS"))
Begin DoDot:1
+4 SET MSR=""
FOR
SET MSR=$ORDER(MAPARMS("MEAS",MEAS,"SETMEAS",MSR))
IF MSR=""
QUIT
Begin DoDot:2
+5 IF MSRES=MSR
SET LOK=1
SET RES=1
QUIT
+6 SET SCODE=$$MSET(MEAS)
+7 NEW SETMEAS
+8 SET SETMEAS=MSR
DO SCD
End DoDot:2
IF LOK
QUIT
+9 ;
End DoDot:1
QUIT
+10 IF $GET(SETMEAS)'=""
IF MSRES=SETMEAS
SET LOK=1
SET RES=1
QUIT
+11 IF $GET(SETMEAS)'=""
IF MSRES'=SETMEAS
Begin DoDot:1
+12 IF SETMEAS=MURES
SET LOK=1
SET RES=1
QUIT
+13 SET SCODE=$$MSET(MEAS)
+14 DO SCD
End DoDot:1
QUIT
+15 ;
+16 ;I $G(SETMEAS)'="",'$D(MAPARMS("MEAS",MEAS,"SETMEAS")),MSRES=$P(SCODE,":",1)!(MSRES=$P(SCODE,":",2)) S LOK=1,RES=1 Q
+17 ;
+18 IF $GET(NUMMEAS)'=""
IF $GET(FLG)=1
Begin DoDot:1
+19 NEW REX,SRES,DRES,BPRES,BQMEAS,BNUMMEAS
+20 IF $GET(NUMMEAS)["~"
SET REX=1
+21 IF $GET(NUMMEAS)["~"
IF $GET(NUMMEAS)["'"
SET REX=0
+22 IF MSRES?.ULP
QUIT
+23 IF MSRES'?.PN
IF MSRES'?.N
QUIT
+24 IF $EXTRACT(MSRES,$LENGTH(MSRES),$LENGTH(MSRES))?.P
SET MSRES=$EXTRACT(MSRES,1,$LENGTH(MSRES)-1)
+25 ; if value starts with a punctuation e.g. < or >
+26 IF $EXTRACT(MSRES,1,1)?.P
SET ROPER=$EXTRACT(MSRES,1,1)
SET MSRES=$EXTRACT(MSRES,2,$LENGTH(MSRES))
+27 IF $PIECE(^AUTTMSR(MEAS,0),"^",1)="EGA"
Begin DoDot:2
+28 IF MSRES["/"
SET MSRES=$PIECE(MSRES," ",1)
End DoDot:2
+29 DO NCHK(NUMMEAS)
End DoDot:1
QUIT
+30 ;
+31 IF $GET(NUMMEAS)'=""
IF $GET(FLG)=0
Begin DoDot:1
+32 IF $GET(BBOTH)!($GET(ABOTH))
Begin DoDot:2
+33 SET BPRES=MSRES
SET SRES=0
SET DRES=0
+34 IF $GET(BBOTH)'=0
FOR BQMEAS="DIA","SYS"
SET LOK=0
SET RES=0
Begin DoDot:3
+35 IF $GET(CPAR(BQMEAS))'=MEAS
QUIT
+36 SET BNUMMEAS=$GET(BPARMS("MEAS",BQMEAS,"NUMMEAS"))
+37 IF BNUMMEAS=""
QUIT
+38 IF BNUMMEAS["~"
SET REX=1
+39 IF BNUMMEAS["~"
IF BNUMMEAS["'"
SET REX=0
+40 IF $GET(BQMEAS)["SYS"
SET MSRES=$PIECE(MSRES,"/",1)
DO NCHK(BNUMMEAS)
SET SRES=RES
SET MSRES=BPRES
+41 IF $GET(BQMEAS)["DIA"
SET MSRES=$PIECE(MSRES,"/",2)
DO NCHK(BNUMMEAS)
SET DRES=RES
SET MSRES=BPRES
End DoDot:3
+42 IF $GET(ABOTH)'=0
FOR BQMEAS="ADIA","ASYS"
SET LOK=0
SET RES=0
Begin DoDot:3
+43 IF $GET(CPAR(BQMEAS))'=MEAS
QUIT
+44 SET BNUMMEAS=$GET(BPARMS("MEAS",BQMEAS,"NUMMEAS"))
+45 IF BNUMMEAS=""
QUIT
+46 IF BNUMMEAS["~"
SET REX=1
+47 IF BNUMMEAS["~"
IF BNUMMEAS["'"
SET REX=0
+48 IF $GET(BQMEAS)["SYS"
SET MSRES=$PIECE(MSRES,"/",1)
DO NCHK(BNUMMEAS)
SET SRES=RES
SET MSRES=BPRES
+49 IF $GET(BQMEAS)["DIA"
SET MSRES=$PIECE(MSRES,"/",2)
DO NCHK(BNUMMEAS)
SET DRES=RES
SET MSRES=BPRES
End DoDot:3
+50 SET LOK=0
SET RES=0
+51 IF $GET(BBOTH)'=0
IF BPOP="&"
Begin DoDot:3
+52 IF SRES=1
IF DRES=1
SET LOK=1
SET RES=1
End DoDot:3
QUIT
+53 IF $GET(ABOTH)'=0
IF ABPOP="&"
Begin DoDot:3
+54 IF SRES=1
IF DRES=1
SET LOK=1
SET RES=1
End DoDot:3
QUIT
+55 IF BPOP="!"!(ABPOP="!")
Begin DoDot:3
+56 IF SRES=1!(DRES=1)
SET LOK=1
SET RES=1
End DoDot:3
End DoDot:2
QUIT
End DoDot:1
QUIT
+57 QUIT
+58 ;
NCHK(NUMMEAS) ;
+1 IF NUMMEAS["~"
SET VCRIT1=$PIECE(NUMMEAS,"~",1)
SET VCRIT2=$PIECE(NUMMEAS,"~",2)
+2 IF '$TEST
SET VCRIT1=NUMMEAS
SET VCRIT2=""
+3 FOR I=1:1:$LENGTH(VCRIT1)
IF $EXTRACT(VCRIT1,I,I)'?.P
QUIT
+4 SET OPER=$EXTRACT(VCRIT1,1,I-1)
SET RES1=$EXTRACT(VCRIT1,I,$LENGTH(VCRIT1))
+5 IF $EXTRACT(OPER,$LENGTH(OPER),$LENGTH(OPER))="."
Begin DoDot:1
+6 SET OPER=$EXTRACT(OPER,1,$LENGTH(OPER)-1)
SET RES1="."_RES1
End DoDot:1
+7 IF $GET(VCRIT2)'=""
Begin DoDot:1
+8 FOR I=1:1:$LENGTH(VCRIT2)
IF $EXTRACT(VCRIT2,I,I)'?.P
QUIT
+9 SET OPER2=$EXTRACT(VCRIT2,1,I-1)
SET RES2=$EXTRACT(VCRIT2,I,$LENGTH(VCRIT2))
+10 IF $EXTRACT(OPER2,$LENGTH(OPER2),$LENGTH(OPER2))="."
Begin DoDot:2
+11 SET OPER2=$EXTRACT(OPER2,1,$LENGTH(OPER2)-1)
SET RES2="."_RES2
End DoDot:2
End DoDot:1
+12 IF VCRIT2=""
Begin DoDot:1
+13 IF $GET(ROPER)=""
IF @("MSRES"_OPER_"RES1")
SET LOK=1
SET RES=1
QUIT
+14 IF $GET(ROPER)'=""
IF OPER=ROPER
IF @("MSRES"_OPER_"RES1")
SET LOK=1
SET RES=1
QUIT
+15 IF $GET(ROPER)'=""
IF OPER'=ROPER
QUIT
End DoDot:1
+16 IF VCRIT2'=""
Begin DoDot:1
+17 IF @("MSRES"_OPER_"RES1")
IF @("MSRES"_OPER2_"RES2")
SET LOK=1
SET RES=1
+18 IF REX
Begin DoDot:2
+19 IF @("MSRES"_OPER_"RES1")
SET LOK=1
SET RES=1
+20 IF @("MSRES"_OPER2_"RES2")
SET LOK=1
SET RES=1
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
SCD ;EP
+1 NEW LCOD,LCODU,LCODP,LVAL,LVALU,LVALP
+2 FOR LI=1:1:$LENGTH(SCODE,";")
SET FQL=0
Begin DoDot:1
+3 SET MSRS=$PIECE(SCODE,";",LI)
SET ROK=1
SET RES=0
+4 NEW LCOD,LCODU,LCODP
+5 ; Set code exactly, set code uppercase, set code no punctuation
+6 SET LCOD=$PIECE(MSRS,":",1)
SET LCODU=$$UP^XLFSTR(LCOD)
SET LCODP=$$PUNC^BQIUL3(LCOD)
+7 ; Set value exactly, set value uppercase, set value no punctuation
+8 SET LVAL=$PIECE(MSRS,":",2)
SET LVALU=$$UP^XLFSTR(LVAL)
SET LVALP=$$PUNC^BQIUL3(LVAL)
+9 ;
+10 ; If the set code matches the actual MEAS result
+11 IF SETMEAS=LCOD
Begin DoDot:2
+12 IF MSRES=LCOD
SET LOK=1
SET RES=1
SET FQL=1
QUIT
+13 IF MURES=LCODU
SET LOK=1
SET RES=1
SET FQL=1
QUIT
+14 IF MSURNP=LCODP
SET LOK=1
SET RES=1
SET FQL=1
QUIT
+15 IF MSRES=LVAL
SET LOK=1
SET RES=1
SET FQL=1
QUIT
+16 IF MURES=LVALU
SET LOK=1
SET RES=1
SET FQL=1
QUIT
+17 IF MSURNP=LVALP
SET LOK=1
SET RES=1
SET FQL=1
QUIT
End DoDot:2
QUIT
End DoDot:1
IF FQL
QUIT
+18 QUIT
+19 ;
MSET(LN) ;EP - Set of codes
+1 NEW COD,IEN,VALUE,TYPE
+2 SET VALUE=""
+3 SET COD=$PIECE(^AUTTMSR(LN,0),U,1)
SET IEN=$ORDER(^BQI(90507.2,"C",COD,""))
IF IEN=""
QUIT VALUE
+4 SET TYPE=$$GET1^DIQ(90507.2,IEN_",",.04,"E")
+5 IF TYPE["SET"
SET VALUE=$GET(^BQI(90507.2,IEN,2))
+6 QUIT VALUE
