SRORACE ;B'HAM ISC/ADM - PATIENT DEMOGRAPHIC INFO ; [ 04/05/04 9:47 AM ]
;;3.0; Surgery ;**125**;24 Jun 93
ENTH D DEM^VADPT
;Find patient's ethnicity and list it on the display
W !," Ethnicity:" D
.I $G(VADM(11)) W ?40,$P(VADM(11,1),U,2)
.I '$G(VADM(11)) W ?40,"UNANSWERED"
;
;Find all race entries and place into a string with commas inbetween
S SRORC=0,C=1,SRORACE="",SROLINE="",N=1,SROL=""
F S SRORC=$O(VADM(12,SRORC)) Q:SRORC="" Q:C=11 D
.I $G(VADM(12,SRORC)) S SRORACE(C)=$P(VADM(12,SRORC),U,2)
.I SROLINE'="" S SROLINE=SROLINE_", "_SRORACE(C)
.I SROLINE="" S SROLINE=SRORACE(C)
.S C=C+1
;
;Find total length of 'race' string and wrap the text if necessary
I $L(SROLINE)=40!$L(SROLINE)<40 S SROL(N)=SROLINE,SRNUM1=2
I $L(SROLINE)>40 D WRAP
;
W !," Race Category(ies):"
I $G(VADM(12)) F D=1:1:SRNUM1-1 D
.W:D=1 ?40,SROL(D)
.W:D'=1 !,?40,SROL(D)
;
I '$G(VADM(12)) W ?40,"UNANSWERED"
;
K SROL,SROLINE,SRORC,SRORACE,SROLN,SROLN1,SROWRAP,SRNUM1
Q
;
WRAP ;Wrap multiple race entries so that wrapped line
;does not break in the middle of a word
;
S SROLNGTH=$L(SROLINE),E=40,SROWRAP="",SROLN="",SROLN1="",SROL=""
F I=1:40:SROLNGTH S SROLN(I)=SROWRAP_$E(SROLINE,I,E) D
.F K=40:-1:1 I $E(SROLN(I),K)[" " D Q ;Break lines at space
..S SROLN1(I)=$E(SROLN(I),1,K-1)
..S SROWRAP=$E(SROLN(I),K+1,E)
.S E=E+40
;
S:'$D(SROLN1(I)) SROLN1(I)=SROLN(I),SROWRAP=""
I $L(SROLN1(I))+$L(SROWRAP)>39 S SROLN1(I+1)=SROWRAP ;Last line
I $L(SROLN1(I))+$L(SROWRAP)'>39 S SROLN1(I)=SROLN1(I)_" "_SROWRAP
;
;Renumber the SROLN1 array to be in numeric order
S SRNUM=0,SRNUM1=1
F S SRNUM=$O(SROLN1(SRNUM)) Q:SRNUM="" D
.S SROL(SRNUM1)=SROLN1(SRNUM)
.S SRNUM1=SRNUM1+1
Q
;
EXT I $L(SREXT)<40 W ?40,SREXT W:SRFLD=247 $S(SREXT="":"",SREXT=1:" Day",SREXT=0:" Days",SREXT>1:" Days",1:"") Q
N I,J,X,Y S X=SREXT F D W:$L(X) ! I $L(X)<40!(X'[" ") W ?40,X Q
.F I=0:1:38 S J=39-I,Y=$E(X,J) I Y=" " W ?40,$E(X,1,J-1) S X=$E(X,J+1,$L(X)) Q
Q
SRORACE ;B'HAM ISC/ADM - PATIENT DEMOGRAPHIC INFO ; [ 04/05/04 9:47 AM ]
+1 ;;3.0; Surgery ;**125**;24 Jun 93
ENTH DO DEM^VADPT
+1 ;Find patient's ethnicity and list it on the display
+2 WRITE !," Ethnicity:"
Begin DoDot:1
+3 IF $GET(VADM(11))
WRITE ?40,$PIECE(VADM(11,1),U,2)
+4 IF '$GET(VADM(11))
WRITE ?40,"UNANSWERED"
End DoDot:1
+5 ;
+6 ;Find all race entries and place into a string with commas inbetween
+7 SET SRORC=0
SET C=1
SET SRORACE=""
SET SROLINE=""
SET N=1
SET SROL=""
+8 FOR
SET SRORC=$ORDER(VADM(12,SRORC))
IF SRORC=""
QUIT
IF C=11
QUIT
Begin DoDot:1
+9 IF $GET(VADM(12,SRORC))
SET SRORACE(C)=$PIECE(VADM(12,SRORC),U,2)
+10 IF SROLINE'=""
SET SROLINE=SROLINE_", "_SRORACE(C)
+11 IF SROLINE=""
SET SROLINE=SRORACE(C)
+12 SET C=C+1
End DoDot:1
+13 ;
+14 ;Find total length of 'race' string and wrap the text if necessary
+15 IF $LENGTH(SROLINE)=40!$LENGTH(SROLINE)<40
SET SROL(N)=SROLINE
SET SRNUM1=2
+16 IF $LENGTH(SROLINE)>40
DO WRAP
+17 ;
+18 WRITE !," Race Category(ies):"
+19 IF $GET(VADM(12))
FOR D=1:1:SRNUM1-1
Begin DoDot:1
+20 IF D=1
WRITE ?40,SROL(D)
+21 IF D'=1
WRITE !,?40,SROL(D)
End DoDot:1
+22 ;
+23 IF '$GET(VADM(12))
WRITE ?40,"UNANSWERED"
+24 ;
+25 KILL SROL,SROLINE,SRORC,SRORACE,SROLN,SROLN1,SROWRAP,SRNUM1
+26 QUIT
+27 ;
WRAP ;Wrap multiple race entries so that wrapped line
+1 ;does not break in the middle of a word
+2 ;
+3 SET SROLNGTH=$LENGTH(SROLINE)
SET E=40
SET SROWRAP=""
SET SROLN=""
SET SROLN1=""
SET SROL=""
+4 FOR I=1:40:SROLNGTH
SET SROLN(I)=SROWRAP_$EXTRACT(SROLINE,I,E)
Begin DoDot:1
+5 ;Break lines at space
FOR K=40:-1:1
IF $EXTRACT(SROLN(I),K)[" "
Begin DoDot:2
+6 SET SROLN1(I)=$EXTRACT(SROLN(I),1,K-1)
+7 SET SROWRAP=$EXTRACT(SROLN(I),K+1,E)
End DoDot:2
QUIT
+8 SET E=E+40
End DoDot:1
+9 ;
+10 IF '$DATA(SROLN1(I))
SET SROLN1(I)=SROLN(I)
SET SROWRAP=""
+11 ;Last line
IF $LENGTH(SROLN1(I))+$LENGTH(SROWRAP)>39
SET SROLN1(I+1)=SROWRAP
+12 IF $LENGTH(SROLN1(I))+$LENGTH(SROWRAP)'>39
SET SROLN1(I)=SROLN1(I)_" "_SROWRAP
+13 ;
+14 ;Renumber the SROLN1 array to be in numeric order
+15 SET SRNUM=0
SET SRNUM1=1
+16 FOR
SET SRNUM=$ORDER(SROLN1(SRNUM))
IF SRNUM=""
QUIT
Begin DoDot:1
+17 SET SROL(SRNUM1)=SROLN1(SRNUM)
+18 SET SRNUM1=SRNUM1+1
End DoDot:1
+19 QUIT
+20 ;
EXT IF $LENGTH(SREXT)<40
WRITE ?40,SREXT
IF SRFLD=247
WRITE $SELECT(SREXT="":"",SREXT=1:" Day",SREXT=0:" Days",SREXT>1:" Days",1:"")
QUIT
+1 NEW I,J,X,Y
SET X=SREXT
FOR
Begin DoDot:1
+2 FOR I=0:1:38
SET J=39-I
SET Y=$EXTRACT(X,J)
IF Y=" "
WRITE ?40,$EXTRACT(X,1,J-1)
SET X=$EXTRACT(X,J+1,$LENGTH(X))
QUIT
End DoDot:1
IF $LENGTH(X)
WRITE !
IF $LENGTH(X)<40!(X'[" ")
WRITE ?40,X
QUIT
+3 QUIT
