- 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