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

LRPXAPI2.m

Go to the documentation of this file.
  1. LRPXAPI2 ; SLC/STAFF Lab Extract API code ;2/26/04 15:15
  1. ;;5.2;LAB SERVICE;**295,445**;Sep 27, 1994;Build 6
  1. ;
  1. VERIFIED(LRDFN,LRIDT) ; $$(lrdfn,lridt) -> 1 if verified, else 0
  1. ; checks for date report completed
  1. I +$P($G(^LR(LRDFN,"CH",LRIDT,0)),U,3) Q 1
  1. Q 0
  1. ;
  1. MIVERIFY(LRDFN,LRIDT,SUB) ; $$(lrdfn,lridt,sub) -> 1 if verified, else 0
  1. ; checks for report date approved on subscript
  1. S SUB=+$G(SUB)
  1. I SUB>0,SUB<17,$G(^LR(LRDFN,"MI",LRIDT,SUB)) Q 1
  1. Q 0
  1. ;
  1. APVERIFY(LRDFN,LRIDT,APSUB) ; $$(lrdfn,lridt,ap subscrpt) -> 1 if verified
  1. ; autopsy checks for:
  1. ; date of death,
  1. ; date autopsy report completed,
  1. ; autopsy release date/time
  1. ; otherwise, checks for date report completed and report release date
  1. N OK
  1. S OK=0
  1. I APSUB="CY"!(APSUB="EM")!(APSUB="SP") D Q OK
  1. . I $P($G(^LR(LRDFN,APSUB,LRIDT,0)),U,3),$P(^(0),U,11) S OK=1
  1. I APSUB="AU" D Q OK
  1. . I '$$DOD^LRPXAPIU($$DFN^LRPXAPIU(LRDFN)) Q
  1. . I '$P($G(^LR(LRDFN,"AU")),U,3) Q
  1. . I '$P(^LR(LRDFN,"AU"),U,15) Q
  1. . S OK=1
  1. Q OK
  1. ;
  1. VAL(LRDFN,LRIDT,LRDN) ; from LRPXAPI
  1. ; $$(lrdfn,lridt,lrdn) -> result node
  1. Q $G(^LR(LRDFN,"CH",LRIDT,LRDN))
  1. ;
  1. REFVAL(REF) ; from LRPXAPI
  1. ; $$(reference location in ^LR) -> data node
  1. N SUB
  1. I REF'[";" Q ""
  1. S SUB=$P(REF,";",2)
  1. S SUB=""""_SUB_""""
  1. S $P(REF,";",2)=SUB
  1. S REF=$TR(REF,";",",")
  1. S REF="^LR("_REF_")"
  1. Q $G(@REF)
  1. ;
  1. LRPXRM(RESULT,REF,ITEM,TYPES) ; from LRPXAPI
  1. ; returns result node from index subscript as RESULT
  1. N FILE,IEN,SECTION,TEST,VALUES
  1. S RESULT=""
  1. S VALUES=$$REFVAL(REF)
  1. I '$L(VALUES) Q
  1. I ITEM>0 D Q
  1. . S $P(VALUES,U)=$$VRESULT^LRPXAPIU(ITEM,$P(VALUES,U))
  1. . S RESULT=+ITEM_U_$$TESTNM^LRPXAPIU(+ITEM)_U_VALUES
  1. . D SC(.RESULT,REF,TYPES)
  1. I '$L(ITEM) D Q
  1. . I $P(REF,";",2)'="CH" Q
  1. . S TEST=$$TEST^LRPXAPIU(+$P(REF,";",4))
  1. . I 'TEST Q
  1. . S RESULT=TEST_U_$$TESTNM^LRPXAPIU(TEST)_U_VALUES
  1. . D SC(.RESULT,REF,TYPES)
  1. S SECTION=$P(ITEM,";") I $L(SECTION)'=1 Q
  1. S FILE=$P(ITEM,";",2) I $L(FILE)'=1 Q
  1. S IEN=+$P(ITEM,";",3) I 'IEN Q
  1. I SECTION="M" D Q
  1. . I FILE="S" S RESULT=IEN_U_$$SPECNM^LRPXAPIU(IEN)_U_VALUES Q
  1. . I FILE="T" S RESULT=IEN_U_$$TESTNM^LRPXAPIU(IEN)_U_VALUES Q
  1. . I FILE="O" S RESULT=IEN_U_$$BUGNM^LRPXAPIU(IEN)_U_VALUES Q
  1. . I FILE="A" S RESULT=IEN_U_$$ABNM^LRPXAPIU(IEN)_U_VALUES Q
  1. . I FILE="M" S RESULT=IEN_U_$$TBNM^LRPXAPIU(IEN)_U_VALUES Q
  1. I SECTION="A" D Q
  1. . I FILE="S" S RESULT=U_$$UP^XLFSTR(VALUES)_U_VALUES Q
  1. . I FILE="T" S RESULT=IEN_U_$$TESTNM^LRPXAPIU(IEN)_U_VALUES Q
  1. . I FILE="O" S RESULT=IEN_U_$$ORGNM^LRPXAPIU(IEN)_U_VALUES Q
  1. . I FILE="D" S RESULT=IEN_U_$$DISNM^LRPXAPIU(IEN)_U_VALUES Q
  1. . I FILE="M" S RESULT=IEN_U_$$MORPHNM^LRPXAPIU(IEN)_U_VALUES Q
  1. . I FILE="E" S RESULT=IEN_U_$$ETINM^LRPXAPIU(IEN)_U_VALUES Q
  1. . I FILE="F" S RESULT=IEN_U_$$FUNNM^LRPXAPIU(IEN)_U_VALUES Q
  1. . I FILE="P" S RESULT=IEN_U_$$PROCNM^LRPXAPIU(IEN)_U_VALUES Q
  1. . I FILE="I" S RESULT=IEN_U_$$ICD9^LRPXAPIU(IEN)_U_VALUES Q
  1. Q
  1. ;
  1. SC(RESULT,REF,TYPES) ;
  1. N CNT,LINE,LRDFN,LRIDT,SPEC
  1. I TYPES["S" D
  1. . S $P(REF,";",4)=0
  1. . S SPEC=+$P($$REFVAL(REF),U,5)
  1. . S RESULT("SPECIMEN")=SPEC_U_$$SPECNM^LRPXAPIU(SPEC)
  1. I TYPES["C" D
  1. . S CNT=0,LRDFN=+$P(REF,";"),LRIDT=+$P(REF,";",3)
  1. . S LINE=0
  1. . F S LINE=$O(^LR(LRDFN,"CH",LRIDT,1,LINE)) Q:LINE<1 D
  1. .. S CNT=CNT+1
  1. .. S RESULT("COMMENTS",CNT)=$G(^LR(LRDFN,"CH",LRIDT,1,LINE,0))
  1. . S RESULT("COMMENTS")=CNT
  1. Q
  1. ;
  1. SPEC(DATA,DFN,DATE,STYPE,ERR) ; from LRPXAPI
  1. ; returns specimen node, comment, values in array DATA
  1. N LRDFN,LRIDT K DATA
  1. S ERR=0
  1. S LRDFN=$$LRDFN^LRPXAPIU(DFN)
  1. I 'LRDFN S ERR=1 Q
  1. I 'DATE S ERR=1 Q
  1. S LRIDT=$$LRIDT^LRPXAPIU(DATE)
  1. D LRSPEC(.DATA,LRDFN,LRIDT,STYPE,.ERR)
  1. Q
  1. ;
  1. LRSPEC(DATA,LRDFN,LRIDT,STYPE,ERR) ; from LRPXAPI
  1. ; returns specimen node, comment, values in array DATA
  1. K DATA
  1. S ERR=0
  1. I '$O(^LR(LRDFN,"CH",LRIDT,0)) S ERR=1 Q
  1. I '$L(STYPE) S STYPE="A"
  1. I STYPE="S" D SSPEC(.DATA,LRDFN,LRIDT) Q
  1. I STYPE="C" D CSPEC(.DATA,LRDFN,LRIDT) Q
  1. I STYPE="V" D VSPEC(.DATA,LRDFN,LRIDT) Q
  1. I STYPE="A" D
  1. . N ALL K ALL
  1. . D SSPEC(.DATA,LRDFN,LRIDT) M ALL=DATA
  1. . D CSPEC(.DATA,LRDFN,LRIDT) M ALL=DATA
  1. . D VSPEC(.DATA,LRDFN,LRIDT) M ALL=DATA
  1. . K DATA M DATA=ALL
  1. Q
  1. ;
  1. SSPEC(DATA,LRDFN,LRIDT) ; specimen node values
  1. K DATA
  1. S DATA("S")=$G(^LR(LRDFN,"CH",LRIDT,0))
  1. Q
  1. ;
  1. CSPEC(DATA,LRDFN,LRIDT) ; specimen comments
  1. N CMT,CNT K DATA
  1. I '$D(^LR(LRDFN,"CH",LRIDT,1,0)) Q
  1. S CNT=0
  1. S CMT=0
  1. F S CMT=$O(^LR(LRDFN,"CH",LRIDT,1,CMT)) Q:CMT<1 D
  1. . I '$D(^LR(LRDFN,"CH",LRIDT,1,CMT,0)) Q
  1. . S CNT=CNT+1
  1. . S DATA("C",CNT)=^LR(LRDFN,"CH",LRIDT,1,CMT,0)
  1. Q
  1. ;
  1. VSPEC(DATA,LRDFN,LRIDT) ; test nodes for collected specimen
  1. N CNT,LRDN,VALUE K DATA
  1. S CNT=0
  1. S LRDN=1
  1. F S LRDN=$O(^LR(LRDFN,"CH",LRIDT,LRDN)) Q:LRDN<2 S VALUE=^(LRDN) D
  1. . S CNT=CNT+1
  1. . S DATA("V",CNT)=LRDN_U_VALUE
  1. Q
  1. ;
  1. COMMENT(LRDFN,LRIDT) ; $$(lrdfn,lridt) --> 1 if comment exists, else 0
  1. I +$O(^LR(LRDFN,"CH",LRIDT,1,0)) Q 1
  1. Q 0
  1. ;
  1. VALUE(RESULT,DFN,DATE,TEST,COND,ERR) ; from LRPXAPI, LRPXAPI1
  1. ; returns result node that has met conditions as RESULT
  1. N LRDFN,LRIDT,LRDN
  1. I $L(COND),'$$CONDOK^LRPXAPIU(COND,"C") S ERR=1 Q
  1. I $L(COND) S COND=$$REPLACE("I "_COND)
  1. S RESULT=""
  1. S ERR=0
  1. S LRDFN=$$LRDFN^LRPXAPIU(DFN)
  1. I 'LRDFN S ERR=1 Q
  1. I 'DATE S ERR=1 Q
  1. S LRIDT=$$LRIDT^LRPXAPIU(DATE)
  1. S LRDN=$$LRDN^LRPXAPIU(TEST)
  1. I 'LRDN S ERR=1 Q
  1. D LRVAL(.RESULT,LRDFN,LRIDT,LRDN,COND,.ERR)
  1. Q
  1. ;
  1. LRVALUE(RESULT,LRDFN,LRIDT,LRDN,COND,ERR) ; from LRPXAPI, LRPXAPI1
  1. ; returns result node that has met conditions as RESULT
  1. I $L(COND),'$$CONDOK^LRPXAPIU(COND,"C") S ERR=1 Q
  1. I $L(COND) S COND=$$REPLACE("I "_COND)
  1. D LRVAL(.RESULT,LRDFN,LRIDT,LRDN,COND,.ERR)
  1. Q
  1. ;
  1. LRVAL(RESULT,LRDFN,LRIDT,LRDN,COND,ERR) ;
  1. N F,S,V,VALUE
  1. S RESULT=""
  1. S ERR=0
  1. S VALUE=$G(^LR(LRDFN,"CH",LRIDT,LRDN))
  1. I '$L(VALUE) S ERR=1 Q
  1. I $L(COND) D I ERR Q
  1. . S V=$P(VALUE,U)
  1. . S F=$P(VALUE,U,2)
  1. . S S=$P($P(VALUE,U,5),"!")
  1. . I 'S S S=$P($G(^LR(LRDFN,"CH",LRIDT,0)),U,5)
  1. . X COND I '$T S ERR=1
  1. S RESULT=VALUE
  1. Q
  1. ;
  1. CHNODE(ARRAY,NODE) ; from LRPXAPI
  1. N NAME,NAME3,NAME5,NODE3,NODE5,PIECE,PIECE3,PIECE5,SUB K ARRAY
  1. I '$L(NODE) Q
  1. S NAME="RESULT^FLAG^CODES^VERIFIER^NORMALS^DATE-R^DATE-T^^INSTITUTION^LEDI^INSTRUMENT^TYPE"
  1. S NAME3="NLT-O!NLT-R!LOINC!METHOD!MAP!!TEST"
  1. S NAME5="SPEC!LOW!HIGH!LOW-C!HIGH-C!!UNITS!DELTA-T!DELTA-V!DEF!LOW-T!HIGH-T"
  1. F PIECE=1:1:12 D
  1. . I PIECE=8 Q
  1. . S SUB=$P(NAME,U,PIECE)
  1. . I PIECE=8 Q
  1. . I PIECE=3 D Q
  1. .. S NODE3=$P(NODE,U,3)
  1. .. F PIECE3=1:1:5,7 S ARRAY($P(NAME3,"!",PIECE3))=$P(NODE3,"!",PIECE3)
  1. . I PIECE=5 D Q
  1. .. S NODE5=$P(NODE,U,5)
  1. .. F PIECE5=1:1:12 D
  1. ... I PIECE5=6 Q
  1. ... S ARRAY($P(NAME5,"!",PIECE5))=$P(NODE5,"!",PIECE5)
  1. . S ARRAY(SUB)=$P(NODE,U,PIECE)
  1. Q
  1. ;
  1. ACCY(TESTS,ACC,BDN) ; from LRPXAPI
  1. ; returns TESTS from yearly accession, ACC, BDN required
  1. ; BDN is beginning date number
  1. ; TESTS is array of file 60 iens
  1. N DIC,LRAA,LRAAB,LRAD,LRAN,TEST,X,Y K DIC,TESTS
  1. I '$L($G(ACC)) Q
  1. S LRAAB=$P(ACC," ")
  1. I LRAAB="" Q
  1. S BDN=$E($G(BDN))
  1. I BDN'>1 Q
  1. S LRAN=+$P(ACC," ",3)
  1. I 'LRAN Q
  1. S LRAA=+$O(^LRO(68,"B",LRAAB,0))
  1. I 'LRAA D
  1. . S DIC=68,DIC(0)="M"
  1. . S X=LRAAB
  1. . D ^DIC K DIC
  1. . S LRAA=+Y
  1. I LRAA'>0 Q
  1. S LRAD=BDN_$P(ACC," ",2)_"0000" ; yearly acc areas are assumed
  1. S TEST=0
  1. F S TEST=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TEST)) Q:TEST<1 D
  1. . S TESTS(TEST)=TEST_U_$$TESTNM^LRPXAPIU(TEST)
  1. Q
  1. ;
  1. CONDOK(CONDO,TYPE) ; $$ from LRPXAPIU
  1. N DEL,NUM,OK,OPER,PIECE,PIECES,VALID,VALIDOP,VALUE,VAR K PIECES
  1. I '(TYPE="C"!(TYPE="M")!(TYPE="A")) Q 0
  1. S COND=CONDO
  1. I $E(COND)="|" S COND=$E(COND,2,245)
  1. I $E(COND)="~" S COND=$E(COND,2,245)
  1. I $L(COND)'>2 Q 0
  1. I $E(COND,1,2)'?1U1P Q 0
  1. I COND[U Q 0
  1. I CONDO[" " Q 0
  1. I CONDO["|" S DEL="|"
  1. E S DEL="~"
  1. I '$$SYNTAX($$REPLACE(COND)) Q 0
  1. S PIECE=COND
  1. D
  1. . I TYPE="C" S VALID="FSV" Q
  1. . I TYPE="A" S VALID="CDEFIMOPST" Q
  1. . I TYPE="M" S VALID="ACIMORST" Q
  1. F NUM=1:1 Q:'$L($P(PIECE,DEL,NUM)) S PIECES(NUM)=$P(PIECE,DEL,NUM)
  1. S OK=1
  1. S NUM=0
  1. F S NUM=$O(PIECES(NUM)) Q:NUM<1 D Q:'OK
  1. . S PIECE=PIECES(NUM)
  1. . I $L(PIECE)<3 S OK=0 Q
  1. . S VAR=$E(PIECE)
  1. . I VALID'[VAR S OK=0 Q
  1. . D
  1. .. I VAR="V" S VALIDOP="=<>[]" Q
  1. .. I VAR="F" S VALIDOP="=[]" Q
  1. .. I VAR="I" S VALIDOP="=[]" Q
  1. .. I VAR="R" S VALIDOP="=[]" Q
  1. .. I VAR="S",TYPE="A" S VALIDOP="=[]" Q
  1. .. S VALIDOP="="
  1. . I $E(PIECE,3)="'" S OK=0 Q
  1. . I $E(PIECE,2)="'" S OPER=$E(PIECE,3)
  1. . E S OPER=$E(PIECE,2)
  1. . I VALIDOP'[OPER S OK=0 Q
  1. . S VALUE=$P(PIECE,OPER,2,999)
  1. . I $E(VALUE)="""",$E(VALUE,$L(VALUE))'="""" S OK=0 Q
  1. . I VAR="C" D Q:'OK
  1. .. I VALUE'?1""""1U1"""" S OK=0 Q
  1. .. I $$CATSUB^LRPXAPIU($E(VALUE,2),TYPE)=-1 S OK=0 Q
  1. . I VALUE,VALUE'=+VALUE S OK=0 Q
  1. . I $L($P(VALUE,"""",3)) S OK=0 Q
  1. . I '$$SYNTAX(PIECE) S OK=0 Q
  1. . I $E(PIECE,2)="=",COND[(VAR_"'=") S OK=0 Q
  1. I 'OK Q 0
  1. Q 1
  1. ;
  1. REPLACE(COND) ; $$(condition) -> condition replacing | or ~ with commas
  1. Q $TR(COND,"~|",",,")
  1. ;
  1. SYNTAX(X) ; $$(condition) -> 1 if correct, else 0
  1. ; check syntax when condition applies to an if statement
  1. S X="I "_X
  1. D ^DIM
  1. I '$D(X) Q 0
  1. Q 1
  1. ;
  1. NORMALS(LOW,HIGH,TEST,SPEC) ; from LRPXAPIU
  1. N NODE
  1. S (LOW,HIGH)=""
  1. S TEST=+$G(TEST)
  1. I 'TEST Q
  1. S SPEC=+$G(SPEC)
  1. I 'SPEC Q
  1. S NODE=$G(^LAB(60,TEST,1,SPEC,0))
  1. S LOW=$P(NODE,U,2)
  1. S HIGH=$P(NODE,U,3)
  1. Q
  1. ;