LRAUSICD ;AVAMC/REG - AUTOPSY ICD SEARCH ;8/15/95 09:01
;;5.2;LAB SERVICE;**72,253,315,422**;Sep 27, 1994;Build 29
;
; Reference to $$CSI^ICDEX supported by ICR #5747
; Reference to $$SINFO^ICDEX supported by ICR #5747
; Reference to $$ICDDX^ICDEX supported by ICR #5747
;
S IOP="HOME" D ^%ZIS W @IOF,?20,LRO(68)," SEARCH BY ICD CODE"
ASK W ! D B^LRU Q:Y<0
N LR,VAR,ICDFMT,ICDSYS
S Y=$$IMP^ICDEX(30) S LR("I10DTI")=Y X ^DD("DD") S LR("I10DTE")=Y
I (LRSDT<LR("I10DTI")),(LRLDT'<LR("I10DTI")) D G ASK
. W !!,$C(7),"Beginning and Ending dates must both be prior to "_LR("I10DTE")_"(ICD-9)"
. W !,"or both be on or after "_LR("I10DTE")_"(ICD-10)."
S ICDFMT=$S(LRSDT<LR("I10DTI"):1,1:2)
S ICDSYS=+$$SINFO^ICDEX("DIAG",LRLDT)
S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99
S DIC("A")="Select ICD Diagnosis: "
S DIC=80,DIC(0)="AEQMZ" D ^DIC K DIC G:+Y<1 ASK D
. S N=+Y,I(1)=$P(Y(0),U,1),I=$P($$ICDDX^ICDEX(I(1),LRLDT,,"E"),"^",4)
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)="ICD 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAUSICD 1955 printed Nov 22, 2024@17:19:52 Page 2
LRAUSICD ;AVAMC/REG - AUTOPSY ICD SEARCH ;8/15/95 09:01
+1 ;;5.2;LAB SERVICE;**72,253,315,422**;Sep 27, 1994;Build 29
+2 ;
+3 ; Reference to $$CSI^ICDEX supported by ICR #5747
+4 ; Reference to $$SINFO^ICDEX supported by ICR #5747
+5 ; Reference to $$ICDDX^ICDEX supported by ICR #5747
+6 ;
+7 SET IOP="HOME"
DO ^%ZIS
WRITE @IOF,?20,LRO(68)," SEARCH BY ICD CODE"
ASK WRITE !
DO B^LRU
if Y<0
QUIT
+1 NEW LR,VAR,ICDFMT,ICDSYS
+2 SET Y=$$IMP^ICDEX(30)
SET LR("I10DTI")=Y
XECUTE ^DD("DD")
SET LR("I10DTE")=Y
+3 IF (LRSDT<LR("I10DTI"))
IF (LRLDT'<LR("I10DTI"))
Begin DoDot:1
+4 WRITE !!,$CHAR(7),"Beginning and Ending dates must both be prior to "_LR("I10DTE")_"(ICD-9)"
+5 WRITE !,"or both be on or after "_LR("I10DTE")_"(ICD-10)."
End DoDot:1
GOTO ASK
+6 SET ICDFMT=$SELECT(LRSDT<LR("I10DTI"):1,1:2)
+7 SET ICDSYS=+$$SINFO^ICDEX("DIAG",LRLDT)
+8 SET LRSDT=LRSDT-.01
SET LRLDT=LRLDT+.99
+9 SET DIC("A")="Select ICD Diagnosis: "
+10 SET DIC=80
SET DIC(0)="AEQMZ"
DO ^DIC
KILL DIC
if +Y<1
GOTO ASK
Begin DoDot:1
+11 SET N=+Y
SET I(1)=$PIECE(Y(0),U,1)
SET I=$PIECE($$ICDDX^ICDEX(I(1),LRLDT,,"E"),"^",4)
End DoDot:1
+12 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)="ICD 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
