- SROATM3 ;BIR/MAM - NON CARDIAC TRANSMISSION (CONT) ;05/03/11
- ;;3.0;Surgery;**27,38,62,88,97,111,142,153,174,175,184,200,205**;24 Jun 93;Build 12
- ;** NOTICE: This routine is part of an implementation of a nationally
- ;** controlled procedure. Local modifications to this routine
- ;** are prohibited.
- ;;
- N SRCONMOD,SRMOD,SRPMOD,SR10SP
- S SHEMP=SHEMP_$J($P(SRA(201),"^",16),5)_$J($P(SRA(202),"^",16),7)_$J($P(SRA(201),"^",17),4)_$J($P(SRA(202),"^",17),7)_$J($P(SRA(203),"^"),5)_$J($P(SRA(204),"^"),7)_$J($P(SRA(203),"^",2),5)_$J($P(SRA(204),"^",2),7)
- S SHEMP=SHEMP_$J($P(SRA(203),"^",16),5)_$J($P(SRA(204),"^",16),7)
- S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_" 10",SRACNT=SRACNT+1
- S SHEMP=SHEMP_$J($P(SRA(203),"^",3),3)_$J($P(SRA(204),"^",3),7)_$J($P(SRA(203),"^",4),3)_$J($P(SRA(204),"^",4),7)_$J($P(SRA(203),"^",6),4)_$J($P(SRA(204),"^",6),7)
- N SROBOT S SROBOT=$P($G(^SRF(SRTN,"OP")),U,3),SHEMP=SHEMP_$J($P(SRA(203),"^",7),6)_$J($P(SRA(204),"^",7),7)_$J(SROBOT,2)
- S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_" 11",SRACNT=SRACNT+1
- S SHEMP=SHEMP_$J($P(SRA(203),"^",8),4)_$J($P(SRA(204),"^",8),7)_$J($P(SRA(203),"^",9),5)_$J($P(SRA(204),"^",9),7)_$J($P(SRA(203),"^",10),4)_$J($P(SRA(204),"^",10),7)
- S SHEMP=SHEMP_$J($P(SRA(203),"^",12),4)_$J($P(SRA(204),"^",12),7)_$J($P(SRA(203),"^",13),5)_$J($P(SRA(204),"^",13),7)_$J($P(SRA(203),"^",14),5)_$J($P(SRA(204),"^",14),7)
- S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_" 12",SRACNT=SRACNT+1
- S (SRPMOD,SRCONMOD)="",SR10SP=" " F I="OP","CON" S SRA(I)=$G(^SRF(SRTN,I))
- S CPT=$P($G(^SRO(136,SRTN,0)),"^",2) D
- .I SRA("CON"),$P($G(^SRF(SRA("CON"),30)),"^")!($P($G(^SRF(SRA("CON"),31)),"^",8)) S SRA("CON")=""
- .I CPT S CPT=$P($$CPT^ICPTCOD(CPT),"^",2),SRCASE=SRTN D MOD S SRPMOD=SRM
- .S SHEMP=SHEMP_$J(CPT,5),SRPMOD=SRPMOD_SR10SP
- S CPT="",CON=$P(SRA("CON"),"^") S:CON CPT=$P($G(^SRO(136,CON,0)),"^",2) D
- .I CPT S CPT=$P($$CPT^ICPTCOD(CPT),"^",2),SRCASE=CON D MOD S SRCONMOD=SRM
- .S SHEMP=SHEMP_$J(CPT,5),SRCONMOD=SRCONMOD_SR10SP
- S CPT="",SHEMP=SHEMP_$J(CPT,5)
- K CPT F I=1:1:10 S (CPT(I),SRMOD(I))=""
- S (OPS,CNT)=0 F S OPS=$O(^SRO(136,SRTN,3,OPS)) Q:'OPS!(CNT=10) S CNT=CNT+1,X=$P($G(^SRO(136,SRTN,3,OPS,0)),"^") I X S CPT(CNT)=$P($$CPT^ICPTCOD(X),"^",2) D OTH
- S SHEMP=SHEMP_$J(CPT(1),5)_$J(CPT(2),5)_$J(CPT(3),5)_$J(CPT(4),5)_$J(CPT(5),5)_$J(CPT(6),5)_$J(CPT(7),5)_$J(CPT(8),5)_$J(CPT(9),5)_$J(CPT(10),5)
- S SHEMP=SHEMP_$E(SRPMOD,1,10)_$E(SRCONMOD,1,10) F I=1:1:10 S SHEMP=SHEMP_$E(SRMOD(I)_SR10SP,1,10)
- S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
- ;
- ;Ethnicity contained in VADM(11)
- N SROETCD,SROPTF S SHEMP=$E(SHEMP,1,11)_" 13"
- 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 SHEMP=SHEMP_$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 SRORACE=SRORACE_" "
- S SHEMP=SHEMP_$E(SRORACE,1,10)
- ;get name of person who completed assessment
- N SRP S SRP=$P($G(^SRF(SRTN,"RA")),"^",9) I SRP S Y=SRP,C=$P(^DD(130,272.1,0),"^",2) D Y^DIQ S SRP=Y
- S X=$L(SRP)+1 F I=X:1:35 S SRP=SRP_" "
- S SRA(.9)=$G(^SRF(SRTN,.9)),SRA("VER")=$G(^SRF(SRTN,"VER"))
- S SHEMP=SHEMP_SRP_$J($P(SRA(.9),"^"),12)_$J($E($P(SRA(.9),"^",2),1,12),12)_$J($P(SRA(.9),"^",3),12)_$J($P(SRA(.9),"^",4),12)_$J($P(SRA(.9),"^",5),12)_$J($P(SRA(.9),"^",6),12) ;Line 13
- F I=7:1:18 S SHEMP=SHEMP_$J($P(SRA("VER"),"^",I),2)
- S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
- ;
- N II,OT,SRC,SRNM11,SRNM13,SRNM23,SRNM25
- S II=0,OT="" F S II=$O(^SRF(SRTN,63,"B",II)) Q:'II S OT=OT_II
- S SHEMP=$E(SHEMP,1,11)_" 14"_$J(OT,7)_$J($P(SRA("VER1"),"^",2),10)_$J($P(SRA("VER1"),"^",3),2)_$J($P(SRA("VER1"),"^",4),2)_$J($P(SRA("VER1"),"^",5),2)
- S SHEMP=SHEMP_$J($P(SRA("VER1"),"^",6),2)_$J($P(SRA("VER1"),"^",7),1)_$J($P(SRA("VER1"),"^",8),1)_$J($P(SRA("VER1"),"^",9),1)_$J($E($P(SRA("VER1"),"^",19),1,12),12)
- S SHEMP=SHEMP_$J($P(SRA("VER1"),"^",10),1)_$J($E($P(SRA("VER1"),"^",21),1,12),12)_$J($P(SRA("VER1"),"^",22),1)_$J($P(SRA("VER1"),"^",12),1)_$J($P(SRA("VER1"),"^",24),2)
- S SHEMP=SHEMP_$J($P(SRA("VER1"),"^",14),2)_$J($P(SRA("VER1"),"^",15),1)_$J($P(SRA("VER1"),"^",16),2)
- S (SRNM11,SRNM13,SRNM23,SRNM25)=""
- F II=11,23,13,25 I $P(SRA("VER1"),"^",II) S @("SRNM"_II)=$P($G(^VA(200,$P(SRA("VER1"),"^",II),0)),"^")
- S SHEMP=SHEMP_$J($E(SRNM11,1,30),30)_$J($E(SRNM23,1,30),30)
- S SHEMP=SHEMP_$J($E(SRNM13,1,30),30)_$J($E(SRNM25,1,30),30)
- K SRNM S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
- ;
- S II=0,(SRC,OT)="" F S SRC=$O(^SRF(SRTN,57,"B",SRC)) Q:SRC=""!(II=7) S OT=OT_$J($E(SRC,1,10),10),II=II+1
- S OT=$E(OT,1,70)_$J("",70-$L(OT)),SHEMP=$E(SHEMP,1,11)_" 15"_$J(OT,70)
- S OT="" F I=1:1:17,19:1:28 S OT=OT_$J($P(SRA(211),U,I),2)
- S SHEMP=SHEMP_OT
- S (SRC,OT)="" F S SRC=$O(^SRF(SRTN,64,"B",SRC)) Q:'SRC S OT=OT_$J(SRC,1)
- S SHEMP=SHEMP_$J(OT,6)_$J($P(SRA(211),U,30),2)_$J($P(SRA(211),U,31),5)_$J($P(SRA(211),U,32),5)_$J($P(SRA(211),U,35),5)
- S OT="",II=0 F II="34;4","39;4","33;3","36;3","40;3","37;2","38;2","41;2","42;2","43;2" S OT=OT_$J($P(SRA(211),U,+II),$P(II,";",2))
- S SHEMP=SHEMP_OT_$J($P(SRA("VERD"),U,6),4)_$J($P(SRA("VERD"),U,7),5)_$J($P(SRA("VERD"),U,8),4)
- S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
- ;
- S OT="" F II=2:1:4,7,10,11 S OT=OT_$J($P(SRA(210),U,II),2)
- S SHEMP=$E(SHEMP,1,11)_" 16"_OT
- S OT="" F II=44:1:53 S OT=OT_$J($P(SRA(211),U,II),2)
- S SHEMP=SHEMP_OT_$J($E($P(SRA(211),U,54),1,12),12)_$J($E($P(SRA(211),U,55),1,12),12)_$J($P(SRA(211),U,56),3)_$J($P(SRA(211),U,57),3)
- S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
- ;
- S SHEMP=$E(SHEMP,1,11)_" A1"
- S SHEMP=SHEMP_SRANAME,^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_" A2",SRACNT=SRACNT+1
- S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") K SRA,VADM D ADD^VADPT
- S SHEMP=SHEMP_VAPA(1),^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_" A3",SRACNT=SRACNT+1
- S SHEMP=SHEMP_VAPA(2),^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_" A4",SRACNT=SRACNT+1
- S SHEMP=SHEMP_VAPA(3),^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_" A5",SRACNT=SRACNT+1
- S SHEMP=SHEMP_VAPA(4),^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_" A6",SRACNT=SRACNT+1
- S SHEMP=SHEMP_$P(VAPA(5),"^",2),^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_" A7",SRACNT=SRACNT+1
- S SHEMP=SHEMP_VAPA(6),^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_" A8",SRACNT=SRACNT+1
- S SHEMP=SHEMP_VAPA(8),^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
- Q
- MOD ; get principal CPT modifiers
- S SRI=0,SRCNT=1,SRM="" F S SRI=$O(^SRO(136,SRCASE,1,SRI)) Q:'SRI D Q:SRCNT>5
- .S X=$P(^SRO(136,SRCASE,1,SRI,0),"^"),Y=$P($$MOD^ICPTMOD(X,"I"),"^",2)
- .I Y'="" S SRM=SRM_Y,SRCNT=SRCNT+1
- Q
- OTH ; get other procedure CPT modifiers
- S SRI=0,SRCNT=1 F S SRI=$O(^SRO(136,SRTN,3,OPS,1,SRI)) Q:'SRI D Q:SRCNT>5
- .S X=$P(^SRO(136,SRTN,3,OPS,1,SRI,0),"^"),Y=$P($$MOD^ICPTMOD(X,"I"),"^",2)
- .I Y'="" S SRMOD(CNT)=SRMOD(CNT)_Y,SRCNT=SRCNT+1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROATM3 7390 printed Feb 19, 2025@00:08:40 Page 2
- SROATM3 ;BIR/MAM - NON CARDIAC TRANSMISSION (CONT) ;05/03/11
- +1 ;;3.0;Surgery;**27,38,62,88,97,111,142,153,174,175,184,200,205**;24 Jun 93;Build 12
- +2 ;** NOTICE: This routine is part of an implementation of a nationally
- +3 ;** controlled procedure. Local modifications to this routine
- +4 ;** are prohibited.
- +5 ;;
- +6 NEW SRCONMOD,SRMOD,SRPMOD,SR10SP
- +7 SET SHEMP=SHEMP_$JUSTIFY($PIECE(SRA(201),"^",16),5)_$JUSTIFY($PIECE(SRA(202),"^",16),7)_$JUSTIFY($PIECE(SRA(201),"^",17),4)_$JUSTIFY(...
- ... $PIECE(SRA(202),"^",17),7)_$JUSTIFY($PIECE(SRA(203),"^"),5)_$JUSTIFY($PIECE(SRA(204),"^"),7)_$JUSTIFY($PIECE(SRA(203),"^",2),5)_$JUSTIFY($PIECE(SRA(204),"^",2),7)
- +8 SET SHEMP=SHEMP_$JUSTIFY($PIECE(SRA(203),"^",16),5)_$JUSTIFY($PIECE(SRA(204),"^",16),7)
- +9 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
- SET SHEMP=$EXTRACT(SHEMP,1,11)_" 10"
- SET SRACNT=SRACNT+1
- +10 SET SHEMP=SHEMP_$JUSTIFY($PIECE(SRA(203),"^",3),3)_$JUSTIFY($PIECE(SRA(204),"^",3),7)_$JUSTIFY($PIECE(SRA(203),"^",4),3)_$JUSTIFY($PIECE(SRA(204),"^",4),7)_$JUSTIFY($PIECE(SRA(203),"^",6),4)_$JUSTIFY($PIECE(SRA(204),"^",6),7)
- +11 NEW SROBOT
- SET SROBOT=$PIECE($GET(^SRF(SRTN,"OP")),U,3)
- SET SHEMP=SHEMP_$JUSTIFY($PIECE(SRA(203),"^",7),6)_$JUSTIFY($PIECE(SRA(204),"^",7),7)_$JUSTIFY(SROBOT,2)
- +12 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
- SET SHEMP=$EXTRACT(SHEMP,1,11)_" 11"
- SET SRACNT=SRACNT+1
- +13 SET SHEMP=SHEMP_$JUSTIFY($PIECE(SRA(203),"^",8),4)_$JUSTIFY($PIECE(SRA(204),"^",8),7)_$JUSTIFY($PIECE(SRA(203),"^",9),5)_$JUSTIFY($PIECE(SRA(204),"^",9),7)_$JUSTIFY($PIECE(SRA(203),"^",10),4)_$JUSTIFY($PIECE(SRA(204),"^",10),7)
- +14 SET SHEMP=SHEMP_$JUSTIFY($PIECE(SRA(203),"^",12),4)_$JUSTIFY($PIECE(SRA(204),"^",12),7)_$JUSTIFY($PIECE(SRA(203),"^",13),5)_$JUSTIFY($PIECE(SRA(204),"^",13),7)_$JUSTIFY($PIECE(SRA(203),"^",14),5)_$JUSTIFY($PIECE(SRA(204),"^",14),7)
- +15 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
- SET SHEMP=$EXTRACT(SHEMP,1,11)_" 12"
- SET SRACNT=SRACNT+1
- +16 SET (SRPMOD,SRCONMOD)=""
- SET SR10SP=" "
- FOR I="OP","CON"
- SET SRA(I)=$GET(^SRF(SRTN,I))
- +17 SET CPT=$PIECE($GET(^SRO(136,SRTN,0)),"^",2)
- Begin DoDot:1
- +18 IF SRA("CON")
- IF $PIECE($GET(^SRF(SRA("CON"),30)),"^")!($PIECE($GET(^SRF(SRA("CON"),31)),"^",8))
- SET SRA("CON")=""
- +19 IF CPT
- SET CPT=$PIECE($$CPT^ICPTCOD(CPT),"^",2)
- SET SRCASE=SRTN
- DO MOD
- SET SRPMOD=SRM
- +20 SET SHEMP=SHEMP_$JUSTIFY(CPT,5)
- SET SRPMOD=SRPMOD_SR10SP
- End DoDot:1
- +21 SET CPT=""
- SET CON=$PIECE(SRA("CON"),"^")
- if CON
- SET CPT=$PIECE($GET(^SRO(136,CON,0)),"^",2)
- Begin DoDot:1
- +22 IF CPT
- SET CPT=$PIECE($$CPT^ICPTCOD(CPT),"^",2)
- SET SRCASE=CON
- DO MOD
- SET SRCONMOD=SRM
- +23 SET SHEMP=SHEMP_$JUSTIFY(CPT,5)
- SET SRCONMOD=SRCONMOD_SR10SP
- End DoDot:1
- +24 SET CPT=""
- SET SHEMP=SHEMP_$JUSTIFY(CPT,5)
- +25 KILL CPT
- FOR I=1:1:10
- SET (CPT(I),SRMOD(I))=""
- +26 SET (OPS,CNT)=0
- FOR
- SET OPS=$ORDER(^SRO(136,SRTN,3,OPS))
- if 'OPS!(CNT=10)
- QUIT
- SET CNT=CNT+1
- SET X=$PIECE($GET(^SRO(136,SRTN,3,OPS,0)),"^")
- IF X
- SET CPT(CNT)=$PIECE($$CPT^ICPTCOD(X),"^",2)
- DO OTH
- +27 SET SHEMP=SHEMP_$JUSTIFY(CPT(1),5)_$JUSTIFY(CPT(2),5)_$JUSTIFY(CPT(3),5)_$JUSTIFY(CPT(4),5)_$JUSTIFY(CPT(5),5)_$JUSTIFY(CPT(6),5)_$JUSTIFY(CPT(7),5)_$JUSTIFY(CPT(8),5)_$JUSTIFY(CPT(9),5)_$JUSTIFY(CPT(10),5)
- +28 SET SHEMP=SHEMP_$EXTRACT(SRPMOD,1,10)_$EXTRACT(SRCONMOD,1,10)
- FOR I=1:1:10
- SET SHEMP=SHEMP_$EXTRACT(SRMOD(I)_SR10SP,1,10)
- +29 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
- SET SRACNT=SRACNT+1
- +30 ;
- +31 ;Ethnicity contained in VADM(11)
- +32 NEW SROETCD,SROPTF
- SET SHEMP=$EXTRACT(SHEMP,1,11)_" 13"
- +33 SET SROETCD=""
- SET SROPTF=""
- +34 ;Ethnicity code
- SET SROETCD=$PIECE($GET(VADM(11,1)),U,1)
- +35 ;PTF Ethnicity code
- SET SROPTF=$$PTR2CODE^DGUTL4(SROETCD,2,4)
- +36 ;Ethnicity
- SET SHEMP=SHEMP_$JUSTIFY($GET(SROPTF),1)
- +37 ;
- +38 ;Multiple races contained in VADM(12)
- +39 NEW SRORAC,SRORCD,SRORCE
- SET SRORCE=0
- SET SRORAC=""
- SET SRORACE=""
- SET SRORCD=""
- +40 FOR
- SET SRORCE=$ORDER(VADM(12,SRORCE))
- if SRORCE=""
- QUIT
- Begin DoDot:1
- +41 ;Race code
- SET SRORAC=$PIECE($GET(VADM(12,SRORCE)),U,1)
- +42 ;PTF race code
- SET SRORCD=$$PTR2CODE^DGUTL4(SRORAC,1,4)
- +43 SET SRORACE=SRORACE_$JUSTIFY(SRORCD,1)
- End DoDot:1
- +44 SET SRORACE=SRORACE_" "
- +45 SET SHEMP=SHEMP_$EXTRACT(SRORACE,1,10)
- +46 ;get name of person who completed assessment
- +47 NEW SRP
- SET SRP=$PIECE($GET(^SRF(SRTN,"RA")),"^",9)
- IF SRP
- SET Y=SRP
- SET C=$PIECE(^DD(130,272.1,0),"^",2)
- DO Y^DIQ
- SET SRP=Y
- +48 SET X=$LENGTH(SRP)+1
- FOR I=X:1:35
- SET SRP=SRP_" "
- +49 SET SRA(.9)=$GET(^SRF(SRTN,.9))
- SET SRA("VER")=$GET(^SRF(SRTN,"VER"))
- +50 ;Line 13
- SET SHEMP=SHEMP_SRP_$JUSTIFY($PIECE(SRA(.9),"^"),12)_$JUSTIFY($EXTRACT($PIECE(SRA(.9),"^",2),1,12),12)_$JUSTIFY($PIECE(SRA(.9),"^",3),12)_$JUSTIFY($PIECE(SRA(.9),"^",4),12)_$JUSTIFY($PIECE(SRA(.9),"^",5),12)_$JUSTIFY($PIECE(SRA(.9),"^",6),12)
- +51 FOR I=7:1:18
- SET SHEMP=SHEMP_$JUSTIFY($PIECE(SRA("VER"),"^",I),2)
- +52 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
- SET SRACNT=SRACNT+1
- +53 ;
- +54 NEW II,OT,SRC,SRNM11,SRNM13,SRNM23,SRNM25
- +55 SET II=0
- SET OT=""
- FOR
- SET II=$ORDER(^SRF(SRTN,63,"B",II))
- if 'II
- QUIT
- SET OT=OT_II
- +56 SET SHEMP=$EXTRACT(SHEMP,1,11)_" 14"_$JUSTIFY(OT,7)_$JUSTIFY($PIECE(SRA("VER1"),"^",2),10)_$JUSTIFY($PIECE(SRA("VER1"),"^",3),2)_$JUSTIFY($PIECE(SRA("VER1"),"^",4),2)_$JUSTIFY($PIECE(SRA("VER1"),"^",5),2)
- +57 SET SHEMP=SHEMP_$JUSTIFY($PIECE(SRA("VER1"),"^",6),2)_$JUSTIFY($PIECE(SRA("VER1"),"^",7),1)_$JUSTIFY($PIECE(SRA("VER1"),"^",8),1)_$JUSTIFY($PIECE(SRA("VER1"),"^",9),1)_$JUSTIFY($EXTRACT($PIECE(SRA("VER1"),"^",19),1,12),12)
- +58 SET SHEMP=SHEMP_$JUSTIFY($PIECE(SRA("VER1"),"^",10),1)_$JUSTIFY($EXTRACT($PIECE(SRA("VER1"),"^",21),1,12),12)_$JUSTIFY($PIECE(SRA("VER1"),"^",22),1)_$JUSTIFY($PIECE(SRA("VER1"),"^",12),1)_$JUSTIFY($PIECE(SRA("VER1"),"^",24),2)
- +59 SET SHEMP=SHEMP_$JUSTIFY($PIECE(SRA("VER1"),"^",14),2)_$JUSTIFY($PIECE(SRA("VER1"),"^",15),1)_$JUSTIFY($PIECE(SRA("VER1"),"^",16),2)
- +60 SET (SRNM11,SRNM13,SRNM23,SRNM25)=""
- +61 FOR II=11,23,13,25
- IF $PIECE(SRA("VER1"),"^",II)
- SET @("SRNM"_II)=$PIECE($GET(^VA(200,$PIECE(SRA("VER1"),"^",II),0)),"^")
- +62 SET SHEMP=SHEMP_$JUSTIFY($EXTRACT(SRNM11,1,30),30)_$JUSTIFY($EXTRACT(SRNM23,1,30),30)
- +63 SET SHEMP=SHEMP_$JUSTIFY($EXTRACT(SRNM13,1,30),30)_$JUSTIFY($EXTRACT(SRNM25,1,30),30)
- +64 KILL SRNM
- SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
- SET SRACNT=SRACNT+1
- +65 ;
- +66 SET II=0
- SET (SRC,OT)=""
- FOR
- SET SRC=$ORDER(^SRF(SRTN,57,"B",SRC))
- if SRC=""!(II=7)
- QUIT
- SET OT=OT_$JUSTIFY($EXTRACT(SRC,1,10),10)
- SET II=II+1
- +67 SET OT=$EXTRACT(OT,1,70)_$JUSTIFY("",70-$LENGTH(OT))
- SET SHEMP=$EXTRACT(SHEMP,1,11)_" 15"_$JUSTIFY(OT,70)
- +68 SET OT=""
- FOR I=1:1:17,19:1:28
- SET OT=OT_$JUSTIFY($PIECE(SRA(211),U,I),2)
- +69 SET SHEMP=SHEMP_OT
- +70 SET (SRC,OT)=""
- FOR
- SET SRC=$ORDER(^SRF(SRTN,64,"B",SRC))
- if 'SRC
- QUIT
- SET OT=OT_$JUSTIFY(SRC,1)
- +71 SET SHEMP=SHEMP_$JUSTIFY(OT,6)_$JUSTIFY($PIECE(SRA(211),U,30),2)_$JUSTIFY($PIECE(SRA(211),U,31),5)_$JUSTIFY($PIECE(SRA(211),U,32),5)_$JUSTIFY($PIECE(SRA(211),U,35),5)
- +72 SET OT=""
- SET II=0
- FOR II="34;4","39;4","33;3","36;3","40;3","37;2","38;2","41;2","42;2","43;2"
- SET OT=OT_$JUSTIFY($PIECE(SRA(211),U,+II),$PIECE(II,";",2))
- +73 SET SHEMP=SHEMP_OT_$JUSTIFY($PIECE(SRA("VERD"),U,6),4)_$JUSTIFY($PIECE(SRA("VERD"),U,7),5)_$JUSTIFY($PIECE(SRA("VERD"),U,8),4)
- +74 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
- SET SRACNT=SRACNT+1
- +75 ;
- +76 SET OT=""
- FOR II=2:1:4,7,10,11
- SET OT=OT_$JUSTIFY($PIECE(SRA(210),U,II),2)
- +77 SET SHEMP=$EXTRACT(SHEMP,1,11)_" 16"_OT
- +78 SET OT=""
- FOR II=44:1:53
- SET OT=OT_$JUSTIFY($PIECE(SRA(211),U,II),2)
- +79 SET SHEMP=SHEMP_OT_$JUSTIFY($EXTRACT($PIECE(SRA(211),U,54),1,12),12)_$JUSTIFY($EXTRACT($PIECE(SRA(211),U,55),1,12),12)_$JUSTIFY($PIECE(SRA(211),U,56),3)_$JUSTIFY($PIECE(SRA(211),U,57),3)
- +80 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
- SET SRACNT=SRACNT+1
- +81 ;
- +82 SET SHEMP=$EXTRACT(SHEMP,1,11)_" A1"
- +83 SET SHEMP=SHEMP_SRANAME
- SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
- SET SHEMP=$EXTRACT(SHEMP,1,11)_" A2"
- SET SRACNT=SRACNT+1
- +84 SET SRA(0)=^SRF(SRTN,0)
- SET DFN=$PIECE(SRA(0),"^")
- KILL SRA,VADM
- DO ADD^VADPT
- +85 SET SHEMP=SHEMP_VAPA(1)
- SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
- SET SHEMP=$EXTRACT(SHEMP,1,11)_" A3"
- SET SRACNT=SRACNT+1
- +86 SET SHEMP=SHEMP_VAPA(2)
- SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
- SET SHEMP=$EXTRACT(SHEMP,1,11)_" A4"
- SET SRACNT=SRACNT+1
- +87 SET SHEMP=SHEMP_VAPA(3)
- SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
- SET SHEMP=$EXTRACT(SHEMP,1,11)_" A5"
- SET SRACNT=SRACNT+1
- +88 SET SHEMP=SHEMP_VAPA(4)
- SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
- SET SHEMP=$EXTRACT(SHEMP,1,11)_" A6"
- SET SRACNT=SRACNT+1
- +89 SET SHEMP=SHEMP_$PIECE(VAPA(5),"^",2)
- SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
- SET SHEMP=$EXTRACT(SHEMP,1,11)_" A7"
- SET SRACNT=SRACNT+1
- +90 SET SHEMP=SHEMP_VAPA(6)
- SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
- SET SHEMP=$EXTRACT(SHEMP,1,11)_" A8"
- SET SRACNT=SRACNT+1
- +91 SET SHEMP=SHEMP_VAPA(8)
- SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
- SET SRACNT=SRACNT+1
- +92 QUIT
- MOD ; get principal CPT modifiers
- +1 SET SRI=0
- SET SRCNT=1
- SET SRM=""
- FOR
- SET SRI=$ORDER(^SRO(136,SRCASE,1,SRI))
- if 'SRI
- QUIT
- Begin DoDot:1
- +2 SET X=$PIECE(^SRO(136,SRCASE,1,SRI,0),"^")
- SET Y=$PIECE($$MOD^ICPTMOD(X,"I"),"^",2)
- +3 IF Y'=""
- SET SRM=SRM_Y
- SET SRCNT=SRCNT+1
- End DoDot:1
- if SRCNT>5
- QUIT
- +4 QUIT
- OTH ; get other procedure CPT modifiers
- +1 SET SRI=0
- SET SRCNT=1
- FOR
- SET SRI=$ORDER(^SRO(136,SRTN,3,OPS,1,SRI))
- if 'SRI
- QUIT
- Begin DoDot:1
- +2 SET X=$PIECE(^SRO(136,SRTN,3,OPS,1,SRI,0),"^")
- SET Y=$PIECE($$MOD^ICPTMOD(X,"I"),"^",2)
- +3 IF Y'=""
- SET SRMOD(CNT)=SRMOD(CNT)_Y
- SET SRCNT=SRCNT+1
- End DoDot:1
- if SRCNT>5
- QUIT
- +4 QUIT