SROATM1 ;BIR/MAM - NON CARDIAC TRANSMISSION ;09/15/2011
;;3.0;Surgery;**27,38,47,60,62,81,88,93,95,125,153,160,166,174,176,177,182,184**;24 Jun 93;Build 35
;** NOTICE: This routine is part of an implementation of a nationally
;** controlled procedure. Local modifications to this routine
;** are prohibited.
;
; Reference to ^DIC(45.3 supported by DBIA #218
;
N SRINTUB,SRDTH,SRPID,SROR F I=0,200,200.1,206,207,52,204,210,200.1 S SRA(I)=$G(^SRF(SRTN,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),"^",9),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 X=$$SITE^SROUTL0(SRTN),SRDIV=$S(X:$P(^SRO(133,X,0),"^"),1:""),SRDIV=$S(SRDIV:$$GET1^DIQ(4,SRDIV,99),1:SRASITE)
S X=$P($G(^SRF(SRTN,205)),"^",3),SRDTH=$S(X:X,1:$P(VADM(6),"^"))
S SROR="",Y=$P(SRA(0),"^",2),C=$P(^DD(130,.02,0),"^",2) I Y'="" D Y^DIQ S SROR=Y
;
S SHEMP="$"_$J(SRASITE,3)_$J(SRTN,7)_" 1"_DT_$J(AGE,3)_$J(SEX,1)_$J(SRSDATE,12)_$J(SRPID,20)_$J(SRDIV,6)_$J($E(SRDTH,1,12),12)_$J($E(SROR,1,30),30)
F I=1:1:6 S SHEMP=SHEMP_$J($P(SRA(52),"^",I),2)
S SHEMP=SHEMP_$J($P(SRA(200),"^",55),2) F I=9:1:14 S SHEMP=SHEMP_$J($P(SRA(200.1),"^",I),2)
;
S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_" 2",SRACNT=SRACNT+1
S NYUK=$P(SRA(200),"^",2) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",3) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",4) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200.1),"^",2) D ONE S SHEMP=SHEMP_MOE
S NYUK=$P(SRA(200),"^",6) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",7) D ONE S SHEMP=SHEMP_MOE S SHEMP=SHEMP_" ",NYUK=$P(SRA(200),"^",10) D ONE S SHEMP=SHEMP_MOE
S NYUK=$P(SRA(200),"^",11) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",12) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200.1),"^",6) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",15) D ONE S SHEMP=SHEMP_MOE
S NYUK=$P(SRA(200),"^",16) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",17) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(206),"^",14) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",56) D ONE S SHEMP=SHEMP_MOE
S NYUK=$P(SRA(200),"^",33) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",34) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",35) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",57) D ONE S SHEMP=SHEMP_MOE
S NYUK=$P(SRA(200),"^",38) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",39) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(206),"^",16) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",42) D ONE S SHEMP=SHEMP_MOE
S NYUK=$P(SRA(200),"^",43) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",19) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",20) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",21) D ONE S SHEMP=SHEMP_MOE
S NYUK=$P(SRA(200),"^",22) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",23) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",24) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",25) D ONE S SHEMP=SHEMP_MOE
S NYUK=$P(SRA(200),"^",26) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",27) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",28) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",29) D ONE S SHEMP=SHEMP_MOE
S NYUK=$P(SRA(200),"^",45) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",46) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",47) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",48) D ONE S SHEMP=SHEMP_MOE
S NYUK=$P(SRA(200),"^",49) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",50) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200.1),"^",3),SHEMP=SHEMP_$J(NYUK,2)
S NYUK=$P(SRA(0),"^",4) S:NYUK NYUK=$E($P(^DIC(45.3,$P(^SRO(137.45,NYUK,0),"^",2),0),"^"),1,3) S SHEMP=SHEMP_$J(NYUK,3)
S NYUK=$P(SRA(200),"^",52),SHEMP=SHEMP_$J(NYUK,2),X=$P(SRA(0),"^",10),NYUK=$S(X="EM":"Y",1:"N") D ONE S SHEMP=SHEMP_MOE
S NYUK=$P($G(^SRF(SRTN,"1.0")),"^",8),SHEMP=SHEMP_$J(NYUK,2),NYUK=$P(SRA(200),"^",53) D ONE S SHEMP=SHEMP_MOE
S SRASA="",Y=$P($G(^SRF(SRTN,1.1)),"^",3) S:Y X=$P($G(^SRO(132.8,Y,0)),"^"),SRASA=X S NYUK=$E(SRASA,1,1) D ONE S SHEMP=SHEMP_MOE
K SRTECH,SRZ,SRTRAUMA S SRT=0 F S SRT=$O(^SRF(SRTN,6,SRT)) Q:'SRT D ^SROPRIN Q:$D(SRZ)
I $D(SRTECH) S SRTRAUMA=$P(^SRF(SRTN,6,SRT,0),"^",14),SRINTUB=$P($G(^SRF(SRTN,6,SRT,8)),"^",2)
I '$D(SRTECH) S (SRTECH,SRTRAUMA,SRINTUB)=""
S SHEMP=SHEMP_$J(SRTECH,1)_$J($E(SRASA,2),1)_$J(SRINTUB,1)_$J($P(SRA(200.1),"^",8),1)
S NYUK=$P(SRA(206),"^"),SHEMP=SHEMP_$J(NYUK,4),NYUK=$P(SRA(206),"^",2),SHEMP=SHEMP_$J(NYUK,4)
S X=$P(SRA(206),"^",42),Y="" F I=1:1:6 S Y=Y_$P(X,",",I)
S SHEMP=SHEMP_$J(Y,6)
S NYUK=$P(SRA(200),"^",59) D ONE S SHEMP=SHEMP_MOE S NYUK=$P(SRA(200),"^",58) D ONE S SHEMP=SHEMP_MOE_$$ADD182^SROATCM1(SRTN)
S NYUK=$P(SRA(206),"^",18) S SHEMP=SHEMP_$J(NYUK,3) S NYUK=$P(SRA(206),"^",19) S SHEMP=SHEMP_$J(NYUK,3)
S NYUK=$P($G(^SRF(SRTN,.4)),"^",6) S:NYUK NYUK=$P($G(^SRO(131.6,NYUK,0)),"^",2)
S SHEMP=SHEMP_$J(NYUK,3)_$J($P(SRA(210),U,1),2)_$J($P(SRA(200.1),U,15),2)_$J($P(SRA(204),U,17),2)_$J($P(SRA(210),U,5),2)_$J($P(SRA(210),U,6),2)_$J($P(SRA(210),U,8),2)_$J($P(SRA(210),U,9),2)_$J($P(SRA(210),U,12),2)
S SHEMP=SHEMP_$J($P(SRA(207),U,29),2)_$J($P($G(^SRF(SRTN,.1)),"^",21),1)_$J($P(SRA(210),"^",14),2)
S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_" 3",SRACNT=SRACNT+1
D ^SROATM2
Q
ONE S MOE=$S(NYUK="NS":"S",NYUK="":" ",1:NYUK)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROATM1 5296 printed Dec 13, 2024@02:42:08 Page 2
SROATM1 ;BIR/MAM - NON CARDIAC TRANSMISSION ;09/15/2011
+1 ;;3.0;Surgery;**27,38,47,60,62,81,88,93,95,125,153,160,166,174,176,177,182,184**;24 Jun 93;Build 35
+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 ; Reference to ^DIC(45.3 supported by DBIA #218
+7 ;
+8 NEW SRINTUB,SRDTH,SRPID,SROR
FOR I=0,200,200.1,206,207,52,204,210,200.1
SET SRA(I)=$GET(^SRF(SRTN,I))
+9 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),"^",9),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))
+10 ; remove hyphens from PID
SET SRPID=VA("PID")
SET SRPID=$TRANSLATE(SRPID,"-","")
+11 SET X=$$SITE^SROUTL0(SRTN)
SET SRDIV=$SELECT(X:$PIECE(^SRO(133,X,0),"^"),1:"")
SET SRDIV=$SELECT(SRDIV:$$GET1^DIQ(4,SRDIV,99),1:SRASITE)
+12 SET X=$PIECE($GET(^SRF(SRTN,205)),"^",3)
SET SRDTH=$SELECT(X:X,1:$PIECE(VADM(6),"^"))
+13 SET SROR=""
SET Y=$PIECE(SRA(0),"^",2)
SET C=$PIECE(^DD(130,.02,0),"^",2)
IF Y'=""
DO Y^DIQ
SET SROR=Y
+14 ;
+15 SET SHEMP="$"_$JUSTIFY(SRASITE,3)_$JUSTIFY(SRTN,7)_" 1"_DT_$JUSTIFY(AGE,3)_$JUSTIFY(SEX,1)_$JUSTIFY(SRSDATE,12)_$JUSTIFY(SRPID,20)_$JUSTIFY(SRDIV,6)_$JUSTIFY($EXTRACT(SRDTH,1,12),12)_$JUSTIFY($EXTRACT(SROR,1,30),30)
+16 FOR I=1:1:6
SET SHEMP=SHEMP_$JUSTIFY($PIECE(SRA(52),"^",I),2)
+17 SET SHEMP=SHEMP_$JUSTIFY($PIECE(SRA(200),"^",55),2)
FOR I=9:1:14
SET SHEMP=SHEMP_$JUSTIFY($PIECE(SRA(200.1),"^",I),2)
+18 ;
+19 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
SET SHEMP=$EXTRACT(SHEMP,1,11)_" 2"
SET SRACNT=SRACNT+1
+20 SET NYUK=$PIECE(SRA(200),"^",2)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",3)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",4)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200.1),"^",2)
DO ONE
SET SHEMP=SHEMP_MOE
+21 SET NYUK=$PIECE(SRA(200),"^",6)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",7)
DO ONE
SET SHEMP=SHEMP_MOE
SET SHEMP=SHEMP_" "
SET NYUK=$PIECE(SRA(200),"^",10)
DO ONE
SET SHEMP=SHEMP_MOE
+22 SET NYUK=$PIECE(SRA(200),"^",11)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",12)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200.1),"^",6)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",15)
DO ONE
SET SHEMP=SHEMP_MOE
+23 SET NYUK=$PIECE(SRA(200),"^",16)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",17)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(206),"^",14)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",56)
DO ONE
SET SHEMP=SHEMP_MOE
+24 SET NYUK=$PIECE(SRA(200),"^",33)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",34)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",35)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",57)
DO ONE
SET SHEMP=SHEMP_MOE
+25 SET NYUK=$PIECE(SRA(200),"^",38)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",39)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(206),"^",16)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",42)
DO ONE
SET SHEMP=SHEMP_MOE
+26 SET NYUK=$PIECE(SRA(200),"^",43)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",19)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",20)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",21)
DO ONE
SET SHEMP=SHEMP_MOE
+27 SET NYUK=$PIECE(SRA(200),"^",22)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",23)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",24)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",25)
DO ONE
SET SHEMP=SHEMP_MOE
+28 SET NYUK=$PIECE(SRA(200),"^",26)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",27)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",28)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",29)
DO ONE
SET SHEMP=SHEMP_MOE
+29 SET NYUK=$PIECE(SRA(200),"^",45)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",46)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",47)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",48)
DO ONE
SET SHEMP=SHEMP_MOE
+30 SET NYUK=$PIECE(SRA(200),"^",49)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",50)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200.1),"^",3)
SET SHEMP=SHEMP_$JUSTIFY(NYUK,2)
+31 SET NYUK=$PIECE(SRA(0),"^",4)
if NYUK
SET NYUK=$EXTRACT($PIECE(^DIC(45.3,$PIECE(^SRO(137.45,NYUK,0),"^",2),0),"^"),1,3)
SET SHEMP=SHEMP_$JUSTIFY(NYUK,3)
+32 SET NYUK=$PIECE(SRA(200),"^",52)
SET SHEMP=SHEMP_$JUSTIFY(NYUK,2)
SET X=$PIECE(SRA(0),"^",10)
SET NYUK=$SELECT(X="EM":"Y",1:"N")
DO ONE
SET SHEMP=SHEMP_MOE
+33 SET NYUK=$PIECE($GET(^SRF(SRTN,"1.0")),"^",8)
SET SHEMP=SHEMP_$JUSTIFY(NYUK,2)
SET NYUK=$PIECE(SRA(200),"^",53)
DO ONE
SET SHEMP=SHEMP_MOE
+34 SET SRASA=""
SET Y=$PIECE($GET(^SRF(SRTN,1.1)),"^",3)
if Y
SET X=$PIECE($GET(^SRO(132.8,Y,0)),"^")
SET SRASA=X
SET NYUK=$EXTRACT(SRASA,1,1)
DO ONE
SET SHEMP=SHEMP_MOE
+35 KILL SRTECH,SRZ,SRTRAUMA
SET SRT=0
FOR
SET SRT=$ORDER(^SRF(SRTN,6,SRT))
if 'SRT
QUIT
DO ^SROPRIN
if $DATA(SRZ)
QUIT
+36 IF $DATA(SRTECH)
SET SRTRAUMA=$PIECE(^SRF(SRTN,6,SRT,0),"^",14)
SET SRINTUB=$PIECE($GET(^SRF(SRTN,6,SRT,8)),"^",2)
+37 IF '$DATA(SRTECH)
SET (SRTECH,SRTRAUMA,SRINTUB)=""
+38 SET SHEMP=SHEMP_$JUSTIFY(SRTECH,1)_$JUSTIFY($EXTRACT(SRASA,2),1)_$JUSTIFY(SRINTUB,1)_$JUSTIFY($PIECE(SRA(200.1),"^",8),1)
+39 SET NYUK=$PIECE(SRA(206),"^")
SET SHEMP=SHEMP_$JUSTIFY(NYUK,4)
SET NYUK=$PIECE(SRA(206),"^",2)
SET SHEMP=SHEMP_$JUSTIFY(NYUK,4)
+40 SET X=$PIECE(SRA(206),"^",42)
SET Y=""
FOR I=1:1:6
SET Y=Y_$PIECE(X,",",I)
+41 SET SHEMP=SHEMP_$JUSTIFY(Y,6)
+42 SET NYUK=$PIECE(SRA(200),"^",59)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",58)
DO ONE
SET SHEMP=SHEMP_MOE_$$ADD182^SROATCM1(SRTN)
+43 SET NYUK=$PIECE(SRA(206),"^",18)
SET SHEMP=SHEMP_$JUSTIFY(NYUK,3)
SET NYUK=$PIECE(SRA(206),"^",19)
SET SHEMP=SHEMP_$JUSTIFY(NYUK,3)
+44 SET NYUK=$PIECE($GET(^SRF(SRTN,.4)),"^",6)
if NYUK
SET NYUK=$PIECE($GET(^SRO(131.6,NYUK,0)),"^",2)
+45 SET SHEMP=SHEMP_$JUSTIFY(NYUK,3)_$JUSTIFY($PIECE(SRA(210),U,1),2)_$JUSTIFY($PIECE(SRA(200.1),U,15),2)_$JUSTIFY($PIECE(SRA(204),U,17),2)_...
... $JUSTIFY($PIECE(SRA(210),U,5),2)_$JUSTIFY($PIECE(SRA(210),U,6),2)_$JUSTIFY($PIECE(SRA(210),U,8),2)_$JUSTIFY($PIECE(SRA(210),U,9),2)_$JUSTIFY($PIECE(SRA(210),U,12),2)
+46 SET SHEMP=SHEMP_$JUSTIFY($PIECE(SRA(207),U,29),2)_$JUSTIFY($PIECE($GET(^SRF(SRTN,.1)),"^",21),1)_$JUSTIFY($PIECE(SRA(210),"^",14),2)
+47 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
SET SHEMP=$EXTRACT(SHEMP,1,11)_" 3"
SET SRACNT=SRACNT+1
+48 DO ^SROATM2
+49 QUIT
ONE SET MOE=$SELECT(NYUK="NS":"S",NYUK="":" ",1:NYUK)
+1 QUIT
