- 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 Mar 13, 2025@21:54:09 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
