CIAZPLMI ;CIA/PLS - PCC Hook for Lab- Micro Data - Results ;13-Sep-2004 14:20;PLS
;;1.1;VUECENTRIC RPMS SUPPORT;;Sep 14, 2004
;;Copyright 2000-2004, Clinical Informatics Associates, Inc.
;=================================================================
RE ; Result Message
N EXEC,GBL,VAL0,LRDFN,LRIDT,CULT,RESETIEN
;
S LRDFN=$$LRDFN^LR7OR1($G(DFN))
Q:'LRDFN
S LRIDT=$P(LABORDF,";",5)
; Determine MI Test Type
S EXEC=$P($G(^LAB(60,TST,0)),U,14) ; Edit Code
; First Field number in Execute Code entry
S GBL=$P($P($P($G(^LAB(62.07,EXEC,.1)),"/"),"=",2),"""",2)
; Get MI subfield number subscript
S GBL=$P($P($G(^DD(63.05,GBL,0)),U,4),";",1)
S VAL0=$G(^LR(LRDFN,"MI",LRIDT,GBL))
Q:$P(VAL0,U,2)'="F" ; Only process FINAL results
S CULT=TST,RESETIEN=0,VSTAT="R"
S (ORG,ATB)=""
S PTST=TST
I TST D
.I GBL=1 D BACT Q
.I GBL=5 D PARA Q
.I GBL=8 D MYCO Q
.I GBL=11 D TB Q
.I GBL=16 D VIROL Q
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:"")
;
BACT ;
N NOD3
S RES="NEGATIVE"
S NOD3=$G(^LR(LRDFN,"MI",LRIDT,3,0))
I '$P(NOD3,U,3),'$P(NOD3,U,4) D Q
.D SETADD
S RES="POSITIVE" D SETADD
D ORG(3)
Q
;
PARA ;
N NOD6
S RES="NEGATIVE"
S NOD6=$G(^LR(LRDFN,"MI",LRIDT,6,0))
I '$P(NOD6,U,3) D Q
.D SETADD
S RES="POSITIVE" D SETADD
D ORG(6)
Q
;
MYCO ;
N NOD9
S RES="NEGATIVE"
S NOD9=$G(^LR(LRDFN,"MI",LRIDT,9,0))
I '$P(NOD9,U,3) D Q
.D SETADD
S RES="POSITIVE" D SETADD
D ORG(9)
Q
;
TB ;
N NOD12
I $P(VAL0,U,3)'=""!($P(VAL0,U,4)'="") D AFSTN
I CULT=TST,$L(RES) Q
S TST=CULT
S RES="NEGATIVE"
S NOD12=$G(^LR(LRDFN,"MI",LRIDT,12,0))
I '$P(NOD12,U,3) D Q
.D SETADD
S RES="POSITIVE" D SETADD
D ORG(12)
Q
;
AFSTN ;
N TST
S TST=$O(^LAB(60,"B","ACID FAST STAIN","")) I 'TST S TST=$O(^LAB(60,"B","AFB SMEAR",""))
Q:'TST
S RES=$P(VAL0,U,3) S:$L(RES)&($L($P(VAL0,U,4))) RES=RES_";"_$P(VAL0,U,4)
S:RES="" RES=$P(VAL0,U,4)
D SETADD
Q
VIROL ;
N NOD17
S RES="NEGATIVE"
S NOD17=$G(^LR(LRDFN,"MI",LRIDT,17))
I '$P(NOD9,U,3) D Q
.D SETADD
S RES="POSITIVE" D SETADD
D ORG(17)
Q
;
ORG(LEVEL) ;
N OLP
S OLP=0 F S OLP=$O(^LR(LRDFN,"MI",LRIDT,LEVEL,OLP)) Q:'OLP D ; Sets naked reference
.S ORG=^(OLP,0),RES=$P(ORG,U,2),ORG=+ORG
.S RESETIEN=1,ATB=""
.D SETADD
.S RESETIEN=0
.I LEVEL=6 D
..D PSTG
.E I LEVEL'=17 D
..D ATB
Q
;
ATB ;
N ALP
S ALP=1 F S ALP=$O(^LR(LRDFN,"MI",LRIDT,LEVEL,OLP,ALP)) Q:'ALP D ; Sets naked reference
.S RES=$P(^(ALP),U)
.I LEVEL'=11 D
..S ATB=$O(^LAB(62.06,"AD",ALP,""))
.E D
..S ATB=$$TBATB(ALP)
.D:ATB SETADD
Q
; Return TB Antibiotic IEN
TBATB(ANTIB) ;
S ATB=0
S ATBN=$O(^DD(63.39,"GL",ANTIB,1,""))
Q:'ATBN 0
S ATBN=$P($G(^DD(63.39,ATBN,0)),U)
S ATB=$$FIND1^DIC(62.06,,"MX",ATBN)
Q $S(ATB>0:ATB,1:0)
;
PSTG ;
N SLP,STG
S SLP=$O(^LR(LRDFN,"MI",LRIDT,LEVEL,OLP,1,STG)) Q:'STG D
.S STG=^LR(LRDFN,"MI",LRIDT,LEVEL,OLP,1,STG)
.S RES=$P(STG,U,2),STG=$P(STG,U)
.D SETADD
Q
SETADD ;
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_U_RESETIEN)
Q
CIAZPLMI ;CIA/PLS - PCC Hook for Lab- Micro Data - Results ;13-Sep-2004 14:20;PLS
+1 ;;1.1;VUECENTRIC RPMS SUPPORT;;Sep 14, 2004
+2 ;;Copyright 2000-2004, Clinical Informatics Associates, Inc.
+3 ;=================================================================
RE ; Result Message
+1 NEW EXEC,GBL,VAL0,LRDFN,LRIDT,CULT,RESETIEN
+2 ;
+3 SET LRDFN=$$LRDFN^LR7OR1($GET(DFN))
+4 IF 'LRDFN
QUIT
+5 SET LRIDT=$PIECE(LABORDF,";",5)
+6 ; Determine MI Test Type
+7 ; Edit Code
SET EXEC=$PIECE($GET(^LAB(60,TST,0)),U,14)
+8 ; First Field number in Execute Code entry
+9 SET GBL=$PIECE($PIECE($PIECE($GET(^LAB(62.07,EXEC,.1)),"/"),"=",2),"""",2)
+10 ; Get MI subfield number subscript
+11 SET GBL=$PIECE($PIECE($GET(^DD(63.05,GBL,0)),U,4),";",1)
+12 SET VAL0=$GET(^LR(LRDFN,"MI",LRIDT,GBL))
+13 ; Only process FINAL results
IF $PIECE(VAL0,U,2)'="F"
QUIT
+14 SET CULT=TST
SET RESETIEN=0
SET VSTAT="R"
+15 SET (ORG,ATB)=""
+16 SET PTST=TST
+17 IF TST
Begin DoDot:1
+18 IF GBL=1
DO BACT
QUIT
+19 IF GBL=5
DO PARA
QUIT
+20 IF GBL=8
DO MYCO
QUIT
+21 IF GBL=11
DO TB
QUIT
+22 IF GBL=16
DO VIROL
QUIT
End DoDot:1
+23 QUIT
+24 ; 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 ;
BACT ;
+1 NEW NOD3
+2 SET RES="NEGATIVE"
+3 SET NOD3=$GET(^LR(LRDFN,"MI",LRIDT,3,0))
+4 IF '$PIECE(NOD3,U,3)
IF '$PIECE(NOD3,U,4)
Begin DoDot:1
+5 DO SETADD
End DoDot:1
QUIT
+6 SET RES="POSITIVE"
DO SETADD
+7 DO ORG(3)
+8 QUIT
+9 ;
PARA ;
+1 NEW NOD6
+2 SET RES="NEGATIVE"
+3 SET NOD6=$GET(^LR(LRDFN,"MI",LRIDT,6,0))
+4 IF '$PIECE(NOD6,U,3)
Begin DoDot:1
+5 DO SETADD
End DoDot:1
QUIT
+6 SET RES="POSITIVE"
DO SETADD
+7 DO ORG(6)
+8 QUIT
+9 ;
MYCO ;
+1 NEW NOD9
+2 SET RES="NEGATIVE"
+3 SET NOD9=$GET(^LR(LRDFN,"MI",LRIDT,9,0))
+4 IF '$PIECE(NOD9,U,3)
Begin DoDot:1
+5 DO SETADD
End DoDot:1
QUIT
+6 SET RES="POSITIVE"
DO SETADD
+7 DO ORG(9)
+8 QUIT
+9 ;
TB ;
+1 NEW NOD12
+2 IF $PIECE(VAL0,U,3)'=""!($PIECE(VAL0,U,4)'="")
DO AFSTN
+3 IF CULT=TST
IF $LENGTH(RES)
QUIT
+4 SET TST=CULT
+5 SET RES="NEGATIVE"
+6 SET NOD12=$GET(^LR(LRDFN,"MI",LRIDT,12,0))
+7 IF '$PIECE(NOD12,U,3)
Begin DoDot:1
+8 DO SETADD
End DoDot:1
QUIT
+9 SET RES="POSITIVE"
DO SETADD
+10 DO ORG(12)
+11 QUIT
+12 ;
AFSTN ;
+1 NEW TST
+2 SET TST=$ORDER(^LAB(60,"B","ACID FAST STAIN",""))
IF 'TST
SET TST=$ORDER(^LAB(60,"B","AFB SMEAR",""))
+3 IF 'TST
QUIT
+4 SET RES=$PIECE(VAL0,U,3)
IF $LENGTH(RES)&($LENGTH($PIECE(VAL0,U,4)))
SET RES=RES_";"_$PIECE(VAL0,U,4)
+5 IF RES=""
SET RES=$PIECE(VAL0,U,4)
+6 DO SETADD
+7 QUIT
VIROL ;
+1 NEW NOD17
+2 SET RES="NEGATIVE"
+3 SET NOD17=$GET(^LR(LRDFN,"MI",LRIDT,17))
+4 IF '$PIECE(NOD9,U,3)
Begin DoDot:1
+5 DO SETADD
End DoDot:1
QUIT
+6 SET RES="POSITIVE"
DO SETADD
+7 DO ORG(17)
+8 QUIT
+9 ;
ORG(LEVEL) ;
+1 NEW OLP
+2 ; Sets naked reference
SET OLP=0
FOR
SET OLP=$ORDER(^LR(LRDFN,"MI",LRIDT,LEVEL,OLP))
IF 'OLP
QUIT
Begin DoDot:1
+3 SET ORG=^(OLP,0)
SET RES=$PIECE(ORG,U,2)
SET ORG=+ORG
+4 SET RESETIEN=1
SET ATB=""
+5 DO SETADD
+6 SET RESETIEN=0
+7 IF LEVEL=6
Begin DoDot:2
+8 DO PSTG
End DoDot:2
+9 IF '$TEST
IF LEVEL'=17
Begin DoDot:2
+10 DO ATB
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
ATB ;
+1 NEW ALP
+2 ; Sets naked reference
SET ALP=1
FOR
SET ALP=$ORDER(^LR(LRDFN,"MI",LRIDT,LEVEL,OLP,ALP))
IF 'ALP
QUIT
Begin DoDot:1
+3 SET RES=$PIECE(^(ALP),U)
+4 IF LEVEL'=11
Begin DoDot:2
+5 SET ATB=$ORDER(^LAB(62.06,"AD",ALP,""))
End DoDot:2
+6 IF '$TEST
Begin DoDot:2
+7 SET ATB=$$TBATB(ALP)
End DoDot:2
+8 IF ATB
DO SETADD
End DoDot:1
+9 QUIT
+10 ; Return TB Antibiotic IEN
TBATB(ANTIB) ;
+1 SET ATB=0
+2 SET ATBN=$ORDER(^DD(63.39,"GL",ANTIB,1,""))
+3 IF 'ATBN
QUIT 0
+4 SET ATBN=$PIECE($GET(^DD(63.39,ATBN,0)),U)
+5 SET ATB=$$FIND1^DIC(62.06,,"MX",ATBN)
+6 QUIT $SELECT(ATB>0:ATB,1:0)
+7 ;
PSTG ;
+1 NEW SLP,STG
+2 SET SLP=$ORDER(^LR(LRDFN,"MI",LRIDT,LEVEL,OLP,1,STG))
IF 'STG
QUIT
Begin DoDot:1
+3 SET STG=^LR(LRDFN,"MI",LRIDT,LEVEL,OLP,1,STG)
+4 SET RES=$PIECE(STG,U,2)
SET STG=$PIECE(STG,U)
+5 DO SETADD
End DoDot:1
+6 QUIT
SETADD ;
+1 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_U_RESETIEN)
+2 QUIT
