Routine: CIAZPLCH

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

 ; 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)

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

SN ; New Order

 ; Currently not used

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

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

 ; 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

 ; Add to PCC array

ADD(X,Y) ;

 I +$G(Y) D

 .S PCC(Y)=X

 E  S PCC=$G(PCC)+1,PCC(PCC)=X

 ; 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

 ; 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

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)

 ; 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)

 ; 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)

CIAZPLCH.m