LRPXAPI6 ;SLC/STAFF Lab Extract API code ;10/5/03 14:53
;;5.2;LAB SERVICE;**295**;Sep 27, 1994
;
CONDS(CONDS,COND,TYPE,ITEM) ; from LRPXAPI3
; returns array CONDS of conditions - for Micro and AP
; used to determine match, XCONDS determines exact match
I COND["|" D XCONDS(.CONDS,COND,TYPE,$G(ITEM)) Q
N EQUAL,ITEMCHAR,NOTEQUAL,NUM,PIECE
K CONDS
I $E(COND)="~" S COND=$E(COND,2,245)
S ITEM=$G(ITEM)
I $L(ITEM) S COND=COND_"~"_$P(ITEM,";",2)_"="_$P(ITEM,";",3)
S NUM=1
F S PIECE=$P(COND,"~",NUM) Q:PIECE="" D
. S NUM=NUM+1
. S ITEMCHAR=$E(PIECE)
. I ITEMCHAR="S",TYPE="A" D Q
.. S CONDS("AS",PIECE)=""
. I ITEMCHAR="I",TYPE="M" D Q
.. S CONDS("MIR",PIECE)=""
. I ITEMCHAR="R",TYPE="M" D Q
.. S CONDS("MIR",PIECE)=""
. I ITEMCHAR="C" D Q
.. S CONDS(TYPE_"C",PIECE)=""
. S NOTEQUAL=+$P(PIECE,"'=",2)
. I NOTEQUAL S CONDS(0,TYPE_";"_ITEMCHAR_";"_NOTEQUAL)="" Q
. S EQUAL=+$P(PIECE,"=",2)
. I EQUAL S CONDS(1,TYPE_";"_ITEMCHAR_";"_EQUAL)="" Q
S CONDS="~"
Q
;
XCONDS(CONDS,COND,TYPE,ITEM) ;
; returns array CONDS of conditions - for Micro and AP
; used to determine exact match
N EQUAL,ITEMCHAR,NOTEQUAL,NUM,PIECE
K CONDS
I $E(COND)="|" S COND=$E(COND,2,245)
S ITEM=$G(ITEM)
I $L(ITEM) S COND=COND_"|"_$P(ITEM,";",2)_"="_$P(ITEM,";",3)
S NUM=1
F S PIECE=$P(COND,"|",NUM) Q:PIECE="" D
. S NUM=NUM+1
. S ITEMCHAR=$E(PIECE)
. I ITEMCHAR="S",TYPE="A" D Q
.. S CONDS("AS",PIECE)=""
.. S CONDS("X","A;S")=""
. I ITEMCHAR="I",TYPE="M" D Q
.. S CONDS("MIR",PIECE)=""
.. S CONDS("X","MIR","I")=""
. I ITEMCHAR="R",TYPE="M" D Q
.. S CONDS("MIR",PIECE)=""
.. S CONDS("X","MIR","R")=""
. I ITEMCHAR="C" D Q
.. S CONDS(TYPE_"C",PIECE)=""
.. S CONDS("X",TYPE_";C")=""
. S NOTEQUAL=+$P(PIECE,"'=",2)
. I NOTEQUAL D Q
.. S CONDS(0,TYPE_";"_ITEMCHAR_";"_NOTEQUAL)=""
.. S CONDS("X",TYPE_";"_ITEMCHAR)=""
. S EQUAL=+$P(PIECE,"=",2)
. I EQUAL D Q
.. S CONDS(1,TYPE_";"_ITEMCHAR_";"_EQUAL)=""
.. S CONDS("X",TYPE_";"_ITEMCHAR)=""
. S CONDS("X",TYPE)=""
S CONDS="|"
I NUM=2 S CONDS="~"
Q
;
ITEM(ITEM,TYPE,COND,ERR) ; from LRPXAPI1
; return an item from condition
N DEL,ITEMCHAR,NUM,PIECE
S ERR=1,ITEM=""
I TYPE="C" Q
I COND["|" S DEL="|"
E S DEL="~"
S NUM=1
F S PIECE=$P(COND,DEL,NUM) Q:PIECE="" D Q:$L(ITEM)
. S NUM=NUM+1
. S ITEMCHAR=$E(PIECE)
. I $E(PIECE,2)'="=" Q
. I ITEMCHAR="C" Q
. I ITEMCHAR="R" Q
. I ITEMCHAR="I",TYPE="M" Q
. I ITEMCHAR="S",TYPE="A" S ITEM="A;S;1."_$P(PIECE,"=",2) Q
. S ITEM=TYPE_";"_ITEMCHAR_";"_$P(PIECE,"=",2) Q
I $L(ITEM) S ERR=0
Q
;
CHECK(VAR,COND,VALUE) ; $$(variable,condition,value) -> 1 or 0
S @VAR=VALUE
X COND
Q $T
;
TEST ; *** used for testing only
F D T
Q
T N TYPE,ERR,COND,CONDS K CONDS
;D GETTYPE^LRPXAPPU(.TYPE,.ERR) I ERR Q
D GETCOND^LRPXAPPU(.COND,"A",.ERR) I ERR Q
D CONDS(.CONDS,COND,"A")
;W ! ZW CONDS
;I $$MATCH^LRPXAPI5(2,2950206.1116,.CONDS) W !,"YES",! Q
;I $$MATCH^LRPXAPI5(14,2980910.100232,.CONDS) W !,"YES",! Q
I $$MATCH^LRPXAPI5(16,2960503,.CONDS) W !,"YES",! Q
W !,"NO",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRPXAPI6 3132 printed Nov 22, 2024@17:29:38 Page 2
LRPXAPI6 ;SLC/STAFF Lab Extract API code ;10/5/03 14:53
+1 ;;5.2;LAB SERVICE;**295**;Sep 27, 1994
+2 ;
CONDS(CONDS,COND,TYPE,ITEM) ; from LRPXAPI3
+1 ; returns array CONDS of conditions - for Micro and AP
+2 ; used to determine match, XCONDS determines exact match
+3 IF COND["|"
DO XCONDS(.CONDS,COND,TYPE,$GET(ITEM))
QUIT
+4 NEW EQUAL,ITEMCHAR,NOTEQUAL,NUM,PIECE
+5 KILL CONDS
+6 IF $EXTRACT(COND)="~"
SET COND=$EXTRACT(COND,2,245)
+7 SET ITEM=$GET(ITEM)
+8 IF $LENGTH(ITEM)
SET COND=COND_"~"_$PIECE(ITEM,";",2)_"="_$PIECE(ITEM,";",3)
+9 SET NUM=1
+10 FOR
SET PIECE=$PIECE(COND,"~",NUM)
if PIECE=""
QUIT
Begin DoDot:1
+11 SET NUM=NUM+1
+12 SET ITEMCHAR=$EXTRACT(PIECE)
+13 IF ITEMCHAR="S"
IF TYPE="A"
Begin DoDot:2
+14 SET CONDS("AS",PIECE)=""
End DoDot:2
QUIT
+15 IF ITEMCHAR="I"
IF TYPE="M"
Begin DoDot:2
+16 SET CONDS("MIR",PIECE)=""
End DoDot:2
QUIT
+17 IF ITEMCHAR="R"
IF TYPE="M"
Begin DoDot:2
+18 SET CONDS("MIR",PIECE)=""
End DoDot:2
QUIT
+19 IF ITEMCHAR="C"
Begin DoDot:2
+20 SET CONDS(TYPE_"C",PIECE)=""
End DoDot:2
QUIT
+21 SET NOTEQUAL=+$PIECE(PIECE,"'=",2)
+22 IF NOTEQUAL
SET CONDS(0,TYPE_";"_ITEMCHAR_";"_NOTEQUAL)=""
QUIT
+23 SET EQUAL=+$PIECE(PIECE,"=",2)
+24 IF EQUAL
SET CONDS(1,TYPE_";"_ITEMCHAR_";"_EQUAL)=""
QUIT
End DoDot:1
+25 SET CONDS="~"
+26 QUIT
+27 ;
XCONDS(CONDS,COND,TYPE,ITEM) ;
+1 ; returns array CONDS of conditions - for Micro and AP
+2 ; used to determine exact match
+3 NEW EQUAL,ITEMCHAR,NOTEQUAL,NUM,PIECE
+4 KILL CONDS
+5 IF $EXTRACT(COND)="|"
SET COND=$EXTRACT(COND,2,245)
+6 SET ITEM=$GET(ITEM)
+7 IF $LENGTH(ITEM)
SET COND=COND_"|"_$PIECE(ITEM,";",2)_"="_$PIECE(ITEM,";",3)
+8 SET NUM=1
+9 FOR
SET PIECE=$PIECE(COND,"|",NUM)
if PIECE=""
QUIT
Begin DoDot:1
+10 SET NUM=NUM+1
+11 SET ITEMCHAR=$EXTRACT(PIECE)
+12 IF ITEMCHAR="S"
IF TYPE="A"
Begin DoDot:2
+13 SET CONDS("AS",PIECE)=""
+14 SET CONDS("X","A;S")=""
End DoDot:2
QUIT
+15 IF ITEMCHAR="I"
IF TYPE="M"
Begin DoDot:2
+16 SET CONDS("MIR",PIECE)=""
+17 SET CONDS("X","MIR","I")=""
End DoDot:2
QUIT
+18 IF ITEMCHAR="R"
IF TYPE="M"
Begin DoDot:2
+19 SET CONDS("MIR",PIECE)=""
+20 SET CONDS("X","MIR","R")=""
End DoDot:2
QUIT
+21 IF ITEMCHAR="C"
Begin DoDot:2
+22 SET CONDS(TYPE_"C",PIECE)=""
+23 SET CONDS("X",TYPE_";C")=""
End DoDot:2
QUIT
+24 SET NOTEQUAL=+$PIECE(PIECE,"'=",2)
+25 IF NOTEQUAL
Begin DoDot:2
+26 SET CONDS(0,TYPE_";"_ITEMCHAR_";"_NOTEQUAL)=""
+27 SET CONDS("X",TYPE_";"_ITEMCHAR)=""
End DoDot:2
QUIT
+28 SET EQUAL=+$PIECE(PIECE,"=",2)
+29 IF EQUAL
Begin DoDot:2
+30 SET CONDS(1,TYPE_";"_ITEMCHAR_";"_EQUAL)=""
+31 SET CONDS("X",TYPE_";"_ITEMCHAR)=""
End DoDot:2
QUIT
+32 SET CONDS("X",TYPE)=""
End DoDot:1
+33 SET CONDS="|"
+34 IF NUM=2
SET CONDS="~"
+35 QUIT
+36 ;
ITEM(ITEM,TYPE,COND,ERR) ; from LRPXAPI1
+1 ; return an item from condition
+2 NEW DEL,ITEMCHAR,NUM,PIECE
+3 SET ERR=1
SET ITEM=""
+4 IF TYPE="C"
QUIT
+5 IF COND["|"
SET DEL="|"
+6 IF '$TEST
SET DEL="~"
+7 SET NUM=1
+8 FOR
SET PIECE=$PIECE(COND,DEL,NUM)
if PIECE=""
QUIT
Begin DoDot:1
+9 SET NUM=NUM+1
+10 SET ITEMCHAR=$EXTRACT(PIECE)
+11 IF $EXTRACT(PIECE,2)'="="
QUIT
+12 IF ITEMCHAR="C"
QUIT
+13 IF ITEMCHAR="R"
QUIT
+14 IF ITEMCHAR="I"
IF TYPE="M"
QUIT
+15 IF ITEMCHAR="S"
IF TYPE="A"
SET ITEM="A;S;1."_$PIECE(PIECE,"=",2)
QUIT
+16 SET ITEM=TYPE_";"_ITEMCHAR_";"_$PIECE(PIECE,"=",2)
QUIT
End DoDot:1
if $LENGTH(ITEM)
QUIT
+17 IF $LENGTH(ITEM)
SET ERR=0
+18 QUIT
+19 ;
CHECK(VAR,COND,VALUE) ; $$(variable,condition,value) -> 1 or 0
+1 SET @VAR=VALUE
+2 XECUTE COND
+3 QUIT $TEST
+4 ;
TEST ; *** used for testing only
+1 FOR
DO T
+2 QUIT
T NEW TYPE,ERR,COND,CONDS
KILL CONDS
+1 ;D GETTYPE^LRPXAPPU(.TYPE,.ERR) I ERR Q
+2 DO GETCOND^LRPXAPPU(.COND,"A",.ERR)
IF ERR
QUIT
+3 DO CONDS(.CONDS,COND,"A")
+4 ;W ! ZW CONDS
+5 ;I $$MATCH^LRPXAPI5(2,2950206.1116,.CONDS) W !,"YES",! Q
+6 ;I $$MATCH^LRPXAPI5(14,2980910.100232,.CONDS) W !,"YES",! Q
+7 IF $$MATCH^LRPXAPI5(16,2960503,.CONDS)
WRITE !,"YES",!
QUIT
+8 WRITE !,"NO",!
+9 QUIT
