CIAZPLBB ;CIA/PLS - PCC Hook for Lab- Blood Bank data ;07-Sep-2004 19:36;DKM
;;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)
;check for PCC capture
;I $$QUEUE^CIAUTSK("TASK^CIAZPLBB","PCC VLAB FILER",,"MSG(")
D TASK
Q
; Log data
LOG(ARY,NMSP) ;
S NMSP="CIAZPLBB"_$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^CIAZPLCH(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^CIAZPLCH(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")_"+" ;todo - are +- needed
S (RES,AFLG,ORG,ATB,CMPDT)=""
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_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,PTST
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") ;todo - are +- needed
S (TCST,RES,AFLG,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
S PTST=TST
D SETADD
F S SEG=$$SEG("OBX",.LP) Q:'LP D
.S PTST=$P($P(SEG,DL1,4),U,4) Q:'$$VALTST(PTST)
.I PTST["ANTIBODY SCREEN INTERPRETATION" D
..D COOMBS
.E I PTST["ABO INTERPRETATION"!(PTST["RH INTERPRETATION") D
..S PTST=$TR(PTST," "," ")
..S RES=$P(SEG,DL1,6)
..D SETADD
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 +^CIAZPLBB(OIEN):30
I D
.D SAVE^CIAVCXPC(.ERR,.PCC)
.L -^CIAZPLBB(OIEN)
E S ERR="-1^Timeout while trying to lock record."
;I 'ERR,ORD?2U,$L($T(@ORD)) D @ORD
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 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 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
VALTST(TST) ;
Q:TST="ANTIBODY SCREEN INTERPRETATION" 1
Q:TST="ABO INTERPRETATION" 1
Q:TST="RH INTERPRETATION" 1
Q 0
;
COOMBS ;
N ATB
S ATB=""
I $E($G(DR),2,5)="LRBL" D
.I $D(^LR(LRDFN,"BB",LRI,2)) D ; Sets naked reference
..S RES=$P($G(^(2)),U,9)
..S PTST="DIRECT INTERPRETATION"
..D SETADD
..S ATB=0 F S ATB=$O(^LR(LRDFN,"BB",LRI,"EA",ATB)) Q:'ATB D
...S RES="POS"
...D SETADD
.I $D(^LR(LRDFN,"BB",LRI,6)) D ; Sets naked reference
..S RES=$G(^(6))
..S PTST="INDIRECT INTERPRETATION"
..D SETADD
..Q:RES="N"
..S RES="POS"
..S ATB=0 F S ATB=$O(^LR(LRDFN,"BB",LRI,5,ATB)) Q:'ATB D
...D SETADD
Q
;
SETADD ;
D ADD(ACT_U_PTST_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_ATB)
Q
CIAZPLBB ;CIA/PLS - PCC Hook for Lab- Blood Bank data ;07-Sep-2004 19:36;DKM
+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 ;D LOG(.MSG)
+4 ;check for PCC capture
+5 ;I $$QUEUE^CIAUTSK("TASK^CIAZPLBB","PCC VLAB FILER",,"MSG(")
+6 DO TASK
+7 QUIT
+8 ; Log data
LOG(ARY,NMSP) ;
+1 SET NMSP="CIAZPLBB"_$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^CIAZPLCH(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^CIAZPLCH(TST,ODT,.DAT)
+18 SET CPTP=$GET(DAT("CPTPTR"))
+19 SET CPTCODE=$GET(DAT("CPTCODES"))
+20 ;todo - are +- needed
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 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)
+26 DO GETCOM(.DAT)
+27 IF $DATA(DAT(1))
DO ADD("COM^1^"_DAT(1))
+28 IF $DATA(DAT(2))
DO ADD("COM^2^"_DAT(2))
+29 IF $DATA(DAT(3))
DO ADD("COM^3^"_DAT(3))
+30 ; Add Panel Tests - returns expanded panel plus original test
+31 DO EXPAND^LR7OU1(TST,.TSTARY)
+32 IF $DATA(TSTARY)
Begin DoDot:1
+33 ; remove original test
KILL TSTARY(TST)
+34 SET TST=""
FOR
SET TST=$ORDER(TSTARY(TST))
IF TST=""
QUIT
Begin DoDot:2
+35 ; V File based on Subscript
SET FLN=$SELECT($$GET1^DIQ(60,TST,4,"I")="MI":.25,SUB="BB":.31,1:.09)
+36 ; Test Cost
SET TCST=$$GET1^DIQ(60,TST,1,"E")
+37 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
+38 DO SAVE
+39 QUIT
+40 ;
RE ; Result Message
+1 NEW DAT,LP1,TSTARY,VSIT,ERR,TST,FLN,RLOW,RHIGH
+2 NEW RES,AFLG,ORG,ATB,COLSPL,SUB,SPEC,RESDT,PTST
+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 ;todo - are +- needed
SET ACT="LR"_$SELECT(SUB="MI":"M",SUB="BB":"B",1:"C")
+15 SET (TCST,RES,AFLG,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 SET PTST=TST
+25 DO SETADD
+26 FOR
SET SEG=$$SEG("OBX",.LP)
IF 'LP
QUIT
Begin DoDot:1
+27 SET PTST=$PIECE($PIECE(SEG,DL1,4),U,4)
IF '$$VALTST(PTST)
QUIT
+28 IF PTST["ANTIBODY SCREEN INTERPRETATION"
Begin DoDot:2
+29 DO COOMBS
End DoDot:2
+30 IF '$TEST
IF PTST["ABO INTERPRETATION"!(PTST["RH INTERPRETATION")
Begin DoDot:2
+31 SET PTST=$TRANSLATE(PTST," "," ")
+32 SET RES=$PIECE(SEG,DL1,6)
+33 DO SETADD
End DoDot:2
End DoDot:1
+34 DO SAVE
+35 QUIT
+36 ; 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 +^CIAZPLBB(OIEN):30
+1 IF $TEST
Begin DoDot:1
+2 DO SAVE^CIAVCXPC(.ERR,.PCC)
+3 LOCK -^CIAZPLBB(OIEN)
End DoDot:1
+4 IF '$TEST
SET ERR="-1^Timeout while trying to lock record."
+5 ;I 'ERR,ORD?2U,$L($T(@ORD)) D @ORD
+6 IF ERR
DO BUL
+7 QUIT
+8 ; 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 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 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
VALTST(TST) ;
+1 IF TST="ANTIBODY SCREEN INTERPRETATION"
QUIT 1
+2 IF TST="ABO INTERPRETATION"
QUIT 1
+3 IF TST="RH INTERPRETATION"
QUIT 1
+4 QUIT 0
+5 ;
COOMBS ;
+1 NEW ATB
+2 SET ATB=""
+3 IF $EXTRACT($GET(DR),2,5)="LRBL"
Begin DoDot:1
+4 ; Sets naked reference
IF $DATA(^LR(LRDFN,"BB",LRI,2))
Begin DoDot:2
+5 SET RES=$PIECE($GET(^(2)),U,9)
+6 SET PTST="DIRECT INTERPRETATION"
+7 DO SETADD
+8 SET ATB=0
FOR
SET ATB=$ORDER(^LR(LRDFN,"BB",LRI,"EA",ATB))
IF 'ATB
QUIT
Begin DoDot:3
+9 SET RES="POS"
+10 DO SETADD
End DoDot:3
End DoDot:2
+11 ; Sets naked reference
IF $DATA(^LR(LRDFN,"BB",LRI,6))
Begin DoDot:2
+12 SET RES=$GET(^(6))
+13 SET PTST="INDIRECT INTERPRETATION"
+14 DO SETADD
+15 IF RES="N"
QUIT
+16 SET RES="POS"
+17 SET ATB=0
FOR
SET ATB=$ORDER(^LR(LRDFN,"BB",LRI,5,ATB))
IF 'ATB
QUIT
Begin DoDot:3
+18 DO SETADD
End DoDot:3
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
SETADD ;
+1 DO ADD(ACT_U_PTST_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_ATB)
+2 QUIT
