- 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 Feb 18, 2025@23:45:26 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
