source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRSPSICD.m@ 724

Last change on this file since 724 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 1.3 KB
Line 
1LRSPSICD ;AVAMC/REG - CY/EM/SP ICD SEARCH ;8/15/95 08:39
2 ;;5.2;LAB SERVICE;**72,253**;Sep 27, 1994
3 W @IOF,!?20,LRO(68)," SEARCH BY ICD9CM CODE"
4ASK S DIC=80,DIC(0)="AEMOQZ" D ^DIC K DIC Q:Y<1 S N=+Y,I(1)=$P(Y(0),U,1),I=$P(Y(0),U,3)
5 W ! D B^LRU Q:Y<0 S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99
6 S ZTRTN="QUE^LRSPSICD" D BEG^LRUTL Q:POP!($D(ZTSK))
7QUE U IO K ^TMP($J) D L^LRU,S^LRU,XR^LRU
8 S ^TMP($J,0)=I(1)_"^"_I_"^"_LRO(68)_"^"_"ICD9CM CODE"
9 F X=0:0 S LRSDT=$O(^LR(LRXR,LRSDT)) Q:'LRSDT!(LRSDT>LRLDT) D L
10 D ^LRSPSICP K ^TMP($J) D K^LRU,END^LRUTL Q
11L F LRDFN=0:0 S LRDFN=$O(^LR(LRXR,LRSDT,LRDFN)) Q:'LRDFN D I
12 Q
13I F LRI=0:0 S LRI=$O(^LR(LRXR,LRSDT,LRDFN,LRI)) Q:'LRI D TO
14 Q
15TO Q:$P($P($G(^LR(LRDFN,LRSS,LRI,0)),U,6)," ")'=LRABV Q:'$D(^(3,N,0))
16 S LREP=^LR(LRDFN,LRSS,LRI,0),H(2)=$E($P(LREP,"^",10),1,3)
17 S LRAC=$P(LREP,"^",6),LRAN=+$P(LRAC," ",3)
18PRT 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)"))
19 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
20 S:AGE>110!(AGE<10) AGE="?"
21 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)=""
22HERE Q
Note: See TracBrowser for help on using the repository browser.