LRSPSICD.m

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