Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRPXAPI4

LRPXAPI4.m

Go to the documentation of this file. 
  1. LRPXAPI4 ;VA/SLC/STAFF - Lab Extract API code: Exact Match ;9/29/03  21:17
  1.  ;;5.2;LAB SERVICE;**1030,1031**;NOV 01, 1997
  1.  ;
  1.  ;;VA LR Patche(s): 295
  1.  ;
  1.  ;
  1. EXACT(DFN,DATE,CONDS) ; from LRPXAPI5
  1.  Q:'$$PATCH^BLRUTIL4("PXRM*1.5*12") 0               ; IHS/MSC/MKK - LR*5.2*1031
  1.  ; 
  1.  ; check if conditions are met for date/time
  1.  N FETCH,ITEM,NODE,OK,RESULTS,SEPARATE,XDATE K FETCH,RESULTS,SEPARATE
  1.  S OK=1
  1.  I '$L($O(CONDS(""))) Q 1
  1.  M FETCH=^PXRMINDX(63,"PDI",DFN,DATE)
  1.  S ITEM=""
  1.  F  S ITEM=$O(FETCH(ITEM)) Q:ITEM=""  D
  1.  . S NODE=""
  1.  . F  S NODE=$O(FETCH(ITEM,NODE)) Q:NODE=""  D
  1.  .. S SEPARATE($P(NODE,";",1,3),ITEM,NODE)=""
  1.  S XDATE=""
  1.  F  S XDATE=$O(SEPARATE(XDATE)) Q:XDATE=""  D  Q:OK
  1.  . K RESULTS
  1.  . M RESULTS=SEPARATE(XDATE)
  1.  . I '$L($O(RESULTS(""))) S OK=0 Q
  1.  . I $D(CONDS("MIR")) D MIR(.CONDS,.RESULTS,.OK) I 'OK Q
  1.  . I $D(CONDS("AS")) D AS(.CONDS,.RESULTS,.OK) I 'OK Q
  1.  . I $D(CONDS("MC")) D MC(.CONDS,.RESULTS,.OK) I 'OK Q
  1.  . I $D(CONDS("AC")) D AC(.CONDS,.RESULTS,.OK) I 'OK Q
  1.  . I $D(CONDS(1)) D EQUAL(.CONDS,.RESULTS,.OK) I 'OK Q
  1.  . I $D(CONDS(0)) D NOTEQUAL(.CONDS,.RESULTS,.OK) I 'OK Q
  1.  . I '$L($O(RESULTS(""))) S OK=0 Q
  1.  . D SCRAPS(.CONDS,.RESULTS,.OK) I 'OK Q
  1.  . D THREAD(.CONDS,.RESULTS,.OK) I 'OK Q
  1.  Q OK
  1.  ;
  1. THREAD(CONDS,RESULTS,OK) ;
  1.  ; uses TCHK within this scope
  1.  N CHK,FILE,IEN,ITEM,ITEMC,NEXT,NODE,NODEC,NUM,PAR,PARSTOP,START,STOP
  1.  S OK=1
  1.  ; check Micro - only O <-> A match
  1.  I $D(CONDS("X","M;O")),($D(CONDS("X","M;A"))!$D(CONDS("X","M;M"))) D  Q:'OK
  1.  . I '($D(CONDS("X","M;A"))!$D(CONDS("X","M;M"))!$D(CONDS("X","M;MIR"))) Q
  1.  . S ITEM="M;O;"
  1.  . F  S ITEM=$O(RESULTS(ITEM)) Q:ITEM=""  Q:ITEM]"M;O;Z"  D  Q:'OK
  1.  .. S NODE=""
  1.  .. F  S NODE=$O(RESULTS(ITEM,NODE)) Q:NODE=""  D  Q:'OK
  1.  ... S IEN=$P(NODE,";",5)
  1.  ... S OK=0
  1.  ... S ITEMC="M;A;"
  1.  ... F  S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC=""  Q:ITEMC]"M;A;Z"  D  Q:OK
  1.  .... S NODEC=""
  1.  .... F  S NODEC=$O(RESULTS(ITEMC,NODEC)) Q:NODEC=""  D  Q:OK
  1.  ..... I IEN=$P(NODEC,";",5) S OK=1 Q
  1.  ... S ITEMC="M;M;"
  1.  ... F  S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC=""  Q:ITEMC]"M;M;Z"  D  Q:OK
  1.  .... S NODEC=""
  1.  .... F  S NODEC=$O(RESULTS(ITEMC,NODEC)) Q:NODEC=""  D  Q:OK
  1.  ..... I IEN=$P(NODEC,";",5) S OK=1 Q
  1.  I $D(CONDS("X","M")) Q
  1.  ; check AP - M <-> E , S <-> T and O <-> [D M F P] match
  1.  S PAR="A;M",START="A;E"
  1.  I $D(CONDS("X",PAR)),$D(CONDS("X",START)) D TCHK(PAR,7,START) Q:'OK
  1.  S PAR="A;S",START="A;T"
  1.  I $D(CONDS("X",PAR)),$D(CONDS("X",START)) D TCHK(PAR,5,START) Q:'OK
  1.  S PAR="A;O"
  1.  I $D(CONDS("X",PAR)) D  Q:'OK
  1.  . F FILE="D","M","F","P" D  Q:'OK
  1.  .. S START="A;"_FILE
  1.  .. I $D(CONDS("X",START)) D TCHK(PAR,5,START)
  1.  Q
  1. TCHK(PAR,NUM,START) ; within scope of THREAD
  1.  S ITEM=PAR,PARSTOP=PAR_";Z",STOP=START_";Z"
  1.  F  S ITEM=$O(RESULTS(ITEM)) Q:ITEM=""  Q:ITEM]PARSTOP  D  Q:'OK
  1.  . S NODE=""
  1.  . F  S NODE=$O(RESULTS(ITEM,NODE)) Q:NODE=""  D  Q:'OK
  1.  .. S IEN=$P(NODE,";",1,NUM)
  1.  .. S CHK=0
  1.  .. S ITEMC=START
  1.  .. F  S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC=""  Q:ITEMC]STOP  D  Q:CHK
  1.  ... S NODEC=""
  1.  ... F  S NODEC=$O(RESULTS(ITEMC,NODEC)) Q:NODEC=""  D  Q:CHK
  1.  .... I IEN=$P(NODEC,";",1,NUM) S CHK=1 Q
  1.  .... I $L(NODEC,";")=4 S CHK=1 Q  ; at collection date
  1.  .. I 'CHK K RESULTS(ITEM)
  1.  S NEXT=$O(RESULTS(PAR))
  1.  I NEXT="" S OK=0 Q
  1.  I NEXT]PARSTOP S OK=0 Q
  1.  Q
  1.  ;
  1. SCRAPS(CONDS,RESULTS,OK) ;
  1.  N ITEM,ITEMC
  1.  S OK=1
  1.  S ITEM=""
  1.  F  S ITEM=$O(RESULTS(ITEM)) Q:ITEM=""  D
  1.  . S ITEMC=$P(ITEM,";",1,2)
  1.  . I ITEMC="M;A",$D(CONDS("MIR")) Q
  1.  . I ITEMC="M;M",$D(CONDS("MIR")) Q
  1.  . I '$D(CONDS("X",ITEMC)) K RESULTS(ITEM)
  1.  I '$L($O(RESULTS(""))) S OK=0 Q
  1.  Q
  1.  ;
  1. NOTEQUAL(CONDS,RESULTS,OK) ;
  1.  ; check not equal condition for pointer values
  1.  N FILE,ITEM,START,STOP,TYPE
  1.  S OK=1
  1.  S ITEM=""
  1.  F  S ITEM=$O(CONDS(0,ITEM)) Q:ITEM=""  D  Q:'OK
  1.  . S TYPE=$E(ITEM),FILE=$E(ITEM,3),START=TYPE_";"_FILE,STOP=TYPE_";"_FILE_";Z"
  1.  . K RESULTS(ITEM)
  1.  . S NEXT=$O(RESULTS(START))
  1.  . I NEXT="" S OK=0 Q
  1.  . I NEXT]STOP S OK=0 Q
  1.  Q
  1.  ;
  1. EQUAL(CONDS,RESULTS,OK) ;
  1.  ; check equal condition for pointer values
  1.  N FILE,ITEM,ITEMC,NEXT,START,STOP,TYPE
  1.  S OK=1
  1.  S ITEM=""
  1.  F  S ITEM=$O(CONDS(1,ITEM)) Q:ITEM=""  D
  1.  . S TYPE=$E(ITEM),FILE=$E(ITEM,3),START=TYPE_";"_FILE,STOP=TYPE_";"_FILE_";Z"
  1.  . S ITEMC=START
  1.  . F  S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC=""  Q:ITEMC]STOP  D
  1.  .. I ITEMC=ITEM Q
  1.  .. K RESULTS(ITEMC)
  1.  S NEXT=$O(RESULTS(START))
  1.  I NEXT="" S OK=0 Q
  1.  I NEXT]STOP S OK=0 Q
  1.  Q
  1.  ;
  1. AC(CONDS,RESULTS,OK) ;
  1.  ; check conditions for AP categories
  1.  N CAT,CATEGORY,ITEM,ITEMC,NODE,NOTEQUAL,SUB
  1.  S OK=1
  1.  S ITEM=""
  1.  F  S ITEM=$O(CONDS("AC",ITEM)) Q:ITEM=""  D
  1.  . S CATEGORY=$P(ITEM,"=",2)
  1.  . I '$L(CATEGORY) Q
  1.  . S CATEGORY=$E(CATEGORY,2)
  1.  . S NOTEQUAL=0
  1.  . I $L($P(ITEM,"'=",2)) S NOTEQUAL=1
  1.  . S ITEMC="A"
  1.  . F  S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC=""  Q:ITEMC]"A;Z"  D
  1.  .. I ITEMC["A;T;" Q
  1.  .. S NODE=""
  1.  .. F  S NODE=$O(RESULTS(ITEMC,NODE)) Q:NODE=""  D
  1.  ... S SUB=$P(NODE,";",2)
  1.  ... I SUB=33!(SUB=80) S CAT="A"
  1.  ... E  S CAT=$E(SUB)
  1.  ... I NOTEQUAL,CAT=CATEGORY K RESULTS(ITEMC,NODE) Q
  1.  ... I 'NOTEQUAL,CAT'=CATEGORY K RESULTS(ITEMC,NODE) Q
  1.  I '$L($O(RESULTS(""))) S OK=0 Q
  1.  Q
  1.  ;
  1. MC(CONDS,RESULTS,OK) ;
  1.  ; check conditions for Micro categories
  1.  N CATEGORY,CATSUB,ITEM,ITEMC,NEXT,NODE,NOTEQUAL,SUB
  1.  S OK=1
  1.  S ITEM=""
  1.  F  S ITEM=$O(CONDS("MC",ITEM)) Q:ITEM=""  D
  1.  . S CATEGORY=$P(ITEM,"=",2)
  1.  . I '$L(CATEGORY) Q
  1.  . S CATEGORY=$E(CATEGORY,2)
  1.  . S CATSUB=$$CATSUB^LRPXAPIU(CATEGORY,"M")
  1.  . S NOTEQUAL=0
  1.  . I $L($P(ITEM,"'=",2)) S NOTEQUAL=1
  1.  . S ITEMC="M"
  1.  . F  S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC=""  Q:ITEMC]"M;Z"  D
  1.  .. I ITEMC["M;T;" Q
  1.  .. I ITEMC["M;S;" Q
  1.  .. S NODE=""
  1.  .. F  S NODE=$O(RESULTS(ITEMC,NODE)) Q:NODE=""  D
  1.  ... S SUB=$P(NODE,";",4)
  1.  ... I NOTEQUAL,SUB=CATSUB K RESULTS(ITEMC,NODE) Q
  1.  ... I 'NOTEQUAL,SUB'=CATSUB K RESULTS(ITEMC,NODE) Q
  1.  S NEXT=$O(RESULTS("M"))
  1.  I NEXT="" S OK=0 Q
  1.  I NEXT]"M;S" S OK=0 Q
  1.  Q
  1.  ;
  1. AS(CONDS,RESULTS,OK) ;
  1.  ; check conditions for AP specimen
  1.  N CHECK,ITEM,ITEMC,NEXT,S
  1.  S OK=1
  1.  S ITEM=""
  1.  F  S ITEM=$O(CONDS("AS",ITEM)) Q:ITEM=""  D
  1.  . I $E(ITEM,2)="'" D  Q
  1.  .. ; good if the specimen text is not present for this collection
  1.  .. S ITEMC="A;S;1"
  1.  .. F  S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC=""  Q:ITEMC]"A;S;Z"  D
  1.  ... S S=$P(ITEMC,"1.",2)
  1.  ... S CHECK="I "_ITEM
  1.  ... X CHECK I '$T K RESULTS(ITEMC)
  1.  . ; good if any of the specimen text for this collection have a matching text
  1.  . I $O(RESULTS("A;S;1"))="" Q
  1.  . I $O(RESULTS("A;S;1"))]"A;S;Z" Q
  1.  . S OK=0
  1.  . S ITEMC="A;S;1"
  1.  . F  S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC=""  Q:ITEMC]"A;S;Z"  D
  1.  .. S S=$P(ITEMC,"1.",2)
  1.  .. S CHECK="I "_ITEM
  1.  .. X CHECK I '$T K RESULTS(ITEMC)
  1.  S NEXT=$O(RESULTS("A;S;"))
  1.  I NEXT="" S OK=0 Q
  1.  I NEXT]"A;S;Z" S OK=0 Q
  1.  S OK=1
  1.  Q
  1.  ;
  1. MIR(CONDS,RESULTS,OK) ;
  1.  ; check conditions for antimicrobial results and interpretations
  1.  ; uses MCHK within this scope
  1.  N ABNODE,ABTYPE,CHECK,I,ITEM,ITEMC,NEXTA,NEXTM,NODE,R,START,STOP
  1.  S OK=0
  1.  F ABTYPE="A","M" D MCHK(ABTYPE)
  1.  S NEXTA=$O(RESULTS("M;A"))
  1.  S NEXTM=$O(RESULTS("M;M"))
  1.  I NEXTA="",NEXTM="" Q
  1.  I NEXTA="",NEXTM]"M;M;Z" Q
  1.  I NEXTA]"M;A;Z",NEXTM="" Q
  1.  I NEXTA]"M;A;Z",NEXTM]"M;M;Z" Q
  1.  S OK=1
  1.  Q
  1. MCHK(ABTYPE) ; within scope of MIR
  1.  S START="M;"_ABTYPE
  1.  S STOP=START_";Z"
  1.  S ITEM=""
  1.  F  S ITEM=$O(CONDS("MIR",ITEM)) Q:ITEM=""  D
  1.  . I $E(ITEM,2)="'" D  Q
  1.  .. ; good if the interpretation/result is not present for this collection
  1.  .. S ITEMC=START
  1.  .. F  S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC=""  Q:ITEMC]STOP  D
  1.  ... S NODE=""
  1.  ... F  S NODE=$O(RESULTS(ITEMC,NODE)) Q:NODE=""  D
  1.  .... S ABNODE=$$REFVAL^LRPXAPI(NODE)
  1.  .... I ABTYPE="A" D
  1.  ..... S I=$P(ABNODE,U,2)
  1.  ..... S R=$P(ABNODE,U)
  1.  .... E  D
  1.  ..... S R=$P(ABNODE,U)
  1.  ..... S I=R
  1.  .... S CHECK="I "_ITEM
  1.  .... X CHECK I $T Q
  1.  .... K RESULTS(ITEMC,NODE)
  1.  . ; good if any of the interpretations/results have matching conditions
  1.  . I $O(RESULTS(START))="" Q
  1.  . I $O(RESULTS(START))]STOP Q
  1.  . S ITEMC=START
  1.  . F  S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC=""  Q:ITEMC]STOP  D
  1.  .. S NODE=""
  1.  .. F  S NODE=$O(RESULTS(ITEMC,NODE)) Q:NODE=""  D
  1.  ... S ABNODE=$$REFVAL^LRPXAPI(NODE)
  1.  ... S I=$P(ABNODE,U,2)
  1.  ... S R=$P(ABNODE,U)
  1.  ... S CHECK="I "_ITEM
  1.  ... X CHECK I '$T K RESULTS(ITEMC,NODE)
  1.  Q
  1.  ;