- 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
