SRTPTM1 ;BIR/SJA - TRANSPLANT TRANSMISSION ;07/22/2011
;;3.0;Surgery;**167,175,176**;24 Jun 93;Build 8
;
N SRDTH,SRPID
F I=0,.01,.02,.1,.11,.5,.55,1,3,10,11,"RA" S SRA(I)=$G(^SRT(SRTPP,I))
S DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANAME=VADM(1),SEX=$P(VADM(5),"^"),Z=$P(VADM(3),"^"),SRSDATE=$E($P(SRA(0),"^",2),1,12),Y=$E(SRSDATE,1,7),AGE=$E(Y,1,3)-$E(Z,1,3)-($E(Y,4,7)<$E(Z,4,7))
S SRPID=VA("PID"),SRPID=$TR(SRPID,"-","") ; remove hyphens from PID
S SRDIV=$P($G(^SRT(SRTPP,8)),"^"),SRDIV=$S(SRDIV:$$GET1^DIQ(4,SRDIV,99),1:SRASITE)
S SRCASE=$P(SRA(0),"^",3),SRTYPE=$P(SRA("RA"),"^",2),SRNOVA=$P(SRA("RA"),"^",5)
LN1 S SRSHEMP="$"_$J(SRASITE,3)_$J(SRTPP,7)_" 1"_DT_$J(AGE,3)_$J(SEX,1)_$J(SRSDATE,7)_$J(SRPID,20)_$J(SRDIV,6)_$J(SRCASE,10)
S SRSHEMP=SRSHEMP_$J(SRTYPE,2)_$J(SRNOVA,1)_$J($P(SRA(.01),"^",11),6)
S TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRSHEMP
LN2 S SRSHEMP=$E(SRSHEMP,1,11)_" 2",SRACNT=SRACNT+1
S SRHD=$P(SRA(0),"^",4) I SRHD["C" S SRH="C",SRHD=$E(SRHD,1,$L(SRHD)-1)
E S SRH=" "
S SRWD=$P(SRA(0),"^",5) I SRWD["K" S SRW="K",SRWD=$E(SRWD,1,$L(SRWD)-1)
E S SRW=" "
S SRSHEMP=SRSHEMP_$J(SRHD,3)_SRH_$J(SRWD,3)_SRW
S SRSHEMP=SRSHEMP_$J($P(SRA(0),"^",9),1)_$J($P(SRA(0),"^",10),2)_$J($P(SRA(0),"^",12),1)
S SRSHEMP=SRSHEMP_$J($P(SRA(0),"^",13),19)_$J($P(SRA(0),"^",14),19)
S SRSHEMP=SRSHEMP_$J($P(VADM(3),"^"),7)
S TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRSHEMP
LN3 S SRSHEMP=$E(SRSHEMP,1,11)_" 3",SRACNT=SRACNT+1
S SRSDATE=$P(SRA(0),"^",11) S SRSHEMP=SRSHEMP_$J(SRSDATE,7)_$J($P(SRA(0),"^",19),3)_$J($P(SRA(0),"^",20),3)
S SRSHEMP=SRSHEMP_$J($P(SRA(0),"^",21),2)_$J($P(SRA(0),"^",22),2)_$J($P(SRA(0),"^",23),2)_$J($P(SRA(.01),"^",10),2)
S SRSHEMP=SRSHEMP_$J($P(SRA(.01),"^",9),2)_$J($P(SRA(0),"^",8),2)
S SRSDATE=$P(SRA(.01),"^") S SRSHEMP=SRSHEMP_$J(SRSDATE,7)_$J($P(SRA(.01),"^",2),1)_$J($P(SRA(.01),"^",3),2)_$J($P(SRA(.01),"^",4),2)
S SRSHEMP=SRSHEMP_$J($P(SRA(.01),"^",5),3)_$J($P(SRA(.01),"^",6),3)_$J($P(SRA(.01),"^",7),5)_$J($P(SRA(.01),"^",8),5)
F I=24:1:29 S SRSHEMP=SRSHEMP_$J($P(SRA(.55),"^",I),2)
S TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRSHEMP
LN4 S SRSHEMP=$E(SRSHEMP,1,11)_" 4",SRACNT=SRACNT+1
S SRSHEMP=SRSHEMP_$J($P(SRA(0),"^",6),3)_$J($P(SRA(0),"^",7),3)
F I=1:1:11,13:1:24,26,27 S SRSHEMP=SRSHEMP_$J($P(SRA(.1),"^",I),1)
F I=1:1:14,16:1:23 S SRSHEMP=SRSHEMP_$J($P(SRA(.11),"^",I),1)
S SRSHEMP=SRSHEMP_$J($P(SRA(.1),"^",12),1)
S TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRSHEMP
LN5 S SRSHEMP=$E(SRSHEMP,1,11)_" 5",SRACNT=SRACNT+1
S SRSHEMP=SRSHEMP_$J($P(SRA(.1),"^",25),50) F I=1:1:9 S SRSHEMP=SRSHEMP_$J($P(SRA(.5),"^",I),1)
S SRSHEMP=SRSHEMP_$J($P(SRA(.5),"^",10),2) F I=11:1:13 S SRSHEMP=SRSHEMP_$J($P(SRA(.5),"^",I),1)
S TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRSHEMP
LN6 S SRSHEMP=$E(SRSHEMP,1,11)_" 6",SRACNT=SRACNT+1
F I=14:1:22 S SRSHEMP=SRSHEMP_$J($P(SRA(.5),"^",I),1)
S SRSHEMP=SRSHEMP_$J($P(SRA(.5),"^",23),2)_$J($P(SRA(.5),"^",25),1)
F I=1:1:5 S NYUK=$P(SRA(.55),"^",I) D ONE S SRSHEMP=SRSHEMP_$J(MOE,1)
S SRSHEMP=SRSHEMP_$J($P(SRA(.55),"^",6),2)
F I=7:1:12 S SRSHEMP=SRSHEMP_$J($P(SRA(.55),"^",I),1)
S SRSHEMP=SRSHEMP_$J($P(SRA(.55),"^",13),4)_$J($P(SRA(.55),"^",14),3)_$J($P(SRA(.55),"^",15),1)
S SRSHEMP=SRSHEMP_$J($P(SRA(.55),"^",16),1)_$J($P(SRA(.55),"^",17),2)
F I=18:1:23 S SRSHEMP=SRSHEMP_$J($P(SRA(.55),"^",I),1)
S SRHD=$P(SRA(1),"^",2) I SRHD["C" S SRH="C",SRHD=$E(SRHD,1,$L(SRHD)-1)
E S SRH=" "
S SRWD=$P(SRA(1),"^",3) I SRWD["K" S SRW="K",SRWD=$E(SRWD,1,$L(SRWD)-1)
E S SRW=" "
S SRSHEMP=SRSHEMP_$J(SRHD,3)_SRH_$J(SRWD,3)_SRW
S SRSHEMP=SRSHEMP_$J($P(SRA(1),"^",5),1)_$J($P(SRA(1),"^",6),3)_$J($P(SRA(1),"^",8),2)_$J($P(SRA(1),"^",9),1)
S TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRSHEMP
LN7 S SRSHEMP=$E(SRSHEMP,1,11)_" 7",SRACNT=SRACNT+1
F I=10:1:12 S SRSHEMP=SRSHEMP_$J($P(SRA(1),"^",I),19)
S TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRSHEMP
LN8 S SRSHEMP=$E(SRSHEMP,1,11)_" 8",SRACNT=SRACNT+1
S SRSHEMP=SRSHEMP_$J($P(SRA(1),"^",14),19)_$J($P(SRA(1),"^",15),19)
S NYUK=$P(SRA(1),"^",4) D ONE S SRSHEMP=SRSHEMP_MOE
;Multiple races for donor
S SRORCE=0,SRORAC="",SRORACE="",SRORCD=""
F S SRORCE=$O(^SRT(SRTPP,44,SRORCE)) Q:'SRORCE D
.S SRORAC=$G(^SRT(SRTPP,44,SRORCE,0))
.S SRORACE=SRORACE_$J(SRORAC,1)
S TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRSHEMP_SRORACE
LN9 S SRSHEMP=$E(SRSHEMP,1,11)_" 9",SRACNT=SRACNT+1
S SRSHEMP=SRSHEMP_$J($P(SRA(3),"^",4),4)_$J($P(SRA(3),"^",5),4)_$J($P(SRA(3),"^",6),4)_$J($P(SRA(3),"^",7),1)_$J($P(SRA(1),"^",1),7)
S NYUK=$J($P(SRA(3),"^"),1) D ONE S SRSHEMP=SRSHEMP_MOE S NYUK=$J($P(SRA(3),"^",2),1) D ONE S SRSHEMP=SRSHEMP_MOE
S NYUK=$P(SRA(3),"^",3) D ONE S SRSHEMP=SRSHEMP_MOE
F I=1:1:12 S SRSHEMP=SRSHEMP_$J($P(SRA(10),"^",I),1)
S SRSHEMP=SRSHEMP_$J($P(SRA(10),"^",13),7) F I=14:1:18 S SRSHEMP=SRSHEMP_$J($P(SRA(10),"^",I),1)
S SRSHEMP=SRSHEMP_$J($P(SRA(10),"^",19),12)
S TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRSHEMP
LN10 S SRSHEMP=$E(SRSHEMP,1,11)_" 10",SRACNT=SRACNT+1
F I=1:1:9 S NYUK=$P(SRA(11),"^",I) D ONE S SRSHEMP=SRSHEMP_$J(MOE,$S(I=2:3,I=3:3,I=5:4,I=6:4,I=7:4,1:1))
;Ethnicity contained in VADM(11)
N SROETCD,SROPTF S SROETCD="",SROPTF=""
S SROETCD=$P($G(VADM(11,1)),U,1) ;Ethnicity code
S SROPTF=$$PTR2CODE^DGUTL4(SROETCD,2,4) ;PTF Ethnicity code
S SRSHEMP=SRSHEMP_$J($G(SROPTF),1) ;Ethnicity
;Multiple races contained in VADM(12)
N SRORAC,SRORCD,SRORCE S SRORCE=0,SRORAC="",SRORACE="",SRORCD=""
F S SRORCE=$O(VADM(12,SRORCE)) Q:SRORCE="" D
.S SRORAC=$P($G(VADM(12,SRORCE)),U,1) ;Race code
.S SRORCD=$$PTR2CODE^DGUTL4(SRORAC,1,4) ;PTF race code
.S SRORACE=SRORACE_$J(SRORCD,1)
S TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRSHEMP_SRORACE
LN11 S SRSHEMP=$E(SRSHEMP,1,11)_" 11",SRACNT=SRACNT+1
F I=15:1:17 S SRSHEMP=SRSHEMP_$J($P(SRA(0),"^",I),19)
S TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRSHEMP
LN12 S SRSHEMP=$E(SRSHEMP,1,11)_" 12",SRACNT=SRACNT+1
; Transplant Comments field
S TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRSHEMP_$E($P(SRA(.02),"^"),1,66)
LN13 S SRSHEMP=$E(SRSHEMP,1,11)_" 13",SRACNT=SRACNT+1
S TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRSHEMP_$E($P(SRA(.02),"^"),67,130)
D ^SRTPTM2
Q
ONE S MOE=$S(NYUK="NS":"S",NYUK="":" ",1:NYUK)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSRTPTM1 6165 printed Dec 13, 2024@02:48:55 Page 2
SRTPTM1 ;BIR/SJA - TRANSPLANT TRANSMISSION ;07/22/2011
+1 ;;3.0;Surgery;**167,175,176**;24 Jun 93;Build 8
+2 ;
+3 NEW SRDTH,SRPID
+4 FOR I=0,.01,.02,.1,.11,.5,.55,1,3,10,11,"RA"
SET SRA(I)=$GET(^SRT(SRTPP,I))
+5 SET DFN=$PIECE(SRA(0),"^")
NEW I
DO DEM^VADPT
SET SRANAME=VADM(1)
SET SEX=$PIECE(VADM(5),"^")
SET Z=$PIECE(VADM(3),"^")
SET SRSDATE=$EXTRACT($PIECE(SRA(0),"^",2),1,12)
SET Y=$EXTRACT(SRSDATE,1,7)
SET AGE=$EXTRACT(Y,1,3)-$EXTRACT(Z,1,3)-($EXTRACT(Y,4,7)<$EXTRACT(Z,4,7))
+6 ; remove hyphens from PID
SET SRPID=VA("PID")
SET SRPID=$TRANSLATE(SRPID,"-","")
+7 SET SRDIV=$PIECE($GET(^SRT(SRTPP,8)),"^")
SET SRDIV=$SELECT(SRDIV:$$GET1^DIQ(4,SRDIV,99),1:SRASITE)
+8 SET SRCASE=$PIECE(SRA(0),"^",3)
SET SRTYPE=$PIECE(SRA("RA"),"^",2)
SET SRNOVA=$PIECE(SRA("RA"),"^",5)
LN1 SET SRSHEMP="$"_$JUSTIFY(SRASITE,3)_$JUSTIFY(SRTPP,7)_" 1"_DT_$JUSTIFY(AGE,3)_$JUSTIFY(SEX,1)_$JUSTIFY(SRSDATE,7)_$JUSTIFY(SRPID,20)_$JUSTIFY(SRDIV,6)_$JUSTIFY(SRCASE,10)
+1 SET SRSHEMP=SRSHEMP_$JUSTIFY(SRTYPE,2)_$JUSTIFY(SRNOVA,1)_$JUSTIFY($PIECE(SRA(.01),"^",11),6)
+2 SET TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SRSHEMP
LN2 SET SRSHEMP=$EXTRACT(SRSHEMP,1,11)_" 2"
SET SRACNT=SRACNT+1
+1 SET SRHD=$PIECE(SRA(0),"^",4)
IF SRHD["C"
SET SRH="C"
SET SRHD=$EXTRACT(SRHD,1,$LENGTH(SRHD)-1)
+2 IF '$TEST
SET SRH=" "
+3 SET SRWD=$PIECE(SRA(0),"^",5)
IF SRWD["K"
SET SRW="K"
SET SRWD=$EXTRACT(SRWD,1,$LENGTH(SRWD)-1)
+4 IF '$TEST
SET SRW=" "
+5 SET SRSHEMP=SRSHEMP_$JUSTIFY(SRHD,3)_SRH_$JUSTIFY(SRWD,3)_SRW
+6 SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(0),"^",9),1)_$JUSTIFY($PIECE(SRA(0),"^",10),2)_$JUSTIFY($PIECE(SRA(0),"^",12),1)
+7 SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(0),"^",13),19)_$JUSTIFY($PIECE(SRA(0),"^",14),19)
+8 SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(VADM(3),"^"),7)
+9 SET TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SRSHEMP
LN3 SET SRSHEMP=$EXTRACT(SRSHEMP,1,11)_" 3"
SET SRACNT=SRACNT+1
+1 SET SRSDATE=$PIECE(SRA(0),"^",11)
SET SRSHEMP=SRSHEMP_$JUSTIFY(SRSDATE,7)_$JUSTIFY($PIECE(SRA(0),"^",19),3)_$JUSTIFY($PIECE(SRA(0),"^",20),3)
+2 SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(0),"^",21),2)_$JUSTIFY($PIECE(SRA(0),"^",22),2)_$JUSTIFY($PIECE(SRA(0),"^",23),2)_$JUSTIFY($PIECE(SRA(.01),"^",10),2)
+3 SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(.01),"^",9),2)_$JUSTIFY($PIECE(SRA(0),"^",8),2)
+4 SET SRSDATE=$PIECE(SRA(.01),"^")
SET SRSHEMP=SRSHEMP_$JUSTIFY(SRSDATE,7)_$JUSTIFY($PIECE(SRA(.01),"^",2),1)_$JUSTIFY($PIECE(SRA(.01),"^",3),2)_$JUSTIFY($PIECE(SRA(.01),"^",4),2)
+5 SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(.01),"^",5),3)_$JUSTIFY($PIECE(SRA(.01),"^",6),3)_$JUSTIFY($PIECE(SRA(.01),"^",7),5)_$JUSTIFY($PIECE(SRA(.01),"^",8),5)
+6 FOR I=24:1:29
SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(.55),"^",I),2)
+7 SET TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SRSHEMP
LN4 SET SRSHEMP=$EXTRACT(SRSHEMP,1,11)_" 4"
SET SRACNT=SRACNT+1
+1 SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(0),"^",6),3)_$JUSTIFY($PIECE(SRA(0),"^",7),3)
+2 FOR I=1:1:11,13:1:24,26,27
SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(.1),"^",I),1)
+3 FOR I=1:1:14,16:1:23
SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(.11),"^",I),1)
+4 SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(.1),"^",12),1)
+5 SET TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SRSHEMP
LN5 SET SRSHEMP=$EXTRACT(SRSHEMP,1,11)_" 5"
SET SRACNT=SRACNT+1
+1 SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(.1),"^",25),50)
FOR I=1:1:9
SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(.5),"^",I),1)
+2 SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(.5),"^",10),2)
FOR I=11:1:13
SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(.5),"^",I),1)
+3 SET TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SRSHEMP
LN6 SET SRSHEMP=$EXTRACT(SRSHEMP,1,11)_" 6"
SET SRACNT=SRACNT+1
+1 FOR I=14:1:22
SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(.5),"^",I),1)
+2 SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(.5),"^",23),2)_$JUSTIFY($PIECE(SRA(.5),"^",25),1)
+3 FOR I=1:1:5
SET NYUK=$PIECE(SRA(.55),"^",I)
DO ONE
SET SRSHEMP=SRSHEMP_$JUSTIFY(MOE,1)
+4 SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(.55),"^",6),2)
+5 FOR I=7:1:12
SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(.55),"^",I),1)
+6 SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(.55),"^",13),4)_$JUSTIFY($PIECE(SRA(.55),"^",14),3)_$JUSTIFY($PIECE(SRA(.55),"^",15),1)
+7 SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(.55),"^",16),1)_$JUSTIFY($PIECE(SRA(.55),"^",17),2)
+8 FOR I=18:1:23
SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(.55),"^",I),1)
+9 SET SRHD=$PIECE(SRA(1),"^",2)
IF SRHD["C"
SET SRH="C"
SET SRHD=$EXTRACT(SRHD,1,$LENGTH(SRHD)-1)
+10 IF '$TEST
SET SRH=" "
+11 SET SRWD=$PIECE(SRA(1),"^",3)
IF SRWD["K"
SET SRW="K"
SET SRWD=$EXTRACT(SRWD,1,$LENGTH(SRWD)-1)
+12 IF '$TEST
SET SRW=" "
+13 SET SRSHEMP=SRSHEMP_$JUSTIFY(SRHD,3)_SRH_$JUSTIFY(SRWD,3)_SRW
+14 SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(1),"^",5),1)_$JUSTIFY($PIECE(SRA(1),"^",6),3)_$JUSTIFY($PIECE(SRA(1),"^",8),2)_$JUSTIFY($PIECE(SRA(1),"^",9),1)
+15 SET TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SRSHEMP
LN7 SET SRSHEMP=$EXTRACT(SRSHEMP,1,11)_" 7"
SET SRACNT=SRACNT+1
+1 FOR I=10:1:12
SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(1),"^",I),19)
+2 SET TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SRSHEMP
LN8 SET SRSHEMP=$EXTRACT(SRSHEMP,1,11)_" 8"
SET SRACNT=SRACNT+1
+1 SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(1),"^",14),19)_$JUSTIFY($PIECE(SRA(1),"^",15),19)
+2 SET NYUK=$PIECE(SRA(1),"^",4)
DO ONE
SET SRSHEMP=SRSHEMP_MOE
+3 ;Multiple races for donor
+4 SET SRORCE=0
SET SRORAC=""
SET SRORACE=""
SET SRORCD=""
+5 FOR
SET SRORCE=$ORDER(^SRT(SRTPP,44,SRORCE))
if 'SRORCE
QUIT
Begin DoDot:1
+6 SET SRORAC=$GET(^SRT(SRTPP,44,SRORCE,0))
+7 SET SRORACE=SRORACE_$JUSTIFY(SRORAC,1)
End DoDot:1
+8 SET TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SRSHEMP_SRORACE
LN9 SET SRSHEMP=$EXTRACT(SRSHEMP,1,11)_" 9"
SET SRACNT=SRACNT+1
+1 SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(3),"^",4),4)_$JUSTIFY($PIECE(SRA(3),"^",5),4)_$JUSTIFY($PIECE(SRA(3),"^",6),4)_$JUSTIFY($PIECE(SRA(3),"^",7),1)_$JUSTIFY($PIECE(SRA(1),"^",1),7)
+2 SET NYUK=$JUSTIFY($PIECE(SRA(3),"^"),1)
DO ONE
SET SRSHEMP=SRSHEMP_MOE
SET NYUK=$JUSTIFY($PIECE(SRA(3),"^",2),1)
DO ONE
SET SRSHEMP=SRSHEMP_MOE
+3 SET NYUK=$PIECE(SRA(3),"^",3)
DO ONE
SET SRSHEMP=SRSHEMP_MOE
+4 FOR I=1:1:12
SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(10),"^",I),1)
+5 SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(10),"^",13),7)
FOR I=14:1:18
SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(10),"^",I),1)
+6 SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(10),"^",19),12)
+7 SET TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SRSHEMP
LN10 SET SRSHEMP=$EXTRACT(SRSHEMP,1,11)_" 10"
SET SRACNT=SRACNT+1
+1 FOR I=1:1:9
SET NYUK=$PIECE(SRA(11),"^",I)
DO ONE
SET SRSHEMP=SRSHEMP_$JUSTIFY(MOE,$SELECT(I=2:3,I=3:3,I=5:4,I=6:4,I=7:4,1:1))
+2 ;Ethnicity contained in VADM(11)
+3 NEW SROETCD,SROPTF
SET SROETCD=""
SET SROPTF=""
+4 ;Ethnicity code
SET SROETCD=$PIECE($GET(VADM(11,1)),U,1)
+5 ;PTF Ethnicity code
SET SROPTF=$$PTR2CODE^DGUTL4(SROETCD,2,4)
+6 ;Ethnicity
SET SRSHEMP=SRSHEMP_$JUSTIFY($GET(SROPTF),1)
+7 ;Multiple races contained in VADM(12)
+8 NEW SRORAC,SRORCD,SRORCE
SET SRORCE=0
SET SRORAC=""
SET SRORACE=""
SET SRORCD=""
+9 FOR
SET SRORCE=$ORDER(VADM(12,SRORCE))
if SRORCE=""
QUIT
Begin DoDot:1
+10 ;Race code
SET SRORAC=$PIECE($GET(VADM(12,SRORCE)),U,1)
+11 ;PTF race code
SET SRORCD=$$PTR2CODE^DGUTL4(SRORAC,1,4)
+12 SET SRORACE=SRORACE_$JUSTIFY(SRORCD,1)
End DoDot:1
+13 SET TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SRSHEMP_SRORACE
LN11 SET SRSHEMP=$EXTRACT(SRSHEMP,1,11)_" 11"
SET SRACNT=SRACNT+1
+1 FOR I=15:1:17
SET SRSHEMP=SRSHEMP_$JUSTIFY($PIECE(SRA(0),"^",I),19)
+2 SET TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SRSHEMP
LN12 SET SRSHEMP=$EXTRACT(SRSHEMP,1,11)_" 12"
SET SRACNT=SRACNT+1
+1 ; Transplant Comments field
+2 SET TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SRSHEMP_$EXTRACT($PIECE(SRA(.02),"^"),1,66)
LN13 SET SRSHEMP=$EXTRACT(SRSHEMP,1,11)_" 13"
SET SRACNT=SRACNT+1
+1 SET TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SRSHEMP_$EXTRACT($PIECE(SRA(.02),"^"),67,130)
+2 DO ^SRTPTM2
+3 QUIT
ONE SET MOE=$SELECT(NYUK="NS":"S",NYUK="":" ",1:NYUK)
+1 QUIT
