LRPXAPI4 ;SLC/STAFF Lab Extract API code - Exact Match ;9/29/03 21:17
;;5.2;LAB SERVICE;**295**;Sep 27, 1994
;
EXACT(DFN,DATE,CONDS) ; from LRPXAPI5
; check if conditions are met for date/time
N FETCH,ITEM,NODE,OK,RESULTS,SEPARATE,XDATE K FETCH,RESULTS,SEPARATE
S OK=1
I '$L($O(CONDS(""))) Q 1
M FETCH=^PXRMINDX(63,"PDI",DFN,DATE)
S ITEM=""
F S ITEM=$O(FETCH(ITEM)) Q:ITEM="" D
. S NODE=""
. F S NODE=$O(FETCH(ITEM,NODE)) Q:NODE="" D
.. S SEPARATE($P(NODE,";",1,3),ITEM,NODE)=""
S XDATE=""
F S XDATE=$O(SEPARATE(XDATE)) Q:XDATE="" D Q:OK
. K RESULTS
. M RESULTS=SEPARATE(XDATE)
. I '$L($O(RESULTS(""))) S OK=0 Q
. I $D(CONDS("MIR")) D MIR(.CONDS,.RESULTS,.OK) I 'OK Q
. I $D(CONDS("AS")) D AS(.CONDS,.RESULTS,.OK) I 'OK Q
. I $D(CONDS("MC")) D MC(.CONDS,.RESULTS,.OK) I 'OK Q
. I $D(CONDS("AC")) D AC(.CONDS,.RESULTS,.OK) I 'OK Q
. I $D(CONDS(1)) D EQUAL(.CONDS,.RESULTS,.OK) I 'OK Q
. I $D(CONDS(0)) D NOTEQUAL(.CONDS,.RESULTS,.OK) I 'OK Q
. I '$L($O(RESULTS(""))) S OK=0 Q 0
. D SCRAPS(.CONDS,.RESULTS,.OK) I 'OK Q
. D THREAD(.CONDS,.RESULTS,.OK) I 'OK Q
Q OK
;
THREAD(CONDS,RESULTS,OK) ;
; uses TCHK within this scope
N CHK,FILE,IEN,ITEM,ITEMC,NEXT,NODE,NODEC,NUM,PAR,PARSTOP,START,STOP
S OK=1
; check Micro - only O <-> A match
I $D(CONDS("X","M;O")),($D(CONDS("X","M;A"))!$D(CONDS("X","M;M"))) D Q:'OK
. I '($D(CONDS("X","M;A"))!$D(CONDS("X","M;M"))!$D(CONDS("X","M;MIR"))) Q
. S ITEM="M;O;"
. F S ITEM=$O(RESULTS(ITEM)) Q:ITEM="" Q:ITEM]"M;O;Z" D Q:'OK
.. S NODE=""
.. F S NODE=$O(RESULTS(ITEM,NODE)) Q:NODE="" D Q:'OK
... S IEN=$P(NODE,";",5)
... S OK=0
... S ITEMC="M;A;"
... F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]"M;A;Z" D Q:OK
.... S NODEC=""
.... F S NODEC=$O(RESULTS(ITEMC,NODEC)) Q:NODEC="" D Q:OK
..... I IEN=$P(NODEC,";",5) S OK=1 Q
... S ITEMC="M;M;"
... F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]"M;M;Z" D Q:OK
.... S NODEC=""
.... F S NODEC=$O(RESULTS(ITEMC,NODEC)) Q:NODEC="" D Q:OK
..... I IEN=$P(NODEC,";",5) S OK=1 Q
I $D(CONDS("X","M")) Q
; check AP - M <-> E , S <-> T and O <-> [D M F P] match
S PAR="A;M",START="A;E"
I $D(CONDS("X",PAR)),$D(CONDS("X",START)) D TCHK(PAR,7,START) Q:'OK
S PAR="A;S",START="A;T"
I $D(CONDS("X",PAR)),$D(CONDS("X",START)) D TCHK(PAR,5,START) Q:'OK
S PAR="A;O"
I $D(CONDS("X",PAR)) D Q:'OK
. F FILE="D","M","F","P" D Q:'OK
.. S START="A;"_FILE
.. I $D(CONDS("X",START)) D TCHK(PAR,5,START)
Q
TCHK(PAR,NUM,START) ; within scope of THREAD
S ITEM=PAR,PARSTOP=PAR_";Z",STOP=START_";Z"
F S ITEM=$O(RESULTS(ITEM)) Q:ITEM="" Q:ITEM]PARSTOP D Q:'OK
. S NODE=""
. F S NODE=$O(RESULTS(ITEM,NODE)) Q:NODE="" D Q:'OK
.. S IEN=$P(NODE,";",1,NUM)
.. S CHK=0
.. S ITEMC=START
.. F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]STOP D Q:CHK
... S NODEC=""
... F S NODEC=$O(RESULTS(ITEMC,NODEC)) Q:NODEC="" D Q:CHK
.... I IEN=$P(NODEC,";",1,NUM) S CHK=1 Q
.... I $L(NODEC,";")=4 S CHK=1 Q ; at collection date
.. I 'CHK K RESULTS(ITEM)
S NEXT=$O(RESULTS(PAR))
I NEXT="" S OK=0 Q
I NEXT]PARSTOP S OK=0 Q
Q
;
SCRAPS(CONDS,RESULTS,OK) ;
N ITEM,ITEMC
S OK=1
S ITEM=""
F S ITEM=$O(RESULTS(ITEM)) Q:ITEM="" D
. S ITEMC=$P(ITEM,";",1,2)
. I ITEMC="M;A",$D(CONDS("MIR")) Q
. I ITEMC="M;M",$D(CONDS("MIR")) Q
. I '$D(CONDS("X",ITEMC)) K RESULTS(ITEM)
I '$L($O(RESULTS(""))) S OK=0 Q
Q
;
NOTEQUAL(CONDS,RESULTS,OK) ;
; check not equal condition for pointer values
N FILE,ITEM,START,STOP,TYPE
S OK=1
S ITEM=""
F S ITEM=$O(CONDS(0,ITEM)) Q:ITEM="" D Q:'OK
. S TYPE=$E(ITEM),FILE=$E(ITEM,3),START=TYPE_";"_FILE,STOP=TYPE_";"_FILE_";Z"
. K RESULTS(ITEM)
. S NEXT=$O(RESULTS(START))
. I NEXT="" S OK=0 Q
. I NEXT]STOP S OK=0 Q
Q
;
EQUAL(CONDS,RESULTS,OK) ;
; check equal condition for pointer values
N FILE,ITEM,ITEMC,NEXT,START,STOP,TYPE
S OK=1
S ITEM=""
F S ITEM=$O(CONDS(1,ITEM)) Q:ITEM="" D
. S TYPE=$E(ITEM),FILE=$E(ITEM,3),START=TYPE_";"_FILE,STOP=TYPE_";"_FILE_";Z"
. S ITEMC=START
. F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]STOP D
.. I ITEMC=ITEM Q
.. K RESULTS(ITEMC)
S NEXT=$O(RESULTS(START))
I NEXT="" S OK=0 Q
I NEXT]STOP S OK=0 Q
Q
;
AC(CONDS,RESULTS,OK) ;
; check conditions for AP categories
N CAT,CATEGORY,ITEM,ITEMC,NODE,NOTEQUAL,SUB
S OK=1
S ITEM=""
F S ITEM=$O(CONDS("AC",ITEM)) Q:ITEM="" D
. S CATEGORY=$P(ITEM,"=",2)
. I '$L(CATEGORY) Q
. S CATEGORY=$E(CATEGORY,2)
. S NOTEQUAL=0
. I $L($P(ITEM,"'=",2)) S NOTEQUAL=1
. S ITEMC="A"
. F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]"A;Z" D
.. I ITEMC["A;T;" Q
.. S NODE=""
.. F S NODE=$O(RESULTS(ITEMC,NODE)) Q:NODE="" D
... S SUB=$P(NODE,";",2)
... I SUB=33!(SUB=80) S CAT="A"
... E S CAT=$E(SUB)
... I NOTEQUAL,CAT=CATEGORY K RESULTS(ITEMC,NODE) Q
... I 'NOTEQUAL,CAT'=CATEGORY K RESULTS(ITEMC,NODE) Q
I '$L($O(RESULTS(""))) S OK=0 Q
Q
;
MC(CONDS,RESULTS,OK) ;
; check conditions for Micro categories
N CATEGORY,CATSUB,ITEM,ITEMC,NEXT,NODE,NOTEQUAL,SUB
S OK=1
S ITEM=""
F S ITEM=$O(CONDS("MC",ITEM)) Q:ITEM="" D
. S CATEGORY=$P(ITEM,"=",2)
. I '$L(CATEGORY) Q
. S CATEGORY=$E(CATEGORY,2)
. S CATSUB=$$CATSUB^LRPXAPIU(CATEGORY,"M")
. S NOTEQUAL=0
. I $L($P(ITEM,"'=",2)) S NOTEQUAL=1
. S ITEMC="M"
. F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]"M;Z" D
.. I ITEMC["M;T;" Q
.. I ITEMC["M;S;" Q
.. S NODE=""
.. F S NODE=$O(RESULTS(ITEMC,NODE)) Q:NODE="" D
... S SUB=$P(NODE,";",4)
... I NOTEQUAL,SUB=CATSUB K RESULTS(ITEMC,NODE) Q
... I 'NOTEQUAL,SUB'=CATSUB K RESULTS(ITEMC,NODE) Q
S NEXT=$O(RESULTS("M"))
I NEXT="" S OK=0 Q
I NEXT]"M;S" S OK=0 Q
Q
;
AS(CONDS,RESULTS,OK) ;
; check conditions for AP specimen
N CHECK,ITEM,ITEMC,NEXT,S
S OK=1
S ITEM=""
F S ITEM=$O(CONDS("AS",ITEM)) Q:ITEM="" D
. I $E(ITEM,2)="'" D Q
.. ; good if the specimen text is not present for this collection
.. S ITEMC="A;S;1"
.. F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]"A;S;Z" D
... S S=$P(ITEMC,"1.",2)
... S CHECK="I "_ITEM
... X CHECK I '$T K RESULTS(ITEMC)
. ; good if any of the specimen text for this collection have a matching text
. I $O(RESULTS("A;S;1"))="" Q
. I $O(RESULTS("A;S;1"))]"A;S;Z" Q
. S OK=0
. S ITEMC="A;S;1"
. F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]"A;S;Z" D
.. S S=$P(ITEMC,"1.",2)
.. S CHECK="I "_ITEM
.. X CHECK I '$T K RESULTS(ITEMC)
S NEXT=$O(RESULTS("A;S;"))
I NEXT="" S OK=0 Q
I NEXT]"A;S;Z" S OK=0 Q
S OK=1
Q
;
MIR(CONDS,RESULTS,OK) ;
; check conditions for antimicrobial results and interpretations
; uses MCHK within this scope
N ABNODE,ABTYPE,CHECK,I,ITEM,ITEMC,NEXTA,NEXTM,NODE,R,START,STOP
S OK=0
F ABTYPE="A","M" D MCHK(ABTYPE)
S NEXTA=$O(RESULTS("M;A"))
S NEXTM=$O(RESULTS("M;M"))
I NEXTA="",NEXTM="" Q
I NEXTA="",NEXTM]"M;M;Z" Q
I NEXTA]"M;A;Z",NEXTM="" Q
I NEXTA]"M;A;Z",NEXTM]"M;M;Z" Q
S OK=1
Q
MCHK(ABTYPE) ; within scope of MIR
S START="M;"_ABTYPE
S STOP=START_";Z"
S ITEM=""
F S ITEM=$O(CONDS("MIR",ITEM)) Q:ITEM="" D
. I $E(ITEM,2)="'" D Q
.. ; good if the interpretation/result is not present for this collection
.. S ITEMC=START
.. F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]STOP D
... S NODE=""
... F S NODE=$O(RESULTS(ITEMC,NODE)) Q:NODE="" D
.... S ABNODE=$$REFVAL^LRPXAPI(NODE)
.... I ABTYPE="A" D
..... S I=$P(ABNODE,U,2)
..... S R=$P(ABNODE,U)
.... E D
..... S R=$P(ABNODE,U)
..... S I=R
.... S CHECK="I "_ITEM
.... X CHECK I $T Q
.... K RESULTS(ITEMC,NODE)
. ; good if any of the interpretations/results have matching conditions
. I $O(RESULTS(START))="" Q
. I $O(RESULTS(START))]STOP Q
. S ITEMC=START
. F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]STOP D
.. S NODE=""
.. F S NODE=$O(RESULTS(ITEMC,NODE)) Q:NODE="" D
... S ABNODE=$$REFVAL^LRPXAPI(NODE)
... S I=$P(ABNODE,U,2)
... S R=$P(ABNODE,U)
... S CHECK="I "_ITEM
... X CHECK I '$T K RESULTS(ITEMC,NODE)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRPXAPI4 8124 printed Apr 09, 2024@21:19:59 Page 2
LRPXAPI4 ;SLC/STAFF Lab Extract API code - Exact Match ;9/29/03 21:17
+1 ;;5.2;LAB SERVICE;**295**;Sep 27, 1994
+2 ;
EXACT(DFN,DATE,CONDS) ; from LRPXAPI5
+1 ; check if conditions are met for date/time
+2 NEW FETCH,ITEM,NODE,OK,RESULTS,SEPARATE,XDATE
KILL FETCH,RESULTS,SEPARATE
+3 SET OK=1
+4 IF '$LENGTH($ORDER(CONDS("")))
QUIT 1
+5 MERGE FETCH=^PXRMINDX(63,"PDI",DFN,DATE)
+6 SET ITEM=""
+7 FOR
SET ITEM=$ORDER(FETCH(ITEM))
if ITEM=""
QUIT
Begin DoDot:1
+8 SET NODE=""
+9 FOR
SET NODE=$ORDER(FETCH(ITEM,NODE))
if NODE=""
QUIT
Begin DoDot:2
+10 SET SEPARATE($PIECE(NODE,";",1,3),ITEM,NODE)=""
End DoDot:2
End DoDot:1
+11 SET XDATE=""
+12 FOR
SET XDATE=$ORDER(SEPARATE(XDATE))
if XDATE=""
QUIT
Begin DoDot:1
+13 KILL RESULTS
+14 MERGE RESULTS=SEPARATE(XDATE)
+15 IF '$LENGTH($ORDER(RESULTS("")))
SET OK=0
QUIT
+16 IF $DATA(CONDS("MIR"))
DO MIR(.CONDS,.RESULTS,.OK)
IF 'OK
QUIT
+17 IF $DATA(CONDS("AS"))
DO AS(.CONDS,.RESULTS,.OK)
IF 'OK
QUIT
+18 IF $DATA(CONDS("MC"))
DO MC(.CONDS,.RESULTS,.OK)
IF 'OK
QUIT
+19 IF $DATA(CONDS("AC"))
DO AC(.CONDS,.RESULTS,.OK)
IF 'OK
QUIT
+20 IF $DATA(CONDS(1))
DO EQUAL(.CONDS,.RESULTS,.OK)
IF 'OK
QUIT
+21 IF $DATA(CONDS(0))
DO NOTEQUAL(.CONDS,.RESULTS,.OK)
IF 'OK
QUIT
+22 IF '$LENGTH($ORDER(RESULTS("")))
SET OK=0
QUIT 0
+23 DO SCRAPS(.CONDS,.RESULTS,.OK)
IF 'OK
QUIT
+24 DO THREAD(.CONDS,.RESULTS,.OK)
IF 'OK
QUIT
End DoDot:1
if OK
QUIT
+25 QUIT OK
+26 ;
THREAD(CONDS,RESULTS,OK) ;
+1 ; uses TCHK within this scope
+2 NEW CHK,FILE,IEN,ITEM,ITEMC,NEXT,NODE,NODEC,NUM,PAR,PARSTOP,START,STOP
+3 SET OK=1
+4 ; check Micro - only O <-> A match
+5 IF $DATA(CONDS("X","M;O"))
IF ($DATA(CONDS("X","M;A"))!$DATA(CONDS("X","M;M")))
Begin DoDot:1
+6 IF '($DATA(CONDS("X","M;A"))!$DATA(CONDS("X","M;M"))!$DATA(CONDS("X","M;MIR")))
QUIT
+7 SET ITEM="M;O;"
+8 FOR
SET ITEM=$ORDER(RESULTS(ITEM))
if ITEM=""
QUIT
if ITEM]"M;O;Z"
QUIT
Begin DoDot:2
+9 SET NODE=""
+10 FOR
SET NODE=$ORDER(RESULTS(ITEM,NODE))
if NODE=""
QUIT
Begin DoDot:3
+11 SET IEN=$PIECE(NODE,";",5)
+12 SET OK=0
+13 SET ITEMC="M;A;"
+14 FOR
SET ITEMC=$ORDER(RESULTS(ITEMC))
if ITEMC=""
QUIT
if ITEMC]"M;A;Z"
QUIT
Begin DoDot:4
+15 SET NODEC=""
+16 FOR
SET NODEC=$ORDER(RESULTS(ITEMC,NODEC))
if NODEC=""
QUIT
Begin DoDot:5
+17 IF IEN=$PIECE(NODEC,";",5)
SET OK=1
QUIT
End DoDot:5
if OK
QUIT
End DoDot:4
if OK
QUIT
+18 SET ITEMC="M;M;"
+19 FOR
SET ITEMC=$ORDER(RESULTS(ITEMC))
if ITEMC=""
QUIT
if ITEMC]"M;M;Z"
QUIT
Begin DoDot:4
+20 SET NODEC=""
+21 FOR
SET NODEC=$ORDER(RESULTS(ITEMC,NODEC))
if NODEC=""
QUIT
Begin DoDot:5
+22 IF IEN=$PIECE(NODEC,";",5)
SET OK=1
QUIT
End DoDot:5
if OK
QUIT
End DoDot:4
if OK
QUIT
End DoDot:3
if 'OK
QUIT
End DoDot:2
if 'OK
QUIT
End DoDot:1
if 'OK
QUIT
+23 IF $DATA(CONDS("X","M"))
QUIT
+24 ; check AP - M <-> E , S <-> T and O <-> [D M F P] match
+25 SET PAR="A;M"
SET START="A;E"
+26 IF $DATA(CONDS("X",PAR))
IF $DATA(CONDS("X",START))
DO TCHK(PAR,7,START)
if 'OK
QUIT
+27 SET PAR="A;S"
SET START="A;T"
+28 IF $DATA(CONDS("X",PAR))
IF $DATA(CONDS("X",START))
DO TCHK(PAR,5,START)
if 'OK
QUIT
+29 SET PAR="A;O"
+30 IF $DATA(CONDS("X",PAR))
Begin DoDot:1
+31 FOR FILE="D","M","F","P"
Begin DoDot:2
+32 SET START="A;"_FILE
+33 IF $DATA(CONDS("X",START))
DO TCHK(PAR,5,START)
End DoDot:2
if 'OK
QUIT
End DoDot:1
if 'OK
QUIT
+34 QUIT
TCHK(PAR,NUM,START) ; within scope of THREAD
+1 SET ITEM=PAR
SET PARSTOP=PAR_";Z"
SET STOP=START_";Z"
+2 FOR
SET ITEM=$ORDER(RESULTS(ITEM))
if ITEM=""
QUIT
if ITEM]PARSTOP
QUIT
Begin DoDot:1
+3 SET NODE=""
+4 FOR
SET NODE=$ORDER(RESULTS(ITEM,NODE))
if NODE=""
QUIT
Begin DoDot:2
+5 SET IEN=$PIECE(NODE,";",1,NUM)
+6 SET CHK=0
+7 SET ITEMC=START
+8 FOR
SET ITEMC=$ORDER(RESULTS(ITEMC))
if ITEMC=""
QUIT
if ITEMC]STOP
QUIT
Begin DoDot:3
+9 SET NODEC=""
+10 FOR
SET NODEC=$ORDER(RESULTS(ITEMC,NODEC))
if NODEC=""
QUIT
Begin DoDot:4
+11 IF IEN=$PIECE(NODEC,";",1,NUM)
SET CHK=1
QUIT
+12 ; at collection date
IF $LENGTH(NODEC,";")=4
SET CHK=1
QUIT
End DoDot:4
if CHK
QUIT
End DoDot:3
if CHK
QUIT
+13 IF 'CHK
KILL RESULTS(ITEM)
End DoDot:2
if 'OK
QUIT
End DoDot:1
if 'OK
QUIT
+14 SET NEXT=$ORDER(RESULTS(PAR))
+15 IF NEXT=""
SET OK=0
QUIT
+16 IF NEXT]PARSTOP
SET OK=0
QUIT
+17 QUIT
+18 ;
SCRAPS(CONDS,RESULTS,OK) ;
+1 NEW ITEM,ITEMC
+2 SET OK=1
+3 SET ITEM=""
+4 FOR
SET ITEM=$ORDER(RESULTS(ITEM))
if ITEM=""
QUIT
Begin DoDot:1
+5 SET ITEMC=$PIECE(ITEM,";",1,2)
+6 IF ITEMC="M;A"
IF $DATA(CONDS("MIR"))
QUIT
+7 IF ITEMC="M;M"
IF $DATA(CONDS("MIR"))
QUIT
+8 IF '$DATA(CONDS("X",ITEMC))
KILL RESULTS(ITEM)
End DoDot:1
+9 IF '$LENGTH($ORDER(RESULTS("")))
SET OK=0
QUIT
+10 QUIT
+11 ;
NOTEQUAL(CONDS,RESULTS,OK) ;
+1 ; check not equal condition for pointer values
+2 NEW FILE,ITEM,START,STOP,TYPE
+3 SET OK=1
+4 SET ITEM=""
+5 FOR
SET ITEM=$ORDER(CONDS(0,ITEM))
if ITEM=""
QUIT
Begin DoDot:1
+6 SET TYPE=$EXTRACT(ITEM)
SET FILE=$EXTRACT(ITEM,3)
SET START=TYPE_";"_FILE
SET STOP=TYPE_";"_FILE_";Z"
+7 KILL RESULTS(ITEM)
+8 SET NEXT=$ORDER(RESULTS(START))
+9 IF NEXT=""
SET OK=0
QUIT
+10 IF NEXT]STOP
SET OK=0
QUIT
End DoDot:1
if 'OK
QUIT
+11 QUIT
+12 ;
EQUAL(CONDS,RESULTS,OK) ;
+1 ; check equal condition for pointer values
+2 NEW FILE,ITEM,ITEMC,NEXT,START,STOP,TYPE
+3 SET OK=1
+4 SET ITEM=""
+5 FOR
SET ITEM=$ORDER(CONDS(1,ITEM))
if ITEM=""
QUIT
Begin DoDot:1
+6 SET TYPE=$EXTRACT(ITEM)
SET FILE=$EXTRACT(ITEM,3)
SET START=TYPE_";"_FILE
SET STOP=TYPE_";"_FILE_";Z"
+7 SET ITEMC=START
+8 FOR
SET ITEMC=$ORDER(RESULTS(ITEMC))
if ITEMC=""
QUIT
if ITEMC]STOP
QUIT
Begin DoDot:2
+9 IF ITEMC=ITEM
QUIT
+10 KILL RESULTS(ITEMC)
End DoDot:2
End DoDot:1
+11 SET NEXT=$ORDER(RESULTS(START))
+12 IF NEXT=""
SET OK=0
QUIT
+13 IF NEXT]STOP
SET OK=0
QUIT
+14 QUIT
+15 ;
AC(CONDS,RESULTS,OK) ;
+1 ; check conditions for AP categories
+2 NEW CAT,CATEGORY,ITEM,ITEMC,NODE,NOTEQUAL,SUB
+3 SET OK=1
+4 SET ITEM=""
+5 FOR
SET ITEM=$ORDER(CONDS("AC",ITEM))
if ITEM=""
QUIT
Begin DoDot:1
+6 SET CATEGORY=$PIECE(ITEM,"=",2)
+7 IF '$LENGTH(CATEGORY)
QUIT
+8 SET CATEGORY=$EXTRACT(CATEGORY,2)
+9 SET NOTEQUAL=0
+10 IF $LENGTH($PIECE(ITEM,"'=",2))
SET NOTEQUAL=1
+11 SET ITEMC="A"
+12 FOR
SET ITEMC=$ORDER(RESULTS(ITEMC))
if ITEMC=""
QUIT
if ITEMC]"A;Z"
QUIT
Begin DoDot:2
+13 IF ITEMC["A;T;"
QUIT
+14 SET NODE=""
+15 FOR
SET NODE=$ORDER(RESULTS(ITEMC,NODE))
if NODE=""
QUIT
Begin DoDot:3
+16 SET SUB=$PIECE(NODE,";",2)
+17 IF SUB=33!(SUB=80)
SET CAT="A"
+18 IF '$TEST
SET CAT=$EXTRACT(SUB)
+19 IF NOTEQUAL
IF CAT=CATEGORY
KILL RESULTS(ITEMC,NODE)
QUIT
+20 IF 'NOTEQUAL
IF CAT'=CATEGORY
KILL RESULTS(ITEMC,NODE)
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+21 IF '$LENGTH($ORDER(RESULTS("")))
SET OK=0
QUIT
+22 QUIT
+23 ;
MC(CONDS,RESULTS,OK) ;
+1 ; check conditions for Micro categories
+2 NEW CATEGORY,CATSUB,ITEM,ITEMC,NEXT,NODE,NOTEQUAL,SUB
+3 SET OK=1
+4 SET ITEM=""
+5 FOR
SET ITEM=$ORDER(CONDS("MC",ITEM))
if ITEM=""
QUIT
Begin DoDot:1
+6 SET CATEGORY=$PIECE(ITEM,"=",2)
+7 IF '$LENGTH(CATEGORY)
QUIT
+8 SET CATEGORY=$EXTRACT(CATEGORY,2)
+9 SET CATSUB=$$CATSUB^LRPXAPIU(CATEGORY,"M")
+10 SET NOTEQUAL=0
+11 IF $LENGTH($PIECE(ITEM,"'=",2))
SET NOTEQUAL=1
+12 SET ITEMC="M"
+13 FOR
SET ITEMC=$ORDER(RESULTS(ITEMC))
if ITEMC=""
QUIT
if ITEMC]"M;Z"
QUIT
Begin DoDot:2
+14 IF ITEMC["M;T;"
QUIT
+15 IF ITEMC["M;S;"
QUIT
+16 SET NODE=""
+17 FOR
SET NODE=$ORDER(RESULTS(ITEMC,NODE))
if NODE=""
QUIT
Begin DoDot:3
+18 SET SUB=$PIECE(NODE,";",4)
+19 IF NOTEQUAL
IF SUB=CATSUB
KILL RESULTS(ITEMC,NODE)
QUIT
+20 IF 'NOTEQUAL
IF SUB'=CATSUB
KILL RESULTS(ITEMC,NODE)
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+21 SET NEXT=$ORDER(RESULTS("M"))
+22 IF NEXT=""
SET OK=0
QUIT
+23 IF NEXT]"M;S"
SET OK=0
QUIT
+24 QUIT
+25 ;
AS(CONDS,RESULTS,OK) ;
+1 ; check conditions for AP specimen
+2 NEW CHECK,ITEM,ITEMC,NEXT,S
+3 SET OK=1
+4 SET ITEM=""
+5 FOR
SET ITEM=$ORDER(CONDS("AS",ITEM))
if ITEM=""
QUIT
Begin DoDot:1
+6 IF $EXTRACT(ITEM,2)="'"
Begin DoDot:2
+7 ; good if the specimen text is not present for this collection
+8 SET ITEMC="A;S;1"
+9 FOR
SET ITEMC=$ORDER(RESULTS(ITEMC))
if ITEMC=""
QUIT
if ITEMC]"A;S;Z"
QUIT
Begin DoDot:3
+10 SET S=$PIECE(ITEMC,"1.",2)
+11 SET CHECK="I "_ITEM
+12 XECUTE CHECK
IF '$TEST
KILL RESULTS(ITEMC)
End DoDot:3
End DoDot:2
QUIT
+13 ; good if any of the specimen text for this collection have a matching text
+14 IF $ORDER(RESULTS("A;S;1"))=""
QUIT
+15 IF $ORDER(RESULTS("A;S;1"))]"A;S;Z"
QUIT
+16 SET OK=0
+17 SET ITEMC="A;S;1"
+18 FOR
SET ITEMC=$ORDER(RESULTS(ITEMC))
if ITEMC=""
QUIT
if ITEMC]"A;S;Z"
QUIT
Begin DoDot:2
+19 SET S=$PIECE(ITEMC,"1.",2)
+20 SET CHECK="I "_ITEM
+21 XECUTE CHECK
IF '$TEST
KILL RESULTS(ITEMC)
End DoDot:2
End DoDot:1
+22 SET NEXT=$ORDER(RESULTS("A;S;"))
+23 IF NEXT=""
SET OK=0
QUIT
+24 IF NEXT]"A;S;Z"
SET OK=0
QUIT
+25 SET OK=1
+26 QUIT
+27 ;
MIR(CONDS,RESULTS,OK) ;
+1 ; check conditions for antimicrobial results and interpretations
+2 ; uses MCHK within this scope
+3 NEW ABNODE,ABTYPE,CHECK,I,ITEM,ITEMC,NEXTA,NEXTM,NODE,R,START,STOP
+4 SET OK=0
+5 FOR ABTYPE="A","M"
DO MCHK(ABTYPE)
+6 SET NEXTA=$ORDER(RESULTS("M;A"))
+7 SET NEXTM=$ORDER(RESULTS("M;M"))
+8 IF NEXTA=""
IF NEXTM=""
QUIT
+9 IF NEXTA=""
IF NEXTM]"M;M;Z"
QUIT
+10 IF NEXTA]"M;A;Z"
IF NEXTM=""
QUIT
+11 IF NEXTA]"M;A;Z"
IF NEXTM]"M;M;Z"
QUIT
+12 SET OK=1
+13 QUIT
MCHK(ABTYPE) ; within scope of MIR
+1 SET START="M;"_ABTYPE
+2 SET STOP=START_";Z"
+3 SET ITEM=""
+4 FOR
SET ITEM=$ORDER(CONDS("MIR",ITEM))
if ITEM=""
QUIT
Begin DoDot:1
+5 IF $EXTRACT(ITEM,2)="'"
Begin DoDot:2
+6 ; good if the interpretation/result is not present for this collection
+7 SET ITEMC=START
+8 FOR
SET ITEMC=$ORDER(RESULTS(ITEMC))
if ITEMC=""
QUIT
if ITEMC]STOP
QUIT
Begin DoDot:3
+9 SET NODE=""
+10 FOR
SET NODE=$ORDER(RESULTS(ITEMC,NODE))
if NODE=""
QUIT
Begin DoDot:4
+11 SET ABNODE=$$REFVAL^LRPXAPI(NODE)
+12 IF ABTYPE="A"
Begin DoDot:5
+13 SET I=$PIECE(ABNODE,U,2)
+14 SET R=$PIECE(ABNODE,U)
End DoDot:5
+15 IF '$TEST
Begin DoDot:5
+16 SET R=$PIECE(ABNODE,U)
+17 SET I=R
End DoDot:5
+18 SET CHECK="I "_ITEM
+19 XECUTE CHECK
IF $TEST
QUIT
+20 KILL RESULTS(ITEMC,NODE)
End DoDot:4
End DoDot:3
End DoDot:2
QUIT
+21 ; good if any of the interpretations/results have matching conditions
+22 IF $ORDER(RESULTS(START))=""
QUIT
+23 IF $ORDER(RESULTS(START))]STOP
QUIT
+24 SET ITEMC=START
+25 FOR
SET ITEMC=$ORDER(RESULTS(ITEMC))
if ITEMC=""
QUIT
if ITEMC]STOP
QUIT
Begin DoDot:2
+26 SET NODE=""
+27 FOR
SET NODE=$ORDER(RESULTS(ITEMC,NODE))
if NODE=""
QUIT
Begin DoDot:3
+28 SET ABNODE=$$REFVAL^LRPXAPI(NODE)
+29 SET I=$PIECE(ABNODE,U,2)
+30 SET R=$PIECE(ABNODE,U)
+31 SET CHECK="I "_ITEM
+32 XECUTE CHECK
IF '$TEST
KILL RESULTS(ITEMC,NODE)
End DoDot:3
End DoDot:2
End DoDot:1
+33 QUIT
+34 ;
