LRSPSICD ;AVAMC/REG - CY/EM/SP ICD SEARCH ;8/15/95 08:39
;;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
;
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)="AEMQZ" D ^DIC K DIC G:+Y<1 ASK
N LRX
S N=+Y,(LRX,I(1))=$P(Y(0),U),I=$P($$ICDDX^ICDEX(LRX,LRLDT,,"E"),U,4)
S ZTRTN="QUE^LRSPSICD" D BEG^LRUTL Q:POP!($D(ZTSK))
QUE U IO K ^TMP($J) D L^LRU,S^LRU,XR^LRU
S ^TMP($J,0)=I(1)_"^"_I_"^"_LRO(68)_"^"_"ICD CODE"
F X=0:0 S LRSDT=$O(^LR(LRXR,LRSDT)) Q:'LRSDT!(LRSDT>LRLDT) D L
D ^LRSPSICP K ^TMP($J) D K^LRU,END^LRUTL Q
L F LRDFN=0:0 S LRDFN=$O(^LR(LRXR,LRSDT,LRDFN)) Q:'LRDFN D I
Q
I F LRI=0:0 S LRI=$O(^LR(LRXR,LRSDT,LRDFN,LRI)) Q:'LRI D TO
Q
TO N FN
S FN=0
Q:$P($P($G(^LR(LRDFN,LRSS,LRI,0)),U,6)," ")'=LRABV D DXS Q:'FN
S LREP=^LR(LRDFN,LRSS,LRI,0),H(2)=$E($P(LREP,"^",10),1,3)
S LRAC=$P(LREP,"^",6),LRAN=+$P(LRAC," ",3)
PRT S LRPF=^DIC($P(^LR(LRDFN,0),"^",2),0,"GL"),LRFLN=+$P(@(LRPF_"0)"),"^",2),DFN=$P(^LR(LRDFN,0),"^",3),LRDPF=$P(^(0),U,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),X1=$P(LREP,"^"),X2=DOB D ^%DTC,SSN^LRU S AGE=X\365.25
S:AGE>110!(AGE<10) AGE="?"
S ^TMP($J,H(2),LRAN)=LRAC_U_AGE_U_SEX_U_LRP_U_SSN(1)_U_+$E($P(LREP,U,10),4,5)_"/"_$E($P(LREP,U,10),6,7),^TMP($J,"B",LRP,H(2),LRAN)=""
HERE Q
;
DXS N DX,DXS
S DX=0 F S DX=$O(^LR(LRDFN,LRSS,LRI,3,DX)) Q:'DX S DXS=+$G(^(DX,0)) I DXS=N S FN=1 Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSPSICD 2111 printed Apr 09, 2024@21:14:40 Page 2
LRSPSICD ;AVAMC/REG - CY/EM/SP ICD SEARCH ;8/15/95 08:39
+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 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)="AEMQZ"
DO ^DIC
KILL DIC
if +Y<1
GOTO ASK
+11 NEW LRX
+12 SET N=+Y
SET (LRX,I(1))=$PIECE(Y(0),U)
SET I=$PIECE($$ICDDX^ICDEX(LRX,LRLDT,,"E"),U,4)
+13 SET ZTRTN="QUE^LRSPSICD"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
QUIT
QUE USE IO
KILL ^TMP($JOB)
DO L^LRU
DO S^LRU
DO XR^LRU
+1 SET ^TMP($JOB,0)=I(1)_"^"_I_"^"_LRO(68)_"^"_"ICD CODE"
+2 FOR X=0:0
SET LRSDT=$ORDER(^LR(LRXR,LRSDT))
if 'LRSDT!(LRSDT>LRLDT)
QUIT
DO L
+3 DO ^LRSPSICP
KILL ^TMP($JOB)
DO K^LRU
DO END^LRUTL
QUIT
L FOR LRDFN=0:0
SET LRDFN=$ORDER(^LR(LRXR,LRSDT,LRDFN))
if 'LRDFN
QUIT
DO I
+1 QUIT
I FOR LRI=0:0
SET LRI=$ORDER(^LR(LRXR,LRSDT,LRDFN,LRI))
if 'LRI
QUIT
DO TO
+1 QUIT
TO NEW FN
+1 SET FN=0
+2 if $PIECE($PIECE($GET(^LR(LRDFN,LRSS,LRI,0)),U,6)," ")'=LRABV
QUIT
DO DXS
if 'FN
QUIT
+3 SET LREP=^LR(LRDFN,LRSS,LRI,0)
SET H(2)=$EXTRACT($PIECE(LREP,"^",10),1,3)
+4 SET LRAC=$PIECE(LREP,"^",6)
SET LRAN=+$PIECE(LRAC," ",3)
PRT SET LRPF=^DIC($PIECE(^LR(LRDFN,0),"^",2),0,"GL")
SET LRFLN=+$PIECE(@(LRPF_"0)"),"^",2)
SET DFN=$PIECE(^LR(LRDFN,0),"^",3)
SET LRDPF=$PIECE(^(0),U,2)
if '$DATA(@(LRPF_DFN_",0)"))
QUIT
+1 SET LRPPT=@(LRPF_DFN_",0)")
SET LRP=$PIECE(LRPPT,"^")
SET SSN=$PIECE(LRPPT,"^",9)
SET SEX=$PIECE(LRPPT,"^",2)
SET DOB=$PIECE(LRPPT,"^",3)
SET X1=$PIECE(LREP,"^")
SET X2=DOB
DO ^%DTC
DO SSN^LRU
SET AGE=X\365.25
+2 if AGE>110!(AGE<10)
SET AGE="?"
+3 SET ^TMP($JOB,H(2),LRAN)=LRAC_U_AGE_U_SEX_U_LRP_U_SSN(1)_U_+$EXTRACT($PIECE(LREP,U,10),4,5)_"/"_$EXTRACT($PIECE(LREP,U,10),6,7)
SET ^TMP($JOB,"B",LRP,H(2),LRAN)=""
HERE QUIT
+1 ;
DXS NEW DX,DXS
+1 SET DX=0
FOR
SET DX=$ORDER(^LR(LRDFN,LRSS,LRI,3,DX))
if 'DX
QUIT
SET DXS=+$GET(^(DX,0))
IF DXS=N
SET FN=1
QUIT
+2 QUIT
