CIAZPLCH ;CIA/PLS - PCC Hook for Lab- Chem data ;23-Apr-2004 11:11;PLS
;;1.1;VUECENTRIC RPMS SUPPORT;;Sep 14, 2004
;;Copyright 2000-2004, Clinical Informatics Associates, Inc.
;=================================================================
EN(DATA) N MSG
I $D(DATA)=1 M MSG=@DATA
E M MSG=DATA
D LOG(.MSG)
;I $$QUEUE^CIAUTSK("TASK^CIAZPLCH","PCC VLAB FILER",,"MSG(")
D TASK
Q
; Log data
LOG(ARY,NMSP) ;
S NMSP="CIAZPLCH"_$S($G(NMSP)="":"",1:"."_NMSP)
L +^XTMP(NMSP):2
M ^($O(^XTMP(NMSP,""),-1)+1)=ARY
L -^XTMP(NMSP)
Q
TASK N SEG,LP,DL1,DL2,OIEN,ORD,ACC,STATUS,DFN,DAT,LOC,ERR,PCC,VSIT
N CAT,CONTROL,LABORD,PRV,ODT,CDT,VLAB,SPEC,VSTAT,CPTP,CPTCODE
N DAT,ACT,LOINC,DIAG,LODT,LSEQ
S LP=0
S SEG=$$SEG("MSH",.LP)
Q:'LP
S DL1=$E(SEG,4),DL2=$E(SEG,5)
Q:$P(SEG,DL1,3)'="LABORATORY"
S SEG=$$SEG("PID",.LP)
Q:'LP
S DFN=+$P(SEG,DL1,4)
Q:'DFN
S SEG=$$SEG("PV1",.LP)
Q:'LP
S LOC=+$P($P(SEG,DL1,4),DL2)
S CAT=$S($P(SEG,DL1,3)="I":"I",1:"A")
S SEG=$$SEG("ORC",.LP)
Q:'LP
S STATUS=$P(SEG,DL1,6) ; Order status
S OIEN=$P($P(SEG,DL1,3),DL2) ; OE/RR order number
Q:'OIEN ; Must have an OE/RR order number
S LABORDF=$P($P(SEG,DL1,4),DL2) ; Lab order information
S LABORD=$P(LABORDF,";") ; Lab order number w/File 69 ref
S LODT=$P(LABORDF,";",2) ; Lab order date
S LSEQ=$P(LABORDF,";",3) ; Lab order seq number
S CONTROL=$P(SEG,DL1,2)
S PRV=+$P(SEG,DL1,13) ; Ordering Provider
S ODT=$$FMDATE^LR7OU0($P(SEG,DL1,16)) ; Order effective Date/Time
S CMPDT=$$FMDATE^LR7OU0($P($P(SEG,DL1,8),U,5)) ; Complete Date/Time
;
I CONTROL?2U,$L($T(@CONTROL)) D @CONTROL
Q
SN ; New Order
; Currently not used
Q
SC ; Status Change
N DAT,LP1,TSTARY,VSIT,ERR,TST,FLN,SUB,LOINC
N RES,AFLG,ORG,ATB,COLSPL,CMPDT,UNITS,RLOW,RHIGH,ORG,ATB
N CMPDT
S SEG=$$SEG("OBR",.LP)
Q:'LP
S TST=+$P($P(SEG,DL1,5),DL2,4) ; Primary test
S CDT=$$FMDATE^LR7OU0($P(SEG,DL1,8)) ; Collection Date/Time
S SPEC=$P($P($P(SEG,DL1,16),DL2,4),";") ;Specimen pointer to File 61
S COLSPL=$P($P(SEG,DL1,16),";",4) ; Collection Sample to File 62
S ACC=$P(SEG,DL1,21) ; Accession Number
S VSTAT="A" ; V File Status
S TCST=$$GET1^DIQ(60,TST,1,"E") ; Test cost
S SUB=$$GET1^DIQ(60,TST,4,"I") ; Subscript
S LOINC=$$LOINC(TST,SPEC) ; LOINC Code associated with test/specimen
S (UNITS,RLOW,RHIGH,ORG,ATB)=""
S FLN=$S(SUB="MI":.25,SUB="BB":.31,1:.09) ; V File based on Subscript
D GETCPT(TST,ODT,.DAT)
S CPTP=$G(DAT("CPTPTR"))
S CPTCODE=$G(DAT("CPTCODES"))
S ACT="LR"_$S(SUB="MI":"M",SUB="BB":"B",1:"C")_"+"
S (RES,AFLG,ORG,ATB,CMPDT)=""
D ADD("HDR^^^"_LOC_";"_ODT_";"_CAT_";")
D ADD("VST^PT^"_DFN)
D ADD("VST^DT^"_ODT)
;D ADD("PRV^"_PRV_"^^^^1") ;V Lab doesn't appear to set V Provider
D ADD(ACT_U_TST_U_FLN_U_VSTAT_U_ACC_U_LABORDF_U_ODT_U_CDT_U_PRV_U_TCST_U_SPEC_U_COLSPL)
D GETCOM(.DAT)
D:$D(DAT(1)) ADD("COM^1^"_DAT(1))
D:$D(DAT(2)) ADD("COM^2^"_DAT(2))
D:$D(DAT(3)) ADD("COM^3^"_DAT(3))
; Add Panel Tests - returns expanded panel plus original test
D EXPAND^LR7OU1(TST,.TSTARY)
I $D(TSTARY) D
.K TSTARY(TST) ; remove original test
.S TST="" F S TST=$O(TSTARY(TST)) Q:TST="" D
..S FLN=$S($$GET1^DIQ(60,TST,4,"I")="MI":.25,SUB="BB":.31,1:.09) ; V File based on Subscript
..S TCST=$$GET1^DIQ(60,TST,1,"E") ; Test Cost
..D ADD(ACT_U_TST_U_FLN_U_VSTAT_U_ACC_U_LABORDF_U_ODT_U_CDT_U_PRV_U_TCST_U_SPEC_U_COLSPL)
D SAVE
Q
;
RE ; Result Message
N DAT,LP1,TSTARY,VSIT,ERR,TST,FLN,RLOW,RHIGH
N RES,AFLG,ORG,ATB,COLSPL,SUB,SPEC,RESDT
Q:$$FINDNODE(.MSG,"OBX")<0 ; Result message without OBX segment
S SEG=$$SEG("OBR",.LP)
Q:'LP
S TST=+$P($P(SEG,DL1,5),DL2,4) ; Primary test
S CDT=$$FMDATE^LR7OU0($P(SEG,DL1,8)) ; Collection Date/Time
S SPEC=$P($P($P(SEG,DL1,16),DL2,4),";") ; Specimen pointer to File 61
S COLSPL=$P($P(SEG,DL1,16),";",4) ; Collection Sample to File 62
S ACC=$P(SEG,DL1,21) ; Accession Number
S VSTAT="R" ; V File Status
S SUB=$$GET1^DIQ(60,TST,4,"I")
S FLN=$S(SUB="MI":.25,SUB="BB":.31,1:.09) ; V File based on Subscript
S ACT="LR"_$S(SUB="MI":"M",SUB="BB":"B",1:"C")
S (TCST,RES,AFLG,UNITS,RLOW,RHIGH,ORG,ATB)=""
D ADD("HDR^^^"_LOC_";"_ODT_";"_CAT_";")
D ADD("VST^PT^"_DFN)
D ADD("VST^DT^"_ODT)
D GETCOM(.DAT)
D:$D(DAT(1)) ADD("COM^1^"_DAT(1))
D:$D(DAT(2)) ADD("COM^2^"_DAT(2))
D:$D(DAT(3)) ADD("COM^3^"_DAT(3))
; Save OBR data
I ACT["LRM" D ; Process Micro Results
.D RE^CIAZPLMI
E D
.D ADD(ACT_U_TST_U_FLN_U_VSTAT_U_ACC_U_LABORDF_U_ODT_U_CDT_U_PRV_U_TCST_U_SPEC_U_COLSPL_U_RES_U_CMPDT)
.F S SEG=$$SEG("OBX",.LP) Q:'LP D
..S TST=+$P($P(SEG,DL1,4),U,4) Q:'TST
..S RES=$P(SEG,DL1,6)
..S UNITS=$P(SEG,DL1,7)
..S AFLG=$P(SEG,DL1,9)
..S RLOW=$$FREFRNG("L",TST,SPEC)
..S RHIGH=$$FREFRNG("H",TST,SPEC)
..D ADD(ACT_U_TST_U_FLN_U_VSTAT_U_ACC_U_LABORDF_U_ODT_U_CDT_U_PRV_U_TCST_U_SPEC_U_COLSPL_U_RES_U_CMPDT_U_AFLG_U_UNITS_U_RLOW_U_RHIGH_U_ORG_U_ATB)
D SAVE
Q
; Order Cancel message
OC ;
N DAT,LP1,TSTARY,VSIT,ERR,TST,FLN,SUB,COLSPL
S SEG=$$SEG("OBR",.LP)
Q:'LP
S TST=+$P($P(SEG,DL1,5),DL2,4) ; Primary test
S ACC=$P(SEG,DL1,21) ; Accession Number
S VSTAT="D" ; V File Status
S SUB=$$GET1^DIQ(60,TST,4,"I") ; Subscript
S (TCST,UNITS,RLOW,RHIGH,ORG,ATB,COLSPL,CDT)=""
S FLN=$S(SUB="MI":.25,SUB="BB":.31,1:.09) ; V File based on Subscript
S ACT="LR"_$S(SUB="MI":"M",SUB="BB":"B",1:"C")_"-"
D ADD("HDR^^^"_LOC_";"_ODT_";"_CAT_";")
D ADD("VST^PT^"_DFN)
D ADD("VST^DT^"_ODT)
D ADD(ACT_U_TST_U_FLN_U_VSTAT_U_ACC_U_LABORDF_U_ODT_U_CDT_U_PRV)
; Add Panel Tests - returns expanded panel plus original test
D EXPAND^LR7OU1(TST,.TSTARY)
I $D(TSTARY) D
.K TSTARY(TST) ; remove original test
.S TST="" F S TST=$O(TSTARY(TST)) Q:TST="" D
..S FLN=$S($$GET1^DIQ(60,TST,4,"I")="MI":.25,SUB="BB":.31,1:.09) ; V File based on Subscript
..D ADD(ACT_U_TST_U_FLN_U_VSTAT_U_ACC_U_LABORDF_U_ODT_U_CDT_U_PRV)
D SAVE
;
SAVE L +^CIAZPLCH(OIEN):30
I D
.D SAVE^CIAVCXPC(.ERR,.PCC)
.L -^CIAZPLCH(OIEN)
E S ERR="-1^Timeout while trying to lock record."
D:ERR BUL
Q
; Add to PCC array
ADD(X,Y) ;
I +$G(Y) D
.S PCC(Y)=X
E S PCC=$G(PCC)+1,PCC(PCC)=X
Q
; Find a node in PCC array
FINDNODE(ARY,VAL) ;
N LP
S LP=0 F S LP=$O(ARY(LP)) Q:'LP Q:$E(ARY(LP),1,$L(VAL))=VAL
Q $S(LP:LP,1:-1)
; Return reference range for given test and specimen
FREFRNG(TYPE,TST,SPEC) ;
N AGE,SEX,SNODE,VAL
S TYPE=$G(TYPE,"L")
S AGE=$$GET1^DIQ(2,DFN,.033,"E")
S SEX=$$GET1^DIQ(2,DFN,.02,"I")
S SNODE=$G(^LAB(60,TST,1,SPEC,0))
I $L(SNODE) D
.S VAL=$P(SNODE,U,$S(TYPE="H":3,1:2))
.X:VAL'?.N!(VAL'="") "S VAL="_VAL
Q VAL
; Return specified segment, starting at line LP
SEG(TYP,LP) ;
F S LP=$O(MSG(LP)) Q:'LP Q:$E(MSG(LP),1,$L(TYP))=TYP
Q $S(LP:MSG(LP),1:"")
; Send a bulletin on error
BUL N XMB,XMTEXT,XMY,XMDUZ,XMDT,XMYBLOB,XMZ
S XMB="APCD PCC PACKAGE LINK FAIL"
S XMB(1)=OIEN
S XMB(2)=$P($G(^DPT(DFN,0)),U)
S XMB(3)=LABORD
S XMB(4)=$$FMTE^XLFDT(ODT)
S XMB(5)=$P(ERR,U,2)
S XMDUZ=.5
D ^XMB
Q
; Return CPT code for given test
GETCPT(TST,ODTM,DAT) ;
;Input: TST - pointer to File 60
; ODTM - Order Date/Time
N PTST,FND,LP,CPTP,CPCODE,CPCOST,CPRC,CPAC
N CPDAT,MOD,QUAL,CPTCODES
S FND=0,PTST=0,(MOD,QUAL,CPTCODES)=""
K DAT
F S PTST=$O(^BLRCPT("C",TST,PTST)) Q:'PTST!FND D
.Q:$$GET1^DIQ(9009021,PTST,102,"I") ; Inactive Flag
.Q:ODTM<$$GET1^DIQ(9009021,PTST,.03,"I") ; Order Date>Create Date
.D GETCPT1
.S DAT("CPTPTR")=PTST
.S DAT("CPTCODES")=CPTCODES
Q
GETCPT1 ;
S FND=1
S CPTP=0 F S CPTP=$O(^BLRCPT(PTST,11,CPTP)) Q:'CPTP D
.S CPDAT=$G(^BLRCPT(PTST,11,CPTP,0))
.S CPCODE=$P(CPDAT,U),CPCOST=$P(CPDAT,U,2),CPRC=$P(CPDAT,U,3),CPAC=$P(CPDAT,U,4)
.S LP=0 F S LP=$O(^BLRCPT(PTST,11,CPTP,1,LP)) Q:'LP D
..S MOD=MOD_^BLRCPT(PTST,11,CPTP,1,LP,0)_","
.S:$E(MOD,$L(MOD))="," MOD=$E(MOD,1,$L(MOD)-1)
.S LP=0 F S LP=$O(^BLRCPT(PTST,11,CPTP,2,LP)) Q:'LP D
..S QUAL=QUAL_^BLRCPT(PTST,11,CPTP,2,LP,0)_","
.S:$E(QUAL,$L(QUAL))="," QUAL=$E(QUAL,1,$L(QUAL)-1)
.S CPTCODES=CPTCODES_CPCODE_DL1_CPCOST_DL1_CPRC_DL1_CPAC_DL1_MOD_DL1_QUAL_";"
S:$E(CPTCODES,$L(CPTCODES))=";" CPTCODES=$E(CPTCODES,1,$L(CPTCODES)-1)
Q
; Return comments
GETCOM(ARY) ;
N CNT,LP
K ARY
S CNT=0,LP=0
F S LP=$O(MSG(LP),-1) Q:'LP I $E(MSG(LP),1,3)="NTE" D
.S CNT=CNT+1,ARY(CNT)=$P(MSG(LP),DL1,4)
Q
; Return LOINC code
; Input: TST - Laboratory Test File IEN
; SPEC - Site/Specimen IEN
LOINC(TST,SPEC) ;
Q $$GET1^DIQ(60.01,SPEC_","_TST_",",95.3,"I")
; Return Diagnosis stored in Lab Order File
; Input: TST - Laboratory Test File IEN
; ODT - Lab Order File Date
; SEQ - Lab Order File Date Sequence number
DIAG(TST,ODT,SEQ) ;
N TIEN
S TIEN=$O(^LRO(69,ODT,1,SEQ,2,"B",TST,""))
Q $$GET1^DIQ(69.03,TIEN_","_SEQ_","_ODT_",",9999999.1)
CIAZPLCH ;CIA/PLS - PCC Hook for Lab- Chem data ;23-Apr-2004 11:11;PLS
+1 ;;1.1;VUECENTRIC RPMS SUPPORT;;Sep 14, 2004
+2 ;;Copyright 2000-2004, Clinical Informatics Associates, Inc.
+3 ;=================================================================
EN(DATA) NEW MSG
+1 IF $DATA(DATA)=1
MERGE MSG=@DATA
+2 IF '$TEST
MERGE MSG=DATA
+3 DO LOG(.MSG)
+4 ;I $$QUEUE^CIAUTSK("TASK^CIAZPLCH","PCC VLAB FILER",,"MSG(")
+5 DO TASK
+6 QUIT
+7 ; Log data
LOG(ARY,NMSP) ;
+1 SET NMSP="CIAZPLCH"_$SELECT($GET(NMSP)="":"",1:"."_NMSP)
+2 LOCK +^XTMP(NMSP):2
+3 MERGE ^($ORDER(^XTMP(NMSP,""),-1)+1)=ARY
+4 LOCK -^XTMP(NMSP)
+5 QUIT
TASK NEW SEG,LP,DL1,DL2,OIEN,ORD,ACC,STATUS,DFN,DAT,LOC,ERR,PCC,VSIT
+1 NEW CAT,CONTROL,LABORD,PRV,ODT,CDT,VLAB,SPEC,VSTAT,CPTP,CPTCODE
+2 NEW DAT,ACT,LOINC,DIAG,LODT,LSEQ
+3 SET LP=0
+4 SET SEG=$$SEG("MSH",.LP)
+5 IF 'LP
QUIT
+6 SET DL1=$EXTRACT(SEG,4)
SET DL2=$EXTRACT(SEG,5)
+7 IF $PIECE(SEG,DL1,3)'="LABORATORY"
QUIT
+8 SET SEG=$$SEG("PID",.LP)
+9 IF 'LP
QUIT
+10 SET DFN=+$PIECE(SEG,DL1,4)
+11 IF 'DFN
QUIT
+12 SET SEG=$$SEG("PV1",.LP)
+13 IF 'LP
QUIT
+14 SET LOC=+$PIECE($PIECE(SEG,DL1,4),DL2)
+15 SET CAT=$SELECT($PIECE(SEG,DL1,3)="I":"I",1:"A")
+16 SET SEG=$$SEG("ORC",.LP)
+17 IF 'LP
QUIT
+18 ; Order status
SET STATUS=$PIECE(SEG,DL1,6)
+19 ; OE/RR order number
SET OIEN=$PIECE($PIECE(SEG,DL1,3),DL2)
+20 ; Must have an OE/RR order number
IF 'OIEN
QUIT
+21 ; Lab order information
SET LABORDF=$PIECE($PIECE(SEG,DL1,4),DL2)
+22 ; Lab order number w/File 69 ref
SET LABORD=$PIECE(LABORDF,";")
+23 ; Lab order date
SET LODT=$PIECE(LABORDF,";",2)
+24 ; Lab order seq number
SET LSEQ=$PIECE(LABORDF,";",3)
+25 SET CONTROL=$PIECE(SEG,DL1,2)
+26 ; Ordering Provider
SET PRV=+$PIECE(SEG,DL1,13)
+27 ; Order effective Date/Time
SET ODT=$$FMDATE^LR7OU0($PIECE(SEG,DL1,16))
+28 ; Complete Date/Time
SET CMPDT=$$FMDATE^LR7OU0($PIECE($PIECE(SEG,DL1,8),U,5))
+29 ;
+30 IF CONTROL?2U
IF $LENGTH($TEXT(@CONTROL))
DO @CONTROL
+31 QUIT
SN ; New Order
+1 ; Currently not used
+2 QUIT
SC ; Status Change
+1 NEW DAT,LP1,TSTARY,VSIT,ERR,TST,FLN,SUB,LOINC
+2 NEW RES,AFLG,ORG,ATB,COLSPL,CMPDT,UNITS,RLOW,RHIGH,ORG,ATB
+3 NEW CMPDT
+4 SET SEG=$$SEG("OBR",.LP)
+5 IF 'LP
QUIT
+6 ; Primary test
SET TST=+$PIECE($PIECE(SEG,DL1,5),DL2,4)
+7 ; Collection Date/Time
SET CDT=$$FMDATE^LR7OU0($PIECE(SEG,DL1,8))
+8 ;Specimen pointer to File 61
SET SPEC=$PIECE($PIECE($PIECE(SEG,DL1,16),DL2,4),";")
+9 ; Collection Sample to File 62
SET COLSPL=$PIECE($PIECE(SEG,DL1,16),";",4)
+10 ; Accession Number
SET ACC=$PIECE(SEG,DL1,21)
+11 ; V File Status
SET VSTAT="A"
+12 ; Test cost
SET TCST=$$GET1^DIQ(60,TST,1,"E")
+13 ; Subscript
SET SUB=$$GET1^DIQ(60,TST,4,"I")
+14 ; LOINC Code associated with test/specimen
SET LOINC=$$LOINC(TST,SPEC)
+15 SET (UNITS,RLOW,RHIGH,ORG,ATB)=""
+16 ; V File based on Subscript
SET FLN=$SELECT(SUB="MI":.25,SUB="BB":.31,1:.09)
+17 DO GETCPT(TST,ODT,.DAT)
+18 SET CPTP=$GET(DAT("CPTPTR"))
+19 SET CPTCODE=$GET(DAT("CPTCODES"))
+20 SET ACT="LR"_$SELECT(SUB="MI":"M",SUB="BB":"B",1:"C")_"+"
+21 SET (RES,AFLG,ORG,ATB,CMPDT)=""
+22 DO ADD("HDR^^^"_LOC_";"_ODT_";"_CAT_";")
+23 DO ADD("VST^PT^"_DFN)
+24 DO ADD("VST^DT^"_ODT)
+25 ;D ADD("PRV^"_PRV_"^^^^1") ;V Lab doesn't appear to set V Provider
+26 DO ADD(ACT_U_TST_U_FLN_U_VSTAT_U_ACC_U_LABORDF_U_ODT_U_CDT_U_PRV_U_TCST_U_SPEC_U_COLSPL)
+27 DO GETCOM(.DAT)
+28 IF $DATA(DAT(1))
DO ADD("COM^1^"_DAT(1))
+29 IF $DATA(DAT(2))
DO ADD("COM^2^"_DAT(2))
+30 IF $DATA(DAT(3))
DO ADD("COM^3^"_DAT(3))
+31 ; Add Panel Tests - returns expanded panel plus original test
+32 DO EXPAND^LR7OU1(TST,.TSTARY)
+33 IF $DATA(TSTARY)
Begin DoDot:1
+34 ; remove original test
KILL TSTARY(TST)
+35 SET TST=""
FOR
SET TST=$ORDER(TSTARY(TST))
IF TST=""
QUIT
Begin DoDot:2
+36 ; V File based on Subscript
SET FLN=$SELECT($$GET1^DIQ(60,TST,4,"I")="MI":.25,SUB="BB":.31,1:.09)
+37 ; Test Cost
SET TCST=$$GET1^DIQ(60,TST,1,"E")
+38 DO ADD(ACT_U_TST_U_FLN_U_VSTAT_U_ACC_U_LABORDF_U_ODT_U_CDT_U_PRV_U_TCST_U_SPEC_U_COLSPL)
End DoDot:2
End DoDot:1
+39 DO SAVE
+40 QUIT
+41 ;
RE ; Result Message
+1 NEW DAT,LP1,TSTARY,VSIT,ERR,TST,FLN,RLOW,RHIGH
+2 NEW RES,AFLG,ORG,ATB,COLSPL,SUB,SPEC,RESDT
+3 ; Result message without OBX segment
IF $$FINDNODE(.MSG,"OBX")<0
QUIT
+4 SET SEG=$$SEG("OBR",.LP)
+5 IF 'LP
QUIT
+6 ; Primary test
SET TST=+$PIECE($PIECE(SEG,DL1,5),DL2,4)
+7 ; Collection Date/Time
SET CDT=$$FMDATE^LR7OU0($PIECE(SEG,DL1,8))
+8 ; Specimen pointer to File 61
SET SPEC=$PIECE($PIECE($PIECE(SEG,DL1,16),DL2,4),";")
+9 ; Collection Sample to File 62
SET COLSPL=$PIECE($PIECE(SEG,DL1,16),";",4)
+10 ; Accession Number
SET ACC=$PIECE(SEG,DL1,21)
+11 ; V File Status
SET VSTAT="R"
+12 SET SUB=$$GET1^DIQ(60,TST,4,"I")
+13 ; V File based on Subscript
SET FLN=$SELECT(SUB="MI":.25,SUB="BB":.31,1:.09)
+14 SET ACT="LR"_$SELECT(SUB="MI":"M",SUB="BB":"B",1:"C")
+15 SET (TCST,RES,AFLG,UNITS,RLOW,RHIGH,ORG,ATB)=""
+16 DO ADD("HDR^^^"_LOC_";"_ODT_";"_CAT_";")
+17 DO ADD("VST^PT^"_DFN)
+18 DO ADD("VST^DT^"_ODT)
+19 DO GETCOM(.DAT)
+20 IF $DATA(DAT(1))
DO ADD("COM^1^"_DAT(1))
+21 IF $DATA(DAT(2))
DO ADD("COM^2^"_DAT(2))
+22 IF $DATA(DAT(3))
DO ADD("COM^3^"_DAT(3))
+23 ; Save OBR data
+24 ; Process Micro Results
IF ACT["LRM"
Begin DoDot:1
+25 DO RE^CIAZPLMI
End DoDot:1
+26 IF '$TEST
Begin DoDot:1
+27 DO ADD(ACT_U_TST_U_FLN_U_VSTAT_U_ACC_U_LABORDF_U_ODT_U_CDT_U_PRV_U_TCST_U_SPEC_U_COLSPL_U_RES_U_CMPDT)
+28 FOR
SET SEG=$$SEG("OBX",.LP)
IF 'LP
QUIT
Begin DoDot:2
+29 SET TST=+$PIECE($PIECE(SEG,DL1,4),U,4)
IF 'TST
QUIT
+30 SET RES=$PIECE(SEG,DL1,6)
+31 SET UNITS=$PIECE(SEG,DL1,7)
+32 SET AFLG=$PIECE(SEG,DL1,9)
+33 SET RLOW=$$FREFRNG("L",TST,SPEC)
+34 SET RHIGH=$$FREFRNG("H",TST,SPEC)
+35 DO ADD(ACT_U_TST_U_FLN_U_VSTAT_U_ACC_U_LABORDF_U_ODT_U_CDT_U_PRV_U_TCST_U_SPEC_U_COLSPL_U_RES_U_CMPDT_U_AFLG_U_UNITS_U_RLOW_U_RHIGH_U_ORG_U_ATB)
End DoDot:2
End DoDot:1
+36 DO SAVE
+37 QUIT
+38 ; Order Cancel message
OC ;
+1 NEW DAT,LP1,TSTARY,VSIT,ERR,TST,FLN,SUB,COLSPL
+2 SET SEG=$$SEG("OBR",.LP)
+3 IF 'LP
QUIT
+4 ; Primary test
SET TST=+$PIECE($PIECE(SEG,DL1,5),DL2,4)
+5 ; Accession Number
SET ACC=$PIECE(SEG,DL1,21)
+6 ; V File Status
SET VSTAT="D"
+7 ; Subscript
SET SUB=$$GET1^DIQ(60,TST,4,"I")
+8 SET (TCST,UNITS,RLOW,RHIGH,ORG,ATB,COLSPL,CDT)=""
+9 ; V File based on Subscript
SET FLN=$SELECT(SUB="MI":.25,SUB="BB":.31,1:.09)
+10 SET ACT="LR"_$SELECT(SUB="MI":"M",SUB="BB":"B",1:"C")_"-"
+11 DO ADD("HDR^^^"_LOC_";"_ODT_";"_CAT_";")
+12 DO ADD("VST^PT^"_DFN)
+13 DO ADD("VST^DT^"_ODT)
+14 DO ADD(ACT_U_TST_U_FLN_U_VSTAT_U_ACC_U_LABORDF_U_ODT_U_CDT_U_PRV)
+15 ; Add Panel Tests - returns expanded panel plus original test
+16 DO EXPAND^LR7OU1(TST,.TSTARY)
+17 IF $DATA(TSTARY)
Begin DoDot:1
+18 ; remove original test
KILL TSTARY(TST)
+19 SET TST=""
FOR
SET TST=$ORDER(TSTARY(TST))
IF TST=""
QUIT
Begin DoDot:2
+20 ; V File based on Subscript
SET FLN=$SELECT($$GET1^DIQ(60,TST,4,"I")="MI":.25,SUB="BB":.31,1:.09)
+21 DO ADD(ACT_U_TST_U_FLN_U_VSTAT_U_ACC_U_LABORDF_U_ODT_U_CDT_U_PRV)
End DoDot:2
End DoDot:1
+22 DO SAVE
+23 ;
SAVE LOCK +^CIAZPLCH(OIEN):30
+1 IF $TEST
Begin DoDot:1
+2 DO SAVE^CIAVCXPC(.ERR,.PCC)
+3 LOCK -^CIAZPLCH(OIEN)
End DoDot:1
+4 IF '$TEST
SET ERR="-1^Timeout while trying to lock record."
+5 IF ERR
DO BUL
+6 QUIT
+7 ; Add to PCC array
ADD(X,Y) ;
+1 IF +$GET(Y)
Begin DoDot:1
+2 SET PCC(Y)=X
End DoDot:1
+3 IF '$TEST
SET PCC=$GET(PCC)+1
SET PCC(PCC)=X
+4 QUIT
+5 ; Find a node in PCC array
FINDNODE(ARY,VAL) ;
+1 NEW LP
+2 SET LP=0
FOR
SET LP=$ORDER(ARY(LP))
IF 'LP
QUIT
IF $EXTRACT(ARY(LP),1,$LENGTH(VAL))=VAL
QUIT
+3 QUIT $SELECT(LP:LP,1:-1)
+4 ; Return reference range for given test and specimen
FREFRNG(TYPE,TST,SPEC) ;
+1 NEW AGE,SEX,SNODE,VAL
+2 SET TYPE=$GET(TYPE,"L")
+3 SET AGE=$$GET1^DIQ(2,DFN,.033,"E")
+4 SET SEX=$$GET1^DIQ(2,DFN,.02,"I")
+5 SET SNODE=$GET(^LAB(60,TST,1,SPEC,0))
+6 IF $LENGTH(SNODE)
Begin DoDot:1
+7 SET VAL=$PIECE(SNODE,U,$SELECT(TYPE="H":3,1:2))
+8 IF VAL'?.N!(VAL'="")
XECUTE "S VAL="_VAL
End DoDot:1
+9 QUIT VAL
+10 ; Return specified segment, starting at line LP
SEG(TYP,LP) ;
+1 FOR
SET LP=$ORDER(MSG(LP))
IF 'LP
QUIT
IF $EXTRACT(MSG(LP),1,$LENGTH(TYP))=TYP
QUIT
+2 QUIT $SELECT(LP:MSG(LP),1:"")
+3 ; Send a bulletin on error
BUL NEW XMB,XMTEXT,XMY,XMDUZ,XMDT,XMYBLOB,XMZ
+1 SET XMB="APCD PCC PACKAGE LINK FAIL"
+2 SET XMB(1)=OIEN
+3 SET XMB(2)=$PIECE($GET(^DPT(DFN,0)),U)
+4 SET XMB(3)=LABORD
+5 SET XMB(4)=$$FMTE^XLFDT(ODT)
+6 SET XMB(5)=$PIECE(ERR,U,2)
+7 SET XMDUZ=.5
+8 DO ^XMB
+9 QUIT
+10 ; Return CPT code for given test
GETCPT(TST,ODTM,DAT) ;
+1 ;Input: TST - pointer to File 60
+2 ; ODTM - Order Date/Time
+3 NEW PTST,FND,LP,CPTP,CPCODE,CPCOST,CPRC,CPAC
+4 NEW CPDAT,MOD,QUAL,CPTCODES
+5 SET FND=0
SET PTST=0
SET (MOD,QUAL,CPTCODES)=""
+6 KILL DAT
+7 FOR
SET PTST=$ORDER(^BLRCPT("C",TST,PTST))
IF 'PTST!FND
QUIT
Begin DoDot:1
+8 ; Inactive Flag
IF $$GET1^DIQ(9009021,PTST,102,"I")
QUIT
+9 ; Order Date>Create Date
IF ODTM<$$GET1^DIQ(9009021,PTST,.03,"I")
QUIT
+10 DO GETCPT1
+11 SET DAT("CPTPTR")=PTST
+12 SET DAT("CPTCODES")=CPTCODES
End DoDot:1
+13 QUIT
GETCPT1 ;
+1 SET FND=1
+2 SET CPTP=0
FOR
SET CPTP=$ORDER(^BLRCPT(PTST,11,CPTP))
IF 'CPTP
QUIT
Begin DoDot:1
+3 SET CPDAT=$GET(^BLRCPT(PTST,11,CPTP,0))
+4 SET CPCODE=$PIECE(CPDAT,U)
SET CPCOST=$PIECE(CPDAT,U,2)
SET CPRC=$PIECE(CPDAT,U,3)
SET CPAC=$PIECE(CPDAT,U,4)
+5 SET LP=0
FOR
SET LP=$ORDER(^BLRCPT(PTST,11,CPTP,1,LP))
IF 'LP
QUIT
Begin DoDot:2
+6 SET MOD=MOD_^BLRCPT(PTST,11,CPTP,1,LP,0)_","
End DoDot:2
+7 IF $EXTRACT(MOD,$LENGTH(MOD))=","
SET MOD=$EXTRACT(MOD,1,$LENGTH(MOD)-1)
+8 SET LP=0
FOR
SET LP=$ORDER(^BLRCPT(PTST,11,CPTP,2,LP))
IF 'LP
QUIT
Begin DoDot:2
+9 SET QUAL=QUAL_^BLRCPT(PTST,11,CPTP,2,LP,0)_","
End DoDot:2
+10 IF $EXTRACT(QUAL,$LENGTH(QUAL))=","
SET QUAL=$EXTRACT(QUAL,1,$LENGTH(QUAL)-1)
+11 SET CPTCODES=CPTCODES_CPCODE_DL1_CPCOST_DL1_CPRC_DL1_CPAC_DL1_MOD_DL1_QUAL_";"
End DoDot:1
+12 IF $EXTRACT(CPTCODES,$LENGTH(CPTCODES))=";"
SET CPTCODES=$EXTRACT(CPTCODES,1,$LENGTH(CPTCODES)-1)
+13 QUIT
+14 ; Return comments
GETCOM(ARY) ;
+1 NEW CNT,LP
+2 KILL ARY
+3 SET CNT=0
SET LP=0
+4 FOR
SET LP=$ORDER(MSG(LP),-1)
IF 'LP
QUIT
IF $EXTRACT(MSG(LP),1,3)="NTE"
Begin DoDot:1
+5 SET CNT=CNT+1
SET ARY(CNT)=$PIECE(MSG(LP),DL1,4)
End DoDot:1
+6 QUIT
+7 ; Return LOINC code
+8 ; Input: TST - Laboratory Test File IEN
+9 ; SPEC - Site/Specimen IEN
LOINC(TST,SPEC) ;
+1 QUIT $$GET1^DIQ(60.01,SPEC_","_TST_",",95.3,"I")
+2 ; Return Diagnosis stored in Lab Order File
+3 ; Input: TST - Laboratory Test File IEN
+4 ; ODT - Lab Order File Date
+5 ; SEQ - Lab Order File Date Sequence number
DIAG(TST,ODT,SEQ) ;
+1 NEW TIEN
+2 SET TIEN=$ORDER(^LRO(69,ODT,1,SEQ,2,"B",TST,""))
+3 QUIT $$GET1^DIQ(69.03,TIEN_","_SEQ_","_ODT_",",9999999.1)
