| [613] | 1 | LRPXAPI2 ; SLC/STAFF Lab Extract API code ;2/26/04 15:15
|
|---|
| 2 | ;;5.2;LAB SERVICE;**295**;Sep 27, 1994
|
|---|
| 3 | ;
|
|---|
| 4 | VERIFIED(LRDFN,LRIDT) ; $$(lrdfn,lridt) -> 1 if verified, else 0
|
|---|
| 5 | ; checks for date report completed
|
|---|
| 6 | I +$P($G(^LR(LRDFN,"CH",LRIDT,0)),U,3) Q 1
|
|---|
| 7 | Q 0
|
|---|
| 8 | ;
|
|---|
| 9 | MIVERIFY(LRDFN,LRIDT,SUB) ; $$(lrdfn,lridt,sub) -> 1 if verified, else 0
|
|---|
| 10 | ; checks for report date approved on subscript
|
|---|
| 11 | S SUB=+$G(SUB)
|
|---|
| 12 | I SUB>0,SUB<17,$G(^LR(LRDFN,"MI",LRIDT,SUB)) Q 1
|
|---|
| 13 | Q 0
|
|---|
| 14 | ;
|
|---|
| 15 | APVERIFY(LRDFN,LRIDT,APSUB) ; $$(lrdfn,lridt,ap subscrpt) -> 1 if verified
|
|---|
| 16 | ; autopsy checks for:
|
|---|
| 17 | ; date of death,
|
|---|
| 18 | ; date autopsy report completed,
|
|---|
| 19 | ; autopsy release date/time
|
|---|
| 20 | ; otherwise, checks for date report completed and report release date
|
|---|
| 21 | N OK
|
|---|
| 22 | S OK=0
|
|---|
| 23 | I APSUB="CY"!(APSUB="EM")!(APSUB="SP") D Q OK
|
|---|
| 24 | . I $P($G(^LR(LRDFN,APSUB,LRIDT,0)),U,3),$P(^(0),U,11) S OK=1
|
|---|
| 25 | I APSUB="AU" D Q OK
|
|---|
| 26 | . I '$$DOD^LRPXAPIU($$DFN^LRPXAPIU(LRDFN)) Q
|
|---|
| 27 | . I '$P($G(^LR(LRDFN,"AU")),U,3) Q
|
|---|
| 28 | . I '$P(^LR(LRDFN,"AU"),U,15) Q
|
|---|
| 29 | . S OK=1
|
|---|
| 30 | Q OK
|
|---|
| 31 | ;
|
|---|
| 32 | VAL(LRDFN,LRIDT,LRDN) ; from LRPXAPI
|
|---|
| 33 | ; $$(lrdfn,lridt,lrdn) -> result node
|
|---|
| 34 | Q $G(^LR(LRDFN,"CH",LRIDT,LRDN))
|
|---|
| 35 | ;
|
|---|
| 36 | REFVAL(REF) ; from LRPXAPI
|
|---|
| 37 | ; $$(reference location in ^LR) -> data node
|
|---|
| 38 | N SUB
|
|---|
| 39 | I REF'[";" Q ""
|
|---|
| 40 | S SUB=$P(REF,";",2)
|
|---|
| 41 | S SUB=""""_SUB_""""
|
|---|
| 42 | S $P(REF,";",2)=SUB
|
|---|
| 43 | S REF=$TR(REF,";",",")
|
|---|
| 44 | S REF="^LR("_REF_")"
|
|---|
| 45 | Q $G(@REF)
|
|---|
| 46 | ;
|
|---|
| 47 | LRPXRM(RESULT,REF,ITEM,TYPES) ; from LRPXAPI
|
|---|
| 48 | ; returns result node from index subscript as RESULT
|
|---|
| 49 | N FILE,IEN,SECTION,TEST,VALUES
|
|---|
| 50 | S RESULT=""
|
|---|
| 51 | S VALUES=$$REFVAL(REF)
|
|---|
| 52 | I '$L(VALUES) Q
|
|---|
| 53 | I ITEM>0 D Q
|
|---|
| 54 | . S $P(VALUES,U)=$$VRESULT^LRPXAPIU(ITEM,$P(VALUES,U))
|
|---|
| 55 | . S RESULT=+ITEM_U_$$TESTNM^LRPXAPIU(+ITEM)_U_VALUES
|
|---|
| 56 | . D SC(.RESULT,REF,TYPES)
|
|---|
| 57 | I '$L(ITEM) D Q
|
|---|
| 58 | . I $P(REF,";",2)'="CH" Q
|
|---|
| 59 | . S TEST=$$TEST^LRPXAPIU(+$P(REF,";",4))
|
|---|
| 60 | . I 'TEST Q
|
|---|
| 61 | . S RESULT=TEST_U_$$TESTNM^LRPXAPIU(TEST)_U_VALUES
|
|---|
| 62 | . D SC(.RESULT,REF,TYPES)
|
|---|
| 63 | S SECTION=$P(ITEM,";") I $L(SECTION)'=1 Q
|
|---|
| 64 | S FILE=$P(ITEM,";",2) I $L(FILE)'=1 Q
|
|---|
| 65 | S IEN=+$P(ITEM,";",3) I 'IEN Q
|
|---|
| 66 | I SECTION="M" D Q
|
|---|
| 67 | . I FILE="S" S RESULT=IEN_U_$$SPECNM^LRPXAPIU(IEN)_U_VALUES Q
|
|---|
| 68 | . I FILE="T" S RESULT=IEN_U_$$TESTNM^LRPXAPIU(IEN)_U_VALUES Q
|
|---|
| 69 | . I FILE="O" S RESULT=IEN_U_$$BUGNM^LRPXAPIU(IEN)_U_VALUES Q
|
|---|
| 70 | . I FILE="A" S RESULT=IEN_U_$$ABNM^LRPXAPIU(IEN)_U_VALUES Q
|
|---|
| 71 | . I FILE="M" S RESULT=IEN_U_$$TBNM^LRPXAPIU(IEN)_U_VALUES Q
|
|---|
| 72 | I SECTION="A" D Q
|
|---|
| 73 | . I FILE="S" S RESULT=U_$$UP^XLFSTR(VALUES)_U_VALUES Q
|
|---|
| 74 | . I FILE="T" S RESULT=IEN_U_$$TESTNM^LRPXAPIU(IEN)_U_VALUES Q
|
|---|
| 75 | . I FILE="O" S RESULT=IEN_U_$$ORGNM^LRPXAPIU(IEN)_U_VALUES Q
|
|---|
| 76 | . I FILE="D" S RESULT=IEN_U_$$DISNM^LRPXAPIU(IEN)_U_VALUES Q
|
|---|
| 77 | . I FILE="M" S RESULT=IEN_U_$$MORPHNM^LRPXAPIU(IEN)_U_VALUES Q
|
|---|
| 78 | . I FILE="E" S RESULT=IEN_U_$$ETINM^LRPXAPIU(IEN)_U_VALUES Q
|
|---|
| 79 | . I FILE="F" S RESULT=IEN_U_$$FUNNM^LRPXAPIU(IEN)_U_VALUES Q
|
|---|
| 80 | . I FILE="P" S RESULT=IEN_U_$$PROCNM^LRPXAPIU(IEN)_U_VALUES Q
|
|---|
| 81 | . I FILE="I" S RESULT=IEN_U_$$ICD9^LRPXAPIU(IEN)_U_VALUES Q
|
|---|
| 82 | Q
|
|---|
| 83 | ;
|
|---|
| 84 | SC(RESULT,REF,TYPES) ;
|
|---|
| 85 | N CNT,LINE,LRDFN,LRIDT,SPEC
|
|---|
| 86 | I TYPES["S" D
|
|---|
| 87 | . S $P(REF,";",4)=0
|
|---|
| 88 | . S SPEC=+$P($$REFVAL(REF),U,5)
|
|---|
| 89 | . S RESULT("SPECIMEN")=SPEC_U_$$SPECNM^LRPXAPIU(SPEC)
|
|---|
| 90 | I TYPES["C" D
|
|---|
| 91 | . S CNT=0,LRDFN=+$P(REF,";"),LRIDT=+$P(REF,";",3)
|
|---|
| 92 | . S LINE=0
|
|---|
| 93 | . F S LINE=$O(^LR(LRDFN,"CH",LRIDT,1,LINE)) Q:LINE<1 D
|
|---|
| 94 | .. S CNT=CNT+1
|
|---|
| 95 | .. S RESULT("COMMENTS",CNT)=$G(^LR(LRDFN,"CH",LRIDT,1,LINE,0))
|
|---|
| 96 | . S RESULT("COMMENTS")=CNT
|
|---|
| 97 | Q
|
|---|
| 98 | ;
|
|---|
| 99 | SPEC(DATA,DFN,DATE,STYPE,ERR) ; from LRPXAPI
|
|---|
| 100 | ; returns specimen node, comment, values in array DATA
|
|---|
| 101 | N LRDFN,LRIDT K DATA
|
|---|
| 102 | S ERR=0
|
|---|
| 103 | S LRDFN=$$LRDFN^LRPXAPIU(DFN)
|
|---|
| 104 | I 'LRDFN S ERR=1 Q
|
|---|
| 105 | I 'DATE S ERR=1 Q
|
|---|
| 106 | S LRIDT=$$LRIDT^LRPXAPIU(DATE)
|
|---|
| 107 | D LRSPEC(.DATA,LRDFN,LRIDT,STYPE,.ERR)
|
|---|
| 108 | Q
|
|---|
| 109 | ;
|
|---|
| 110 | LRSPEC(DATA,LRDFN,LRIDT,STYPE,ERR) ; from LRPXAPI
|
|---|
| 111 | ; returns specimen node, comment, values in array DATA
|
|---|
| 112 | K DATA
|
|---|
| 113 | S ERR=0
|
|---|
| 114 | I '$O(^LR(LRDFN,"CH",LRIDT,0)) S ERR=1 Q
|
|---|
| 115 | I '$L(STYPE) S STYPE="A"
|
|---|
| 116 | I STYPE="S" D SSPEC(.DATA,LRDFN,LRIDT) Q
|
|---|
| 117 | I STYPE="C" D CSPEC(.DATA,LRDFN,LRIDT) Q
|
|---|
| 118 | I STYPE="V" D VSPEC(.DATA,LRDFN,LRIDT) Q
|
|---|
| 119 | I STYPE="A" D
|
|---|
| 120 | . N ALL K ALL
|
|---|
| 121 | . D SSPEC(.DATA,LRDFN,LRIDT) M ALL=DATA
|
|---|
| 122 | . D CSPEC(.DATA,LRDFN,LRIDT) M ALL=DATA
|
|---|
| 123 | . D VSPEC(.DATA,LRDFN,LRIDT) M ALL=DATA
|
|---|
| 124 | . K DATA M DATA=ALL
|
|---|
| 125 | Q
|
|---|
| 126 | ;
|
|---|
| 127 | SSPEC(DATA,LRDFN,LRIDT) ; specimen node values
|
|---|
| 128 | K DATA
|
|---|
| 129 | S DATA("S")=$G(^LR(LRDFN,"CH",LRIDT,0))
|
|---|
| 130 | Q
|
|---|
| 131 | ;
|
|---|
| 132 | CSPEC(DATA,LRDFN,LRIDT) ; specimen comments
|
|---|
| 133 | N CMT,CNT K DATA
|
|---|
| 134 | I '$D(^LR(LRDFN,"CH",LRIDT,1,0)) Q
|
|---|
| 135 | S CNT=0
|
|---|
| 136 | S CMT=0
|
|---|
| 137 | F S CMT=$O(^LR(LRDFN,"CH",LRIDT,1,CMT)) Q:CMT<1 D
|
|---|
| 138 | . I '$D(^LR(LRDFN,"CH",LRIDT,1,CMT,0)) Q
|
|---|
| 139 | . S CNT=CNT+1
|
|---|
| 140 | . S DATA("C",CNT)=^LR(LRDFN,"CH",LRIDT,1,CMT,0)
|
|---|
| 141 | Q
|
|---|
| 142 | ;
|
|---|
| 143 | VSPEC(DATA,LRDFN,LRIDT) ; test nodes for collected specimen
|
|---|
| 144 | N CNT,LRDN,VALUE K DATA
|
|---|
| 145 | S CNT=0
|
|---|
| 146 | S LRDN=1
|
|---|
| 147 | F S LRDN=$O(^LR(LRDFN,"CH",LRIDT,LRDN)) Q:LRDN<2 S VALUE=^(LRDN) D
|
|---|
| 148 | . S CNT=CNT+1
|
|---|
| 149 | . S DATA("V",CNT)=LRDN_U_VALUE
|
|---|
| 150 | Q
|
|---|
| 151 | ;
|
|---|
| 152 | COMMENT(LRDFN,LRIDT) ; $$(lrdfn,lridt) --> 1 if comment exists, else 0
|
|---|
| 153 | I +$O(^LR(LRDFN,"CH",LRIDT,1,0)) Q 1
|
|---|
| 154 | Q 0
|
|---|
| 155 | ;
|
|---|
| 156 | VALUE(RESULT,DFN,DATE,TEST,COND,ERR) ; from LRPXAPI, LRPXAPI1
|
|---|
| 157 | ; returns result node that has met conditions as RESULT
|
|---|
| 158 | N LRDFN,LRIDT,LRDN
|
|---|
| 159 | I $L(COND),'$$CONDOK^LRPXAPIU(COND,"C") S ERR=1 Q
|
|---|
| 160 | I $L(COND) S COND=$$REPLACE("I "_COND)
|
|---|
| 161 | S RESULT=""
|
|---|
| 162 | S ERR=0
|
|---|
| 163 | S LRDFN=$$LRDFN^LRPXAPIU(DFN)
|
|---|
| 164 | I 'LRDFN S ERR=1 Q
|
|---|
| 165 | I 'DATE S ERR=1 Q
|
|---|
| 166 | S LRIDT=$$LRIDT^LRPXAPIU(DATE)
|
|---|
| 167 | S LRDN=$$LRDN^LRPXAPIU(TEST)
|
|---|
| 168 | I 'LRDN S ERR=1 Q
|
|---|
| 169 | D LRVAL(.RESULT,LRDFN,LRIDT,LRDN,COND,.ERR)
|
|---|
| 170 | Q
|
|---|
| 171 | ;
|
|---|
| 172 | LRVALUE(RESULT,LRDFN,LRIDT,LRDN,COND,ERR) ; from LRPXAPI, LRPXAPI1
|
|---|
| 173 | ; returns result node that has met conditions as RESULT
|
|---|
| 174 | I $L(COND),'$$CONDOK^LRPXAPIU(COND,"C") S ERR=1 Q
|
|---|
| 175 | I $L(COND) S COND=$$REPLACE("I "_COND)
|
|---|
| 176 | D LRVAL(.RESULT,LRDFN,LRIDT,LRDN,COND,.ERR)
|
|---|
| 177 | Q
|
|---|
| 178 | ;
|
|---|
| 179 | LRVAL(RESULT,LRDFN,LRIDT,LRDN,COND,ERR) ;
|
|---|
| 180 | N F,S,V,VALUE
|
|---|
| 181 | S RESULT=""
|
|---|
| 182 | S ERR=0
|
|---|
| 183 | S VALUE=$G(^LR(LRDFN,"CH",LRIDT,LRDN))
|
|---|
| 184 | I '$L(VALUE) S ERR=1 Q
|
|---|
| 185 | I $L(COND) D I ERR Q
|
|---|
| 186 | . S V=$P(VALUE,U)
|
|---|
| 187 | . S F=$P(VALUE,U,2)
|
|---|
| 188 | . S S=$P($P(VALUE,U,5),"!")
|
|---|
| 189 | . I 'S S S=$P($G(^LR(LRDFN,"CH",LRIDT,0)),U,5)
|
|---|
| 190 | . X COND I '$T S ERR=1
|
|---|
| 191 | S RESULT=VALUE
|
|---|
| 192 | Q
|
|---|
| 193 | ;
|
|---|
| 194 | CHNODE(ARRAY,NODE) ; from LRPXAPI
|
|---|
| 195 | N NAME,NAME3,NAME5,NODE3,NODE5,PIECE,PIECE3,PIECE5,SUB K ARRAY
|
|---|
| 196 | I '$L(NODE) Q
|
|---|
| 197 | S NAME="RESULT^FLAG^CODES^VERIFIER^NORMALS^DATE-R^DATE-T^^INSTITUTION^LEDI^INSTRUMENT^TYPE"
|
|---|
| 198 | S NAME3="NLT-O!NLT-R!LOINC!METHOD!MAP!TEST"
|
|---|
| 199 | S NAME5="SPEC!LOW!HIGH!LOW-C!HIGH-C!!UNITS!DELTA-T!DELTA-V!DEF!LOW-T!HIGH-T"
|
|---|
| 200 | F PIECE=1:1:12 D
|
|---|
| 201 | . I PIECE=8 Q
|
|---|
| 202 | . S SUB=$P(NAME,U,PIECE)
|
|---|
| 203 | . I PIECE=8 Q
|
|---|
| 204 | . I PIECE=3 D Q
|
|---|
| 205 | .. S NODE3=$P(NODE,U,3)
|
|---|
| 206 | .. F PIECE3=1:1:6 S ARRAY($P(NAME3,"!",PIECE3))=$P(NODE3,"!",PIECE3)
|
|---|
| 207 | . I PIECE=5 D Q
|
|---|
| 208 | .. S NODE5=$P(NODE,U,5)
|
|---|
| 209 | .. F PIECE5=1:1:12 D
|
|---|
| 210 | ... I PIECE5=6 Q
|
|---|
| 211 | ... S ARRAY($P(NAME5,"!",PIECE5))=$P(NODE5,"!",PIECE5)
|
|---|
| 212 | . S ARRAY(SUB)=$P(NODE,U,PIECE)
|
|---|
| 213 | Q
|
|---|
| 214 | ;
|
|---|
| 215 | ACCY(TESTS,ACC,BDN) ; from LRPXAPI
|
|---|
| 216 | ; returns TESTS from yearly accession, ACC, BDN required
|
|---|
| 217 | ; BDN is beginning date number
|
|---|
| 218 | ; TESTS is array of file 60 iens
|
|---|
| 219 | N DIC,LRAA,LRAAB,LRAD,LRAN,TEST,X,Y K DIC,TESTS
|
|---|
| 220 | I '$L($G(ACC)) Q
|
|---|
| 221 | S LRAAB=$P(ACC," ")
|
|---|
| 222 | I LRAAB="" Q
|
|---|
| 223 | S BDN=$E($G(BDN))
|
|---|
| 224 | I BDN'>1 Q
|
|---|
| 225 | S LRAN=+$P(ACC," ",3)
|
|---|
| 226 | I 'LRAN Q
|
|---|
| 227 | S LRAA=+$O(^LRO(68,"B",LRAAB,0))
|
|---|
| 228 | I 'LRAA D
|
|---|
| 229 | . S DIC=68,DIC(0)="M"
|
|---|
| 230 | . S X=LRAAB
|
|---|
| 231 | . D ^DIC K DIC
|
|---|
| 232 | . S LRAA=+Y
|
|---|
| 233 | I LRAA'>0 Q
|
|---|
| 234 | S LRAD=BDN_$P(ACC," ",2)_"0000" ; yearly acc areas are assumed
|
|---|
| 235 | S TEST=0
|
|---|
| 236 | F S TEST=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TEST)) Q:TEST<1 D
|
|---|
| 237 | . S TESTS(TEST)=TEST_U_$$TESTNM^LRPXAPIU(TEST)
|
|---|
| 238 | Q
|
|---|
| 239 | ;
|
|---|
| 240 | CONDOK(CONDO,TYPE) ; $$ from LRPXAPIU
|
|---|
| 241 | N DEL,NUM,OK,OPER,PIECE,PIECES,VALID,VALIDOP,VALUE,VAR K PIECES
|
|---|
| 242 | I '(TYPE="C"!(TYPE="M")!(TYPE="A")) Q 0
|
|---|
| 243 | S COND=CONDO
|
|---|
| 244 | I $E(COND)="|" S COND=$E(COND,2,245)
|
|---|
| 245 | I $E(COND)="~" S COND=$E(COND,2,245)
|
|---|
| 246 | I $L(COND)'>2 Q 0
|
|---|
| 247 | I $E(COND,1,2)'?1U1P Q 0
|
|---|
| 248 | I COND[U Q 0
|
|---|
| 249 | I CONDO[" " Q 0
|
|---|
| 250 | I CONDO["|" S DEL="|"
|
|---|
| 251 | E S DEL="~"
|
|---|
| 252 | I '$$SYNTAX($$REPLACE(COND)) Q 0
|
|---|
| 253 | S PIECE=COND
|
|---|
| 254 | D
|
|---|
| 255 | . I TYPE="C" S VALID="FSV" Q
|
|---|
| 256 | . I TYPE="A" S VALID="CDEFIMOPST" Q
|
|---|
| 257 | . I TYPE="M" S VALID="ACIMORST" Q
|
|---|
| 258 | F NUM=1:1 Q:'$L($P(PIECE,DEL,NUM)) S PIECES(NUM)=$P(PIECE,DEL,NUM)
|
|---|
| 259 | S OK=1
|
|---|
| 260 | S NUM=0
|
|---|
| 261 | F S NUM=$O(PIECES(NUM)) Q:NUM<1 D Q:'OK
|
|---|
| 262 | . S PIECE=PIECES(NUM)
|
|---|
| 263 | . I $L(PIECE)<3 S OK=0 Q
|
|---|
| 264 | . S VAR=$E(PIECE)
|
|---|
| 265 | . I VALID'[VAR S OK=0 Q
|
|---|
| 266 | . D
|
|---|
| 267 | .. I VAR="V" S VALIDOP="=<>[]" Q
|
|---|
| 268 | .. I VAR="F" S VALIDOP="=[]" Q
|
|---|
| 269 | .. I VAR="I" S VALIDOP="=[]" Q
|
|---|
| 270 | .. I VAR="R" S VALIDOP="=[]" Q
|
|---|
| 271 | .. I VAR="S",TYPE="A" S VALIDOP="=[]" Q
|
|---|
| 272 | .. S VALIDOP="="
|
|---|
| 273 | . I $E(PIECE,3)="'" S OK=0 Q
|
|---|
| 274 | . I $E(PIECE,2)="'" S OPER=$E(PIECE,3)
|
|---|
| 275 | . E S OPER=$E(PIECE,2)
|
|---|
| 276 | . I VALIDOP'[OPER S OK=0 Q
|
|---|
| 277 | . S VALUE=$P(PIECE,OPER,2,999)
|
|---|
| 278 | . I $E(VALUE)="""",$E(VALUE,$L(VALUE))'="""" S OK=0 Q
|
|---|
| 279 | . I VAR="C" D Q:'OK
|
|---|
| 280 | .. I VALUE'?1""""1U1"""" S OK=0 Q
|
|---|
| 281 | .. I $$CATSUB^LRPXAPIU($E(VALUE,2),TYPE)=-1 S OK=0 Q
|
|---|
| 282 | . I VALUE,VALUE'=+VALUE S OK=0 Q
|
|---|
| 283 | . I $L($P(VALUE,"""",3)) S OK=0 Q
|
|---|
| 284 | . I '$$SYNTAX(PIECE) S OK=0 Q
|
|---|
| 285 | . I $E(PIECE,2)="=",COND[(VAR_"'=") S OK=0 Q
|
|---|
| 286 | I 'OK Q 0
|
|---|
| 287 | Q 1
|
|---|
| 288 | ;
|
|---|
| 289 | REPLACE(COND) ; $$(condition) -> condition replacing | or ~ with commas
|
|---|
| 290 | Q $TR(COND,"~|",",,")
|
|---|
| 291 | ;
|
|---|
| 292 | SYNTAX(X) ; $$(condition) -> 1 if correct, else 0
|
|---|
| 293 | ; check syntax when condition applies to an if statement
|
|---|
| 294 | S X="I "_X
|
|---|
| 295 | D ^DIM
|
|---|
| 296 | I '$D(X) Q 0
|
|---|
| 297 | Q 1
|
|---|
| 298 | ;
|
|---|
| 299 | NORMALS(LOW,HIGH,TEST,SPEC) ; from LRPXAPIU
|
|---|
| 300 | N NODE
|
|---|
| 301 | S (LOW,HIGH)=""
|
|---|
| 302 | S TEST=+$G(TEST)
|
|---|
| 303 | I 'TEST Q
|
|---|
| 304 | S SPEC=+$G(SPEC)
|
|---|
| 305 | I 'SPEC Q
|
|---|
| 306 | S NODE=$G(^LAB(60,TEST,1,SPEC,0))
|
|---|
| 307 | S LOW=$P(NODE,U,2)
|
|---|
| 308 | S HIGH=$P(NODE,U,3)
|
|---|
| 309 | Q
|
|---|
| 310 | ;
|
|---|
