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