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