LRAUSICD.m

LRAUSICD ;VA/AVAMC/REG - AUTOPSY ICDCM SEARCH ; 17-Oct-2014 09:22 ; MKK

 ;;5.2;LAB SERVICE;**1002,72,1013,253,315,1031,1034**;NOV 1, 1997;Build 188

 ;

 ; S IOP="HOME" D ^%ZIS W @IOF,?20,LRO(68)," SEARCH BY ICD9CM CODE"

 S IOP="HOME" D ^%ZIS W @IOF,?20,LRO(68)," SEARCH BY ICDCM CODE"     ; IHS/MSC/MKK - LR*5.2*1034

ASK S DIC=80,DIC(0)="AEQMZ" D ^DIC K DIC Q:Y<1  D

 . ; S N=+Y,I(1)=$P(Y(0),U,1),I=$P($$ICDDX^ICDCODE(I(1),,,1),"^",4)

 . S N=+Y,I(1)=$P(Y(0),U,1),I=$P($$ICDDX^ICDEX(I(1),,,"I",1),"^",4)  ; IHS/MSC/MKK - LR*5.2*1034

 . Q

 D B^LRU Q:Y<0  S LRLDT=LRLDT+.99

 S ZTRTN="QUE^LRAUSICD" D BEG^LRUTL Q:POP!($D(ZTSK))

QUE U IO D S^LRU K ^TMP($J) S LRPAT1=0,^TMP($J,0,1)="ICD9CM CODE: "_I(1)_"  "_I,^TMP($J,0)=I(1)_"^"_I_"^"_LRO(68)_"^"_"ICD CODE"

 F X=0:0 S LRSDT=$O(^LR("AAU",LRSDT)) Q:'LRSDT!(LRSDT>LRLDT)  D LRDFN

 D ^LRAUS K ^TMP($J) D END^LRUTL Q

LRDFN S LRDFN=0 F LRPAT1=0:1 S LRDFN=$O(^LR("AAU",LRSDT,LRDFN)) Q:'LRDFN  D SN

 Q

SN Q:$P($P($G(^LR(LRDFN,"AU")),U,6)," ")'=LRABV  Q:'$D(^LR(LRDFN,80,N,0))!('$D(^LR(LRDFN,0))#2)  S LRAU=^("AU"),LRAD=$P(LRAU,"^")

 S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3),LRPF=^DIC(LRDPF,0,"GL"),LRFLN=+$P(@(LRPF_"0)"),"^",2) Q:'$D(@(LRPF_DFN_",0)"))

 S LRPPT=@(LRPF_DFN_",0)"),LRP=$P(LRPPT,"^"),SSN=$P(LRPPT,"^",9),SEX=$P(LRPPT,"^",2),DOB=$P(LRPPT,"^",3) D SSN^LRU

 S LRYR=$E($P(LRAU,"^"),1,3),LRAC=$P(LRAU,"^",6),LRAN=+$P(LRAC," ",3)

 S X1=$P(LRAU,"^"),X2=DOB D ^%DTC S AGE=X\365.25

 S:AGE<1 AGE="<1"

 S ^TMP($J,LRYR,LRAN)=LRAC_"^"_AGE_"^"_SEX_"^"_LRP_"^"_SSN(1)_"^"_+$E($P(LRAU,"^"),4,5)_"/"_+$E($P(LRAU,"^"),6,7)

 Q

LRAUSICD  ;VA/AVAMC/REG - AUTOPSY ICDCM SEARCH ; 17-Oct-2014 09:22 ; MKK

 +1       ;;5.2;LAB SERVICE;**1002,72,1013,253,315,1031,1034**;NOV 1, 1997;Build 188

 +2       ;

 +3       ; S IOP="HOME" D ^%ZIS W @IOF,?20,LRO(68)," SEARCH BY ICD9CM CODE"

 +4       ; IHS/MSC/MKK - LR*5.2*1034

           SET IOP="HOME"

           DO ^%ZIS

           WRITE @IOF,?20,LRO(68)," SEARCH BY ICDCM CODE"

ASK        SET DIC=80

           SET DIC(0)="AEQMZ"

           DO ^DIC

           KILL DIC

           IF Y<1

               QUIT 

           Begin DoDot:1

 +1       ; S N=+Y,I(1)=$P(Y(0),U,1),I=$P($$ICDDX^ICDCODE(I(1),,,1),"^",4)

 +2       ; IHS/MSC/MKK - LR*5.2*1034

               SET N=+Y

               SET I(1)=$PIECE(Y(0),U,1)

               SET I=$PIECE($$ICDDX^ICDEX(I(1),,,"I",1),"^",4)

 +3            QUIT 

           End DoDot:1

 +4        DO B^LRU

           IF Y<0

               QUIT 

           SET LRLDT=LRLDT+.99

 +5        SET ZTRTN="QUE^LRAUSICD"

           DO BEG^LRUTL

           IF POP!($DATA(ZTSK))

               QUIT 

QUE        USE IO

           DO S^LRU

           KILL ^TMP($JOB)

           SET LRPAT1=0

           SET ^TMP($JOB,0,1)="ICD9CM CODE: "_I(1)_"  "_I

           SET ^TMP($JOB,0)=I(1)_"^"_I_"^"_LRO(68)_"^"_"ICD CODE"

 +1        FOR X=0:0

               SET LRSDT=$ORDER(^LR("AAU",LRSDT))

               IF 'LRSDT!(LRSDT>LRLDT)

                   QUIT 

               DO LRDFN

 +2        DO ^LRAUS

           KILL ^TMP($JOB)

           DO END^LRUTL

           QUIT 

LRDFN      SET LRDFN=0

           FOR LRPAT1=0:1

               SET LRDFN=$ORDER(^LR("AAU",LRSDT,LRDFN))

               IF 'LRDFN

                   QUIT 

               DO SN

 +1        QUIT 

SN         IF $PIECE($PIECE($GET(^LR(LRDFN,"AU")),U,6)," ")'=LRABV

               QUIT 

           IF '$DATA(^LR(LRDFN,80,N,0))!('$DATA(^LR(LRDFN,0))#2)

               QUIT 

           SET LRAU=^("AU")

           SET LRAD=$PIECE(LRAU,"^")

 +1        SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)

           SET DFN=$PIECE(^(0),U,3)

           SET LRPF=^DIC(LRDPF,0,"GL")

           SET LRFLN=+$PIECE(@(LRPF_"0)"),"^",2)

           IF '$DATA(@(LRPF_DFN_",0)"))

               QUIT 

 +2        SET LRPPT=@(LRPF_DFN_",0)")

           SET LRP=$PIECE(LRPPT,"^")

           SET SSN=$PIECE(LRPPT,"^",9)

           SET SEX=$PIECE(LRPPT,"^",2)

           SET DOB=$PIECE(LRPPT,"^",3)

           DO SSN^LRU

 +3        SET LRYR=$EXTRACT($PIECE(LRAU,"^"),1,3)

           SET LRAC=$PIECE(LRAU,"^",6)

           SET LRAN=+$PIECE(LRAC," ",3)

 +4        SET X1=$PIECE(LRAU,"^")

           SET X2=DOB

           DO ^%DTC

           SET AGE=X\365.25

 +5        IF AGE<1

               SET AGE="<1"

 +6        SET ^TMP($JOB,LRYR,LRAN)=LRAC_"^"_AGE_"^"_SEX_"^"_LRP_"^"_SSN(1)_"^"_+$EXTRACT($PIECE(LRAU,"^"),4,5)_"/"_+$EXTRACT($PIECE(LRAU,"^"),6,7)

 +7        QUIT