LRSPS.m

LRSPS ; IHS/DIR/FJE - CY/EM/SP PATH SEARCH LROPT SELECTOR ; 17-Oct-2014 09:22 ; MKK

 ;;5.2;LR;**1001,1034**;NOV 01, 1997;Build 88

 ;

 ;;5.2;LAB SERVICE;;Sep 27, 1994

 S IOP="HOME" D ^%ZIS,XR^LRU

OPTS W !!,"Select ",LRAA(1)," Search: " R X:DTIME Q:X=""!(X[U)

 ; F A=1:1 S Y=$P($T(OPT+A),";",3) Q:Y=""  G:$E(X,1)=$P(Y,U,2) DO

 F A=1:1 S Y=$P($T(OPT+A),";",3) Q:Y=""!(Y["$$END")  B:Y["$$END"  G:$E(X,1)=$P(Y,U,2) DO

 W !!,"Select from:" G LST

DO W " ",$E($P(Y,U,1),7,$L($P(Y,U,1))),! S LROPT=$P(Y,U,3,4) D @LROPT G OPTS

LST W ! F A=1:1 W !,?15,$P($P($T(OPT+A),";",3),U,1) Q:$T(OPT+A)=""

 G OPTS

M S S(7)="MORPHOLOGY",LRSN=61.1,V=2 D ^LRAPSM Q

D S S(7)="DISEASE",LRSN=61.4,V=1 D ^LRAPSM Q

F S S(7)="FUNCTION",LRSN=61.3,V=3 D ^LRAPSM Q

E S S(7)="ETIOLOGY",LRSN=61.2,V=2 D ^LRAPSM Q

P S S(7)="PROCEDURE",LRSN=61.5,V=4 D ^LRAPSM Q

 Q

 ;

 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034

 ;; Original I code follows:

 ;;I ==> ICD9CM code Search^I^^LRSPSICD

 ; The I code can't be 'commented out' below because of how

 ; the GOTO above works, so it's been rewritten below.

 ; ----- END IHS/MSC/MKK - LR*5.2*1034

 ;

OPT ;OPTION LIST

 ;;M ==> Morphology Code Search, SNOMED^M^M

 ;;D ==> Disease Code Search, SNOMED^D^D

 ;;F ==> Function Code Search, SNOMED^F^F

 ;;E ==> Etiology Code Search, SNOMED^E^E

 ;;P ==> Procedure Code Search, SNOMED^P^P

 ;;I ==> ICDCM code Search^I^^LRSPSICD

LRSPS     ; IHS/DIR/FJE - CY/EM/SP PATH SEARCH LROPT SELECTOR ; 17-Oct-2014 09:22 ; MKK

 +1       ;;5.2;LR;**1001,1034**;NOV 01, 1997;Build 88

 +2       ;

 +3       ;;5.2;LAB SERVICE;;Sep 27, 1994

 +4        SET IOP="HOME"

           DO ^%ZIS

           DO XR^LRU

OPTS       WRITE !!,"Select ",LRAA(1)," Search: "

           READ X:DTIME

           IF X=""!(X[U)

               QUIT 

 +1       ; F A=1:1 S Y=$P($T(OPT+A),";",3) Q:Y=""  G:$E(X,1)=$P(Y,U,2) DO

 +2        FOR A=1:1

               SET Y=$PIECE($TEXT(OPT+A),";",3)

               IF Y=""!(Y["$$END")

                   QUIT 

               IF Y["$$END"

                   BREAK 

               IF $EXTRACT(X,1)=$PIECE(Y,U,2)

                   GOTO DO

 +3        WRITE !!,"Select from:"

           GOTO LST

DO         WRITE " ",$EXTRACT($PIECE(Y,U,1),7,$LENGTH($PIECE(Y,U,1))),!

           SET LROPT=$PIECE(Y,U,3,4)

           DO @LROPT

           GOTO OPTS

LST        WRITE !

           FOR A=1:1

               WRITE !,?15,$PIECE($PIECE($TEXT(OPT+A),";",3),U,1)

               IF $TEXT(OPT+A)=""

                   QUIT 

 +1        GOTO OPTS

M          SET S(7)="MORPHOLOGY"

           SET LRSN=61.1

           SET V=2

           DO ^LRAPSM

           QUIT 

D          SET S(7)="DISEASE"

           SET LRSN=61.4

           SET V=1

           DO ^LRAPSM

           QUIT 

F          SET S(7)="FUNCTION"

           SET LRSN=61.3

           SET V=3

           DO ^LRAPSM

           QUIT 

E          SET S(7)="ETIOLOGY"

           SET LRSN=61.2

           SET V=2

           DO ^LRAPSM

           QUIT 

P          SET S(7)="PROCEDURE"

           SET LRSN=61.5

           SET V=4

           DO ^LRAPSM

           QUIT 

 +1        QUIT 

 +2       ;

 +3       ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034

 +4       ;; Original I code follows:

 +5       ;;I ==> ICD9CM code Search^I^^LRSPSICD

 +6       ; The I code can't be 'commented out' below because of how

 +7       ; the GOTO above works, so it's been rewritten below.

 +8       ; ----- END IHS/MSC/MKK - LR*5.2*1034

 +9       ;

OPT       ;OPTION LIST

 +1       ;;M ==> Morphology Code Search, SNOMED^M^M

 +2       ;;D ==> Disease Code Search, SNOMED^D^D

 +3       ;;F ==> Function Code Search, SNOMED^F^F

 +4       ;;E ==> Etiology Code Search, SNOMED^E^E

 +5       ;;P ==> Procedure Code Search, SNOMED^P^P

 +6       ;;I ==> ICDCM code Search^I^^LRSPSICD