- 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
