SROATM1 ;BIR/MAM - NON CARDIAC TRANSMISSION ;12/10/07
;;3.0; Surgery ;**27,38,47,60,62,81,88,93,95,125,153,160,166**;24 Jun 93;Build 6
;** 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,SRCDT,SRCREQ F I=0,200,200.1,206 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 SRCDT=$P($G(^SRF(SRTN,209)),"^",15),SRCREQ=$P($G(^SRF(SRTN,209)),"^",17)
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(SRDTH,12)_$J(SRCDT,7)_$J(SRCREQ,7)
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,NYUK=$P(SRA(200),"^",8) D ONE S SHEMP=SHEMP_MOE,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(200),"^",31) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",32) 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),"^",36) 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(200),"^",41) 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($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)_" "
S NYUK=$P(SRA(206),"^"),SHEMP=SHEMP_$J(NYUK,4),NYUK=$P(SRA(206),"^",2),SHEMP=SHEMP_$J(NYUK,4)
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
SROATM1 ;BIR/MAM - NON CARDIAC TRANSMISSION ;12/10/07
+1 ;;3.0; Surgery ;**27,38,47,60,62,81,88,93,95,125,153,160,166**;24 Jun 93;Build 6
+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,SRCDT,SRCREQ
FOR I=0,200,200.1,206
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 SRCDT=$PIECE($GET(^SRF(SRTN,209)),"^",15)
SET SRCREQ=$PIECE($GET(^SRF(SRTN,209)),"^",17)
+14 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(SRDTH,12)_$JUSTIFY(SRCDT,7)_$JUSTIFY(SRCREQ,7)
+15 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
SET SHEMP=$EXTRACT(SHEMP,1,11)_" 2"
SET SRACNT=SRACNT+1
+16 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
+17 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 NYUK=$PIECE(SRA(200),"^",8)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",10)
DO ONE
SET SHEMP=SHEMP_MOE
+18 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
+19 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(200),"^",31)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",32)
DO ONE
SET SHEMP=SHEMP_MOE
+20 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),"^",36)
DO ONE
SET SHEMP=SHEMP_MOE
+21 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(200),"^",41)
DO ONE
SET SHEMP=SHEMP_MOE
SET NYUK=$PIECE(SRA(200),"^",42)
DO ONE
SET SHEMP=SHEMP_MOE
+22 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
+23 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
+24 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
+25 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
+26 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)
+27 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)
+28 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
+29 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
+30 SET SRASA=""
SET Y=$PIECE($GET(^SRF(SRTN,1.1)),"^",3)
IF Y
SET X=$PIECE($PIECE($GET(^SRO(132.8,Y,0)),"^"),"-")
SET SRASA=X
SET NYUK=$EXTRACT(SRASA,1,1)
DO ONE
SET SHEMP=SHEMP_MOE
+31 KILL SRTECH,SRZ,SRTRAUMA
SET SRT=0
FOR
SET SRT=$ORDER(^SRF(SRTN,6,SRT))
IF 'SRT
QUIT
DO ^SROPRIN
IF $DATA(SRZ)
QUIT
+32 IF $DATA(SRTECH)
SET SRTRAUMA=$PIECE(^SRF(SRTN,6,SRT,0),"^",14)
SET SRINTUB=$PIECE($GET(^SRF(SRTN,6,SRT,8)),"^",2)
+33 IF '$DATA(SRTECH)
SET (SRTECH,SRTRAUMA,SRINTUB)=""
+34 SET SHEMP=SHEMP_$JUSTIFY(SRTECH,1)_$JUSTIFY($EXTRACT(SRASA,2),1)_$JUSTIFY(SRINTUB,1)_" "
+35 SET NYUK=$PIECE(SRA(206),"^")
SET SHEMP=SHEMP_$JUSTIFY(NYUK,4)
SET NYUK=$PIECE(SRA(206),"^",2)
SET SHEMP=SHEMP_$JUSTIFY(NYUK,4)
+36 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
SET SHEMP=$EXTRACT(SHEMP,1,11)_" 3"
SET SRACNT=SRACNT+1
+37 DO ^SROATM2
+38 QUIT
ONE SET MOE=$SELECT(NYUK="NS":"S",NYUK="":" ",1:NYUK)
+1 QUIT
