CIAZPLMI.m

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