- LRUSE ;AVAMC/REG - ENTER/EDIT SNOMED FIELDS ; 6/2/86 9:12 AM ;
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- OPTS R !!,"Select SNOMED FIELD to edit: ",X:DTIME Q:X=""!(X["^")
- F A=1:1 S Y=$P($T(OPT+A),";",3) Q:Y="" G:$E(X,1)=$P(Y,"^",2) DO
- W !!,"Select from:" G LST
- DO W " ",$E($P(Y,"^"),7,$L($P(Y,"^"))),! S DR=$P($T(OPT+A),"^",4),F=$P(Y,"^",3)
- ASK W ! S (DIC,DIE,DLAYGO)=F,DIC(0)="AEQLM" D ^DIC K DIC,DLAYGO G:Y<1 OPTS S DA=+Y D ^DIE G ASK
- LST W ! F A=1:1 W !,?15,$P($P($T(OPT+A),";",3),"^") Q:$T(OPT+A)=""
- G OPTS
- OPT ;OPTION LIST
- ;;T ==> Topography Field^T^61^.01;2;3;4;6
- ;;M ==> Morphology Field^M^61.1^.01;2;3;6
- ;;E ==> Etiology Field^E^61.2^.01;2;7;6
- ;;D ==> Disease Field^D^61.4^.01;2;3;6
- ;;F ==> Function Field^F^61.3^.01;2;3;6
- ;;P ==> Procedure Field^P^61.5^.01;2;3;6
- ;;O ==> Occupation Field^O^61.6^.01;2;3;6
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUSE 833 printed Feb 18, 2025@23:47:59 Page 2
- LRUSE ;AVAMC/REG - ENTER/EDIT SNOMED FIELDS ; 6/2/86 9:12 AM ;
- +1 ;;5.2;LAB SERVICE;;Sep 27, 1994
- OPTS READ !!,"Select SNOMED FIELD to edit: ",X:DTIME
- if X=""!(X["^")
- QUIT
- +1 FOR A=1:1
- SET Y=$PIECE($TEXT(OPT+A),";",3)
- if Y=""
- QUIT
- if $EXTRACT(X,1)=$PIECE(Y,"^",2)
- GOTO DO
- +2 WRITE !!,"Select from:"
- GOTO LST
- DO WRITE " ",$EXTRACT($PIECE(Y,"^"),7,$LENGTH($PIECE(Y,"^"))),!
- SET DR=$PIECE($TEXT(OPT+A),"^",4)
- SET F=$PIECE(Y,"^",3)
- ASK WRITE !
- SET (DIC,DIE,DLAYGO)=F
- SET DIC(0)="AEQLM"
- DO ^DIC
- KILL DIC,DLAYGO
- if Y<1
- GOTO OPTS
- SET DA=+Y
- DO ^DIE
- GOTO ASK
- LST WRITE !
- FOR A=1:1
- WRITE !,?15,$PIECE($PIECE($TEXT(OPT+A),";",3),"^")
- if $TEXT(OPT+A)=""
- QUIT
- +1 GOTO OPTS
- OPT ;OPTION LIST
- +1 ;;T ==> Topography Field^T^61^.01;2;3;4;6
- +2 ;;M ==> Morphology Field^M^61.1^.01;2;3;6
- +3 ;;E ==> Etiology Field^E^61.2^.01;2;7;6
- +4 ;;D ==> Disease Field^D^61.4^.01;2;3;6
- +5 ;;F ==> Function Field^F^61.3^.01;2;3;6
- +6 ;;P ==> Procedure Field^P^61.5^.01;2;3;6
- +7 ;;O ==> Occupation Field^O^61.6^.01;2;3;6