- LRSPSICD ;VA/AVAMC/REG - CY/EM/SP ICD SEARCH ; 17-Oct-2014 09:22 ; MKK
- ;;5.2;LAB SERVICE;**72,1002,253,1018,315,1031,1034**;NOV 1, 1997;Build 188
- ;
- ; W @IOF,!?20,LRO(68)," SEARCH BY ICD9CM CODE"
- W @IOF,!?20,LRO(68)," SEARCH BY ICDCM CODE" ; IHS/MSC/MKK - LR*5.2*1034
- ASK S DIC=80,DIC(0)="AEMOQZ" D ^DIC K DIC Q:Y<1
- N LRX
- ; S N=+Y,(LRX,I(1))=$P(Y(0),U),I=$P($$ICDDX^ICDCODE(LRX,,,1),U,4)
- S N=+Y,(LRX,I(1))=$P(Y(0),U),I=$P($$ICDDX^ICDEX(LRX),U,4) ; IHS/MSC/MKK - LR*5.2*1034
- W ! D B^LRU Q:Y<0 S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99
- 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)_"^"_"ICD9CM 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 Q:$P($P($G(^LR(LRDFN,LRSS,LRI,0)),U,6)," ")'=LRABV Q:'$D(^(3,N,0))
- 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)=""
- ;
- ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- S ^TMP($J,H(2),LRAN)=LRAC_U_AGE_U_SEX_U_LRP_U_HRCN_U_+$E($P(LREP,U,10),4,5)_"/"_$E($P(LREP,U,10),6,7),^TMP($J,"B",LRP,H(2),LRAN)="" ;IHS/ANMC/CLS 08/18/96
- ;----- END IHS MODIFICATIONS
- ;
- HERE Q
- LRSPSICD ;VA/AVAMC/REG - CY/EM/SP ICD SEARCH ; 17-Oct-2014 09:22 ; MKK
- +1 ;;5.2;LAB SERVICE;**72,1002,253,1018,315,1031,1034**;NOV 1, 1997;Build 188
- +2 ;
- +3 ; W @IOF,!?20,LRO(68)," SEARCH BY ICD9CM CODE"
- +4 ; IHS/MSC/MKK - LR*5.2*1034
- WRITE @IOF,!?20,LRO(68)," SEARCH BY ICDCM CODE"
- ASK SET DIC=80
- SET DIC(0)="AEMOQZ"
- DO ^DIC
- KILL DIC
- IF Y<1
- QUIT
- +1 NEW LRX
- +2 ; S N=+Y,(LRX,I(1))=$P(Y(0),U),I=$P($$ICDDX^ICDCODE(LRX,,,1),U,4)
- +3 ; IHS/MSC/MKK - LR*5.2*1034
- SET N=+Y
- SET (LRX,I(1))=$PIECE(Y(0),U)
- SET I=$PIECE($$ICDDX^ICDEX(LRX),U,4)
- +4 WRITE !
- DO B^LRU
- IF Y<0
- QUIT
- SET LRSDT=LRSDT-.01
- SET LRLDT=LRLDT+.99
- +5 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)_"^"_"ICD9CM 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 IF $PIECE($PIECE($GET(^LR(LRDFN,LRSS,LRI,0)),U,6)," ")'=LRABV
- QUIT
- IF '$DATA(^(3,N,0))
- QUIT
- +1 SET LREP=^LR(LRDFN,LRSS,LRI,0)
- SET H(2)=$EXTRACT($PIECE(LREP,"^",10),1,3)
- +2 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 ; S:AGE>110!(AGE<10) AGE="?"
- +3 ; 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)=""
- +4 ;
- +5 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- +6 ;IHS/ANMC/CLS 08/18/96
- SET ^TMP($JOB,H(2),LRAN)=LRAC_U_AGE_U_SEX_U_LRP_U_HRCN_U_+$EXTRACT($PIECE(LREP,U,10),4,5)_"/"_$EXTRACT($PIECE(LREP,U,10),6,7)
- SET ^TMP($JOB,"B",LRP,H(2),LRAN)=""
- +7 ;----- END IHS MODIFICATIONS
- +8 ;
- HERE QUIT
