ECXDSSD ;ALB/JAP - Derive DSS Department code ;July 16, 1998
;;3.0;DSS EXTRACTS;**8**;Dec 22, 1997
;
DERIVE(ECXSVC,ECXPUNIT,ECXDIV,ECXSUF) ;entry point for extrinsic function
; input
; ECXSVC = null or pointer to file #730; required
; ECXPUNIT = null or pointer to file #729; required
; ECXDIV = null or pointer to file #727.3; required
; ECXSUF = null or character string; optional
; output
; DSSDEPT = dss department code as ABBCxxx or null
; A=DSS CODE from file (#730)
; BB=DSS PRODUCTION UNIT CODE from file (#729)
; C=DSS DIVISION IDENTIFIER from file (#727.3)
; xxx=suffix of not more than three characters (optional)
;
N DSSDEPT
S DSSDEPT=""
Q:'$D(ECXSVC) DSSDEPT Q:'$D(ECXPUNIT) DSSDEPT Q:'$D(ECXDIV) DSSDEPT
D GETDIV(.ECXDIV)
I ECXDIV="" Q DSSDEPT
D GETSVC(.ECXSVC)
I ECXSVC="" Q DSSDEPT
D GETPUNIT(.ECXPUNIT)
I ECXPUNIT="" Q DSSDEPT
S DSSDEPT=ECXSVC_ECXPUNIT_ECXDIV
;if variable ecxsuf does not exist, then do nothing
;if variable ecxsuf is null, then assume user interaction for entry
;if variable suffix is a character string, then assume no user interaction; validate ecxsuf
I $D(ECXSUF) D
.D GETSUF(.ECXSUF)
.S DSSDEPT=DSSDEPT_ECXSUF
Q DSSDEPT
;
GETDIV(ECXDIV) ;get division portion of dss dept code
; input
; ECXDIV = pointer to file #40.8 or null; required; passed by reference
; output
; ECXDIV = dss division identifier or null
N ECX,USER,DIC,DR,DIQ,DA,X,Y,DTOUT,DUOUT,JJ,SS
S USER=0
I ECXDIV="" D Q:$D(DTOUT)!($D(DUOUT))!(+Y<1)
.W !!
.S USER=1
.S DIC(0)="AEMQZ",DIC="^ECX(727.3," D ^DIC
.S:+Y>0 ECXDIV=+Y Q
S DIC="^ECX(727.3,",DR="1;",DIQ(0)="E",DIQ="ECX",DA=ECXDIV
D EN^DIQ1
S ECXDIV=$G(ECX(727.3,ECXDIV,1,"E"))
I ECXDIV="",USER=1 D
.W !!,"The selected division does not yet have a"
.W !,"DSS Identifier code defined.",!
.W !,"Use the Enter/Edit DSS Division Identifier option"
.W !,"to associate a DSS identifier with this division.",!
.I $E(IOST)="C" D
..S SS=22-$Y F JJ=1:1:SS W !
..S DIR(0)="E" W ! D ^DIR K DIR W !
Q
;
GETSVC(ECXSVC) ;get service portion of dss dept code
; input
; ECXSVC = pointer to file #730 or null; required; passed by reference
; output
; ECXSVC = dss service code or null
N ECX,USER,DIC,DR,DIQ,X,Y,JJ,SS,DA,DTOUT,DUOUT
S USER=0
I ECXSVC="" D Q:$D(DTOUT)!($D(DUOUT))!(+Y<1)
.W !!
.S USER=1
.S DIC(0)="AEMQZ",DIC="^ECC(730," D ^DIC
.S:+Y>0 ECXSVC=+Y
S DIC="^ECC(730,",DR="3;",DIQ(0)="E",DIQ="ECX",DA=ECXSVC
D EN^DIQ1
S ECXSVC=$G(ECX(730,ECXSVC,3,"E"))
I ECXSVC="",USER=1 D
.W !!,"The selected National Service does not have a"
.W !,"DSS Clinical Service code defined.",!
.W !,"It cannot be used in a DSS Department code.",!
.I $E(IOST)="C" D
..S SS=22-$Y F JJ=1:1:SS W !
..S DIR(0)="E" W ! D ^DIR K DIR W !
Q
;
GETPUNIT(ECXPUNIT) ;get production unit portion of dss dept code
; input
; ECXPUNIT = pointer to file #729 or null; required; passed by reference
; output
; ECXPUNIT = dss production unit code or null
N ECX,DIC,DR,DIQ,X,Y,DTOUT,DUOUT,DA
I ECXPUNIT="" D Q:$D(DTOUT)!($D(DUOUT))!(+Y<1)
.W !!
.S DIC(0)="AEMQZ",DIC="^ECX(729," D ^DIC
.S:+Y>0 ECXPUNIT=+Y
S DIC="^ECX(729,",DR=".01;",DIQ(0)="E",DIQ="ECX",DA=ECXPUNIT
D EN^DIQ1
S ECXPUNIT=$G(ECX(729,ECXPUNIT,.01,"E"))
Q
;
GETSUF(ECXSUF) ;get suffix portion of dss dept code
; input
; ECXSUF = character string or null; required; passed by reference
; output
; ECXSUF = character string or null;
; input character string will be returned as null
N USER,AGAIN,LEN,ZERO,OUT,DIR,DIRUT,DTOUT,DUOUT,X,Y
;ask user for input only if ecxsuf="", otherwise assume no user interaction
;variable user acts as a flag --> if =1, then assume user interaction
S USER=0 S:ECXSUF="" USER=1,AGAIN=0
;variable again acts as a flag --> if =1, don't ask user if he wants to enter suffix
D SUF2
Q
SUF2 ;ask user for input if necessary, then validate variable ecxsuf
I USER=1 D
.I AGAIN=0 D Q:$D(DIRUT)!(Y=0)
..W !!
..S DIR(0)="YA",DIR("A")="Do you want to enter a suffix? ",DIR("B")="NO" K X,Y
..D ^DIR K DIR
.W !!
.S AGAIN=0
.S DIR(0)="FA^1:3",DIR("A")="Enter suffix: " K X,Y
.D ^DIR K DIR
.Q:$D(DIRUT) Q:(X="^")&(Y="^")
.S ECXSUF=Y,LEN=$L(ECXSUF)
.I ECXSUF["-" D
..I $L(ECXSUF)=1 W !!,"Invalid ...try again." S ECXSUF="",AGAIN=1 Q
..I $E(ECXSUF,1)'="-" D Q
...W !!,"The hyphen character < - > is only allowed as the"
...W !!,"1st character in the suffix.",!
...W !,"Try again...",!
...S ECXSUF="",AGAIN=1
..W !!,"The hyphen character < - > should not be used unless this"
..W !,"DSS Department code was previously established in DSS/Austin."
..W !
..S DIR(0)="YA",DIR("A")="Do you want to remove the hyphen? ",DIR("B")="YES" K X,Y
..D ^DIR K DIR
..S:($D(DIRUT))!(Y=1) ECXSUF="" S:(Y=1) AGAIN=1
.Q:AGAIN=1
.S ZERO=0
.F I=1:1:LEN S X=$E(ECXSUF,I) D Q:AGAIN=1
..Q:X="-"&(I=1)
..I X?1P D Q:AGAIN=1
...W !!,"There is an invalid punctuation character < "_X_" > in the suffix.",!
...W !,"Try again...",!
...S ECXSUF="",AGAIN=1
..I X?1L D Q:AGAIN=1
...W !!,"There is an invalid lowercase character < "_X_" > in the suffix.",!
...W !,"Try again...",!
...S ECXSUF="",AGAIN=1
..S:X="0" ZERO=ZERO+0 S:X'="0" ZERO=ZERO+1
.Q:AGAIN=1
.I ZERO=0 D
..W !!,"There are too many zeroes in the suffix.",!
..W !,"Try again...",!
..S ECXSUF="",AGAIN=1
I USER=1,AGAIN=1 G SUF2
;no user interaction; validate ecxsuf
I USER=0,ECXSUF]"" D
.S (ZERO,OUT)=0
.S LEN=$L(ECXSUF) I LEN>3 S ECXSUF="" Q
.F I=1:1:LEN S X=$E(ECXSUF,I) D Q:OUT=1
..I X="-",I'=1 S ECXSUF="",OUT=1
..I X?1P,X'="-" S ECXSUF="",OUT=1
..I X?1L S ECXSUF="",OUT=1
..S:X="0" ZERO=ZERO+0 S:X'="0" ZERO=ZERO+1
.I ZERO=0 S ECXSUF=""
Q
;
DECODE ;allow user to decode a dss department code
N CODE,DESC,OUT,DIR,DIRUT,DTOUT,DUOUT,X,Y
W !!,"You may enter a DSS Department as 'ABBC' (no suffix)."
W !,"The code will be 'translated' into a description and displayed.",!!
S OUT=0
F D Q:OUT=1 Q:$D(DIRUT)
.S DIR(0)="FA^4:4",DIR("A")="Enter a DSS Department code: " K X,Y
.D ^DIR K DIR
.Q:$D(DIRUT) Q:(X="^")&(Y="^")
.S CODE=Y D REVERSE(CODE,.DESC)
.W !
.W !?5,"Service ",?20,"<"_$E(CODE,1)_"> = "_$P(DESC,U,1)
.W !?5,"Prod. Unit ",?20,"<"_$E(CODE,2,3)_"> = "_$P(DESC,U,2)
.W !?5,"Division ",?20,"<"_$E(CODE,4)_"> = "_$P(DESC,U,3)
.W !
.S DIR(0)="YA",DIR("A")="Another one? ",DIR("B")="YES" K X,Y
.D ^DIR K DIR
.I Y=0 S OUT=1
Q
;
REVERSE(ECXDEPT,ECXDESC) ;get dss dept code description
; input
; ECXDEPT = dss dept code as ABBCxxx; required
; output
; ECXDESC = code description; passed by reference
; service_name^prod_unit_long_desc^division_name/station number
; note: if suffix (xxx) is present, it is ignored because free text
N SVC,PUNIT,DIV
Q:$L(ECXDEPT)<4
S SVC=$E(ECXDEPT,1),PUNIT=$E(ECXDEPT,2,3),DIV=$E(ECXDEPT,4)
K X,ECXERR S X=$$FIND1^DIC(730,,"X",SVC,"C",,"ECXERR")
S SVC=$S(X>0:$P(^ECC(730,X,0),U,1),X=0:"Not found",X="":"Error",1:"")
K X,ECXERR S X=$$FIND1^DIC(729,,"X",PUNIT,"B",,"ECXERR")
S PUNIT=$S(X>0:$P(^ECX(729,X,0),U,3),X=0:"Not found",X="":"Error",1:"")
K X,ECXERR S X=$$FIND1^DIC(727.3,,"X",DIV,"C",,"ECXERR")
S DIV=$S(X>0:$P(^DG(40.8,X,0),U,1)_"/"_$P(^(0),U,2),X=0:"Not found",X="":"Error",1:"")
S ECXDESC=SVC_U_PUNIT_U_DIV
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXDSSD 7441 printed Apr 09, 2024@20:57:45 Page 2
ECXDSSD ;ALB/JAP - Derive DSS Department code ;July 16, 1998
+1 ;;3.0;DSS EXTRACTS;**8**;Dec 22, 1997
+2 ;
DERIVE(ECXSVC,ECXPUNIT,ECXDIV,ECXSUF) ;entry point for extrinsic function
+1 ; input
+2 ; ECXSVC = null or pointer to file #730; required
+3 ; ECXPUNIT = null or pointer to file #729; required
+4 ; ECXDIV = null or pointer to file #727.3; required
+5 ; ECXSUF = null or character string; optional
+6 ; output
+7 ; DSSDEPT = dss department code as ABBCxxx or null
+8 ; A=DSS CODE from file (#730)
+9 ; BB=DSS PRODUCTION UNIT CODE from file (#729)
+10 ; C=DSS DIVISION IDENTIFIER from file (#727.3)
+11 ; xxx=suffix of not more than three characters (optional)
+12 ;
+13 NEW DSSDEPT
+14 SET DSSDEPT=""
+15 if '$DATA(ECXSVC)
QUIT DSSDEPT
if '$DATA(ECXPUNIT)
QUIT DSSDEPT
if '$DATA(ECXDIV)
QUIT DSSDEPT
+16 DO GETDIV(.ECXDIV)
+17 IF ECXDIV=""
QUIT DSSDEPT
+18 DO GETSVC(.ECXSVC)
+19 IF ECXSVC=""
QUIT DSSDEPT
+20 DO GETPUNIT(.ECXPUNIT)
+21 IF ECXPUNIT=""
QUIT DSSDEPT
+22 SET DSSDEPT=ECXSVC_ECXPUNIT_ECXDIV
+23 ;if variable ecxsuf does not exist, then do nothing
+24 ;if variable ecxsuf is null, then assume user interaction for entry
+25 ;if variable suffix is a character string, then assume no user interaction; validate ecxsuf
+26 IF $DATA(ECXSUF)
Begin DoDot:1
+27 DO GETSUF(.ECXSUF)
+28 SET DSSDEPT=DSSDEPT_ECXSUF
End DoDot:1
+29 QUIT DSSDEPT
+30 ;
GETDIV(ECXDIV) ;get division portion of dss dept code
+1 ; input
+2 ; ECXDIV = pointer to file #40.8 or null; required; passed by reference
+3 ; output
+4 ; ECXDIV = dss division identifier or null
+5 NEW ECX,USER,DIC,DR,DIQ,DA,X,Y,DTOUT,DUOUT,JJ,SS
+6 SET USER=0
+7 IF ECXDIV=""
Begin DoDot:1
+8 WRITE !!
+9 SET USER=1
+10 SET DIC(0)="AEMQZ"
SET DIC="^ECX(727.3,"
DO ^DIC
+11 if +Y>0
SET ECXDIV=+Y
QUIT
End DoDot:1
if $DATA(DTOUT)!($DATA(DUOUT))!(+Y<1)
QUIT
+12 SET DIC="^ECX(727.3,"
SET DR="1;"
SET DIQ(0)="E"
SET DIQ="ECX"
SET DA=ECXDIV
+13 DO EN^DIQ1
+14 SET ECXDIV=$GET(ECX(727.3,ECXDIV,1,"E"))
+15 IF ECXDIV=""
IF USER=1
Begin DoDot:1
+16 WRITE !!,"The selected division does not yet have a"
+17 WRITE !,"DSS Identifier code defined.",!
+18 WRITE !,"Use the Enter/Edit DSS Division Identifier option"
+19 WRITE !,"to associate a DSS identifier with this division.",!
+20 IF $EXTRACT(IOST)="C"
Begin DoDot:2
+21 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+22 SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
WRITE !
End DoDot:2
End DoDot:1
+23 QUIT
+24 ;
GETSVC(ECXSVC) ;get service portion of dss dept code
+1 ; input
+2 ; ECXSVC = pointer to file #730 or null; required; passed by reference
+3 ; output
+4 ; ECXSVC = dss service code or null
+5 NEW ECX,USER,DIC,DR,DIQ,X,Y,JJ,SS,DA,DTOUT,DUOUT
+6 SET USER=0
+7 IF ECXSVC=""
Begin DoDot:1
+8 WRITE !!
+9 SET USER=1
+10 SET DIC(0)="AEMQZ"
SET DIC="^ECC(730,"
DO ^DIC
+11 if +Y>0
SET ECXSVC=+Y
End DoDot:1
if $DATA(DTOUT)!($DATA(DUOUT))!(+Y<1)
QUIT
+12 SET DIC="^ECC(730,"
SET DR="3;"
SET DIQ(0)="E"
SET DIQ="ECX"
SET DA=ECXSVC
+13 DO EN^DIQ1
+14 SET ECXSVC=$GET(ECX(730,ECXSVC,3,"E"))
+15 IF ECXSVC=""
IF USER=1
Begin DoDot:1
+16 WRITE !!,"The selected National Service does not have a"
+17 WRITE !,"DSS Clinical Service code defined.",!
+18 WRITE !,"It cannot be used in a DSS Department code.",!
+19 IF $EXTRACT(IOST)="C"
Begin DoDot:2
+20 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+21 SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
WRITE !
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
GETPUNIT(ECXPUNIT) ;get production unit portion of dss dept code
+1 ; input
+2 ; ECXPUNIT = pointer to file #729 or null; required; passed by reference
+3 ; output
+4 ; ECXPUNIT = dss production unit code or null
+5 NEW ECX,DIC,DR,DIQ,X,Y,DTOUT,DUOUT,DA
+6 IF ECXPUNIT=""
Begin DoDot:1
+7 WRITE !!
+8 SET DIC(0)="AEMQZ"
SET DIC="^ECX(729,"
DO ^DIC
+9 if +Y>0
SET ECXPUNIT=+Y
End DoDot:1
if $DATA(DTOUT)!($DATA(DUOUT))!(+Y<1)
QUIT
+10 SET DIC="^ECX(729,"
SET DR=".01;"
SET DIQ(0)="E"
SET DIQ="ECX"
SET DA=ECXPUNIT
+11 DO EN^DIQ1
+12 SET ECXPUNIT=$GET(ECX(729,ECXPUNIT,.01,"E"))
+13 QUIT
+14 ;
GETSUF(ECXSUF) ;get suffix portion of dss dept code
+1 ; input
+2 ; ECXSUF = character string or null; required; passed by reference
+3 ; output
+4 ; ECXSUF = character string or null;
+5 ; input character string will be returned as null
+6 NEW USER,AGAIN,LEN,ZERO,OUT,DIR,DIRUT,DTOUT,DUOUT,X,Y
+7 ;ask user for input only if ecxsuf="", otherwise assume no user interaction
+8 ;variable user acts as a flag --> if =1, then assume user interaction
+9 SET USER=0
if ECXSUF=""
SET USER=1
SET AGAIN=0
+10 ;variable again acts as a flag --> if =1, don't ask user if he wants to enter suffix
+11 DO SUF2
+12 QUIT
SUF2 ;ask user for input if necessary, then validate variable ecxsuf
+1 IF USER=1
Begin DoDot:1
+2 IF AGAIN=0
Begin DoDot:2
+3 WRITE !!
+4 SET DIR(0)="YA"
SET DIR("A")="Do you want to enter a suffix? "
SET DIR("B")="NO"
KILL X,Y
+5 DO ^DIR
KILL DIR
End DoDot:2
if $DATA(DIRUT)!(Y=0)
QUIT
+6 WRITE !!
+7 SET AGAIN=0
+8 SET DIR(0)="FA^1:3"
SET DIR("A")="Enter suffix: "
KILL X,Y
+9 DO ^DIR
KILL DIR
+10 if $DATA(DIRUT)
QUIT
if (X="^")&(Y="^")
QUIT
+11 SET ECXSUF=Y
SET LEN=$LENGTH(ECXSUF)
+12 IF ECXSUF["-"
Begin DoDot:2
+13 IF $LENGTH(ECXSUF)=1
WRITE !!,"Invalid ...try again."
SET ECXSUF=""
SET AGAIN=1
QUIT
+14 IF $EXTRACT(ECXSUF,1)'="-"
Begin DoDot:3
+15 WRITE !!,"The hyphen character < - > is only allowed as the"
+16 WRITE !!,"1st character in the suffix.",!
+17 WRITE !,"Try again...",!
+18 SET ECXSUF=""
SET AGAIN=1
End DoDot:3
QUIT
+19 WRITE !!,"The hyphen character < - > should not be used unless this"
+20 WRITE !,"DSS Department code was previously established in DSS/Austin."
+21 WRITE !
+22 SET DIR(0)="YA"
SET DIR("A")="Do you want to remove the hyphen? "
SET DIR("B")="YES"
KILL X,Y
+23 DO ^DIR
KILL DIR
+24 if ($DATA(DIRUT))!(Y=1)
SET ECXSUF=""
if (Y=1)
SET AGAIN=1
End DoDot:2
+25 if AGAIN=1
QUIT
+26 SET ZERO=0
+27 FOR I=1:1:LEN
SET X=$EXTRACT(ECXSUF,I)
Begin DoDot:2
+28 if X="-"&(I=1)
QUIT
+29 IF X?1P
Begin DoDot:3
+30 WRITE !!,"There is an invalid punctuation character < "_X_" > in the suffix.",!
+31 WRITE !,"Try again...",!
+32 SET ECXSUF=""
SET AGAIN=1
End DoDot:3
if AGAIN=1
QUIT
+33 IF X?1L
Begin DoDot:3
+34 WRITE !!,"There is an invalid lowercase character < "_X_" > in the suffix.",!
+35 WRITE !,"Try again...",!
+36 SET ECXSUF=""
SET AGAIN=1
End DoDot:3
if AGAIN=1
QUIT
+37 if X="0"
SET ZERO=ZERO+0
if X'="0"
SET ZERO=ZERO+1
End DoDot:2
if AGAIN=1
QUIT
+38 if AGAIN=1
QUIT
+39 IF ZERO=0
Begin DoDot:2
+40 WRITE !!,"There are too many zeroes in the suffix.",!
+41 WRITE !,"Try again...",!
+42 SET ECXSUF=""
SET AGAIN=1
End DoDot:2
End DoDot:1
+43 IF USER=1
IF AGAIN=1
GOTO SUF2
+44 ;no user interaction; validate ecxsuf
+45 IF USER=0
IF ECXSUF]""
Begin DoDot:1
+46 SET (ZERO,OUT)=0
+47 SET LEN=$LENGTH(ECXSUF)
IF LEN>3
SET ECXSUF=""
QUIT
+48 FOR I=1:1:LEN
SET X=$EXTRACT(ECXSUF,I)
Begin DoDot:2
+49 IF X="-"
IF I'=1
SET ECXSUF=""
SET OUT=1
+50 IF X?1P
IF X'="-"
SET ECXSUF=""
SET OUT=1
+51 IF X?1L
SET ECXSUF=""
SET OUT=1
+52 if X="0"
SET ZERO=ZERO+0
if X'="0"
SET ZERO=ZERO+1
End DoDot:2
if OUT=1
QUIT
+53 IF ZERO=0
SET ECXSUF=""
End DoDot:1
+54 QUIT
+55 ;
DECODE ;allow user to decode a dss department code
+1 NEW CODE,DESC,OUT,DIR,DIRUT,DTOUT,DUOUT,X,Y
+2 WRITE !!,"You may enter a DSS Department as 'ABBC' (no suffix)."
+3 WRITE !,"The code will be 'translated' into a description and displayed.",!!
+4 SET OUT=0
+5 FOR
Begin DoDot:1
+6 SET DIR(0)="FA^4:4"
SET DIR("A")="Enter a DSS Department code: "
KILL X,Y
+7 DO ^DIR
KILL DIR
+8 if $DATA(DIRUT)
QUIT
if (X="^")&(Y="^")
QUIT
+9 SET CODE=Y
DO REVERSE(CODE,.DESC)
+10 WRITE !
+11 WRITE !?5,"Service ",?20,"<"_$EXTRACT(CODE,1)_"> = "_$PIECE(DESC,U,1)
+12 WRITE !?5,"Prod. Unit ",?20,"<"_$EXTRACT(CODE,2,3)_"> = "_$PIECE(DESC,U,2)
+13 WRITE !?5,"Division ",?20,"<"_$EXTRACT(CODE,4)_"> = "_$PIECE(DESC,U,3)
+14 WRITE !
+15 SET DIR(0)="YA"
SET DIR("A")="Another one? "
SET DIR("B")="YES"
KILL X,Y
+16 DO ^DIR
KILL DIR
+17 IF Y=0
SET OUT=1
End DoDot:1
if OUT=1
QUIT
if $DATA(DIRUT)
QUIT
+18 QUIT
+19 ;
REVERSE(ECXDEPT,ECXDESC) ;get dss dept code description
+1 ; input
+2 ; ECXDEPT = dss dept code as ABBCxxx; required
+3 ; output
+4 ; ECXDESC = code description; passed by reference
+5 ; service_name^prod_unit_long_desc^division_name/station number
+6 ; note: if suffix (xxx) is present, it is ignored because free text
+7 NEW SVC,PUNIT,DIV
+8 if $LENGTH(ECXDEPT)<4
QUIT
+9 SET SVC=$EXTRACT(ECXDEPT,1)
SET PUNIT=$EXTRACT(ECXDEPT,2,3)
SET DIV=$EXTRACT(ECXDEPT,4)
+10 KILL X,ECXERR
SET X=$$FIND1^DIC(730,,"X",SVC,"C",,"ECXERR")
+11 SET SVC=$SELECT(X>0:$PIECE(^ECC(730,X,0),U,1),X=0:"Not found",X="":"Error",1:"")
+12 KILL X,ECXERR
SET X=$$FIND1^DIC(729,,"X",PUNIT,"B",,"ECXERR")
+13 SET PUNIT=$SELECT(X>0:$PIECE(^ECX(729,X,0),U,3),X=0:"Not found",X="":"Error",1:"")
+14 KILL X,ECXERR
SET X=$$FIND1^DIC(727.3,,"X",DIV,"C",,"ECXERR")
+15 SET DIV=$SELECT(X>0:$PIECE(^DG(40.8,X,0),U,1)_"/"_$PIECE(^(0),U,2),X=0:"Not found",X="":"Error",1:"")
+16 SET ECXDESC=SVC_U_PUNIT_U_DIV
+17 QUIT
