- 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
