- SROATM2 ;BIR/MAM - NON CARDIAC TRANSMISSION (CONT) ;09/15/2011
- ;;3.0;Surgery;**38,39,45,47,57,60,62,68,81,88,97,129,125,142,153,160,174,175,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.
- ;
- K SRA F I=.2,.3,1.1,200.1,201:1:208,208.1,202.1,210,211,"VER1","VERD" S SRA(I)=$G(^SRF(SRTN,I))
- S SRA("CON")=$P($G(^SRF(SRTN,"CON")),"^") I SRA("CON"),$P($G(^SRF(SRA("CON"),30)),"^")!($P($G(^SRF(SRA("CON"),31)),"^",8)) S SRA("CON")=""
- D RS
- S SHEMP=SHEMP_$J($E($P(SRA(.2),"^",2),1,12),12)_$J($E($P(SRA(.2),"^",3),1,12),12)_$J(SRATT,2)_$J($P(SRA(200.1),"^",4),2)_$J($P($G(^SRF(SRTN,200)),"^",54),2)
- S SRICD=$P($G(^SRO(136,SRTN,0)),"^",3) S:SRICD SRICD=$P($$ICD^SROICD(SRTN,SRICD),"^",2) S SHEMP=SHEMP_$J(SRICD,8)_$J($P(SRA(205),"^"),4)_" "
- S NYUK="N",SRET=0 F S SRET=$O(^SRF(SRTN,29,SRET)) Q:'SRET S CASE=$P(^SRF(SRTN,29,SRET,0),"^") I $P($G(^SRF(CASE,.2)),"^",10) S NYUK="Y" Q
- S SHEMP=SHEMP_NYUK_$J($P($G(^SRF(SRTN,.4)),"^",7),1)_$J($E($P($G(^SRF(SRTN,0)),"^",12)),1)_$J($P($G(^SRF(SRTN,0)),"^",3),1)
- S (SRADMIT,SRADMT)=0 I '$P(SRA(208),"^",14) D ADM^SROQ0A S SRADMIT=$S(SRADMT=0:"0",1:"1")
- S SHEMP=SHEMP_$J($E($P($G(^SRF(SRTN,0)),"^",26)),1)_SRADMIT D OCC^SROATMNO S SHEMP=SHEMP_SRTMP_$J(SROCTYPE,1)_$J(SROC(35),2)_$J(SROC(36),2)
- S NYUK=$E($P(VADM(3),"^"),1,7),SHEMP=SHEMP_$J(NYUK,7) ; date of birth
- S SHEMP=SHEMP_$J(SROC(38),2)_$J(SROC(39),2)_$J(SROC(40),2)_$J(SROC(41),2)_$J(SROC(42),2) K SROC,SROCTYPE,SRTMP
- ;
- S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_" 4",SRACNT=SRACNT+1
- F MOE=1:1:6 S CPT(MOE)=""
- S (X,CNT)=0 F S X=$O(^SRF(SRTN,29,X)) Q:'X!(CNT=6) I $P(^SRF(SRTN,29,X,0),"^",3)="R" S NYUK=$P(^SRF(SRTN,29,X,0),"^") D RETURN
- S SHEMP=SHEMP_$J(CNT,2)
- 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)
- F MOE=1:1:6 S CPT(MOE)=""
- S (X,CNT)=0 F S X=$O(^SRF(SRTN,29,X)) Q:'X!(CNT=6) I $P(^SRF(SRTN,29,X,0),"^",3)'="R" S NYUK=$P(^SRF(SRTN,29,X,0),"^") D RETURN
- S SHEMP=SHEMP_$J(CNT,2)
- 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)
- S SRSDATE=$P(^SRF(SRTN,0),"^",9) K SRSEP D OCC^SROAUTL0 S:'$D(SRO) SRO="",$P(SRO," ",205)="" S SHEMP=SHEMP_$E(SRO,1,112)
- ;
- S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_" 5",SRACNT=SRACNT+1
- S NYUK=$P(SRA(205),"^",6) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(205),"^",7) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(205),"^",8) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(205),"^",10) D ONE S SHEMP=SHEMP_MOE
- S NYUK="N" I $P(SRA(205),"^",11)="Y"!($P(SRA(205),"^",28)="Y") S NYUK="Y"
- D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(205),"^",12) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(205),"^",13) D ONE S SHEMP=SHEMP_MOE,NYUK=$P($G(SROOC(29)),U)
- D IFELSE
- S NYUK=$P(SRA(205),"^",16) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(205),"^",17) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(205),"^",18) D ONE S SHEMP=SHEMP_MOE,NYUK=$P($G(SROOC(31)),U)
- D IFELSE
- N SRCVA D CVA S SHEMP=SHEMP_SRCVA
- S NYUK=$P(SRA(205),"^",22) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(205),"^",23) D ONE S SHEMP=SHEMP_MOE,NYUK=$P($G(SROOC(30)),U)
- D IFELSE
- S NYUK=$P(SRA(205),"^",26) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(205),"^",27) D ONE S SHEMP=SHEMP_MOE_" " S NYUK=$P($G(SROOC(32)),U)
- D IFELSE
- S NYUK=$P(SRA(205),"^",31) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(205),"^",32) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(205),"^",33) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(205),"^",34) D ONE S SHEMP=SHEMP_MOE
- S NYUK=$P(SRA(205),"^",35) D ONE S SHEMP=SHEMP_MOE,NYUK=$P($G(SROOC(21)),U) D IFELSE
- S SHEMP=SHEMP_$E(SRO,113,196),NYUK=$P(SRA(205),"^",37) D ONE S SHEMP=SHEMP_MOE,NYUK=$P($G(SROOC(36)),U) D IFELSE
- S SHEMP=SHEMP_$J($E(SRO,204),1)
- S NYUK=$P(SRA(205),"^",39) D ONE S SHEMP=SHEMP_MOE_$J($E(SRO,197,203),7)
- S NYUK=$P(SRA(205),"^",42) D ONE S SHEMP=SHEMP_MOE S NYUK=$P(SRA(205),"^",43) D ONE S SHEMP=SHEMP_MOE
- S SHEMP=SHEMP_$J($E(SRO,206,212),7)_$J($E(SRO,213,219),7)_$J($E(SRO,220,224),5)
- S NYUK=$P(SRA(205),"^",44) D ONE S SHEMP=SHEMP_MOE_$J($E(SRO,225,231),7)
- ;
- S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_" 6",SRACNT=SRACNT+1
- S SHEMP=SHEMP_$J($P(SRA(201),"^"),5)_$J($P(SRA(202),"^"),7)_$J($P(SRA(201),"^",8),4)_$J($P(SRA(202),"^",8),7)_$J($P(SRA(201),"^",9),5)_$J($P(SRA(202),"^",9),7)_$J($P(SRA(201),"^",5),5)_$J($P(SRA(202),"^",5),7)
- S SHEMP=SHEMP_$J($P(SRA(201),"^",4),4)_$J($P(SRA(202),"^",4),7)
- S SHEMP=SHEMP_$J($P(SRA(201),"^",27),5)_$J($P(SRA(202),"^",27),7)
- S SHEMP=SHEMP_$J($P(SRA(203),"^",15),5)_$J($P(SRA(204),"^",15),7)
- S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_" 7",SRACNT=SRACNT+1
- S SHEMP=SHEMP_$J($E($P(SRA(208),"^",14),1,12),12)_" "_$J($P($G(SRA(208)),"^",11),2)_$J($P($G(SRA(208)),"^",10),2)_$J($E($P($G(SRA(208)),"^",9),1,4),4)
- S SHEMP=SHEMP_$J($E($P(SRA(208),"^",15),1,12),12)_" "_$J($P($G(SRA(206)),"^",3),2)_$J($P($G(SRA(206)),"^",4),2)_$J($P($G(SRA(206)),"^",8),2)_" "
- S SHEMP=SHEMP_$J($E($P(SRA(208),"^",16),1,12),12)_$J($E($P(SRA(208),"^",17),1,12),12)_$J($E($P(SRA(.2),"^",12),1,12),12)_$J($E($P(SRA(.2),"^"),1,12),12)
- S SHEMP=SHEMP_$J($E($P(SRA(1.1),"^",8),1,12),12)_$J($E($P(SRA(208.1),"^"),1,12),12)_$J($E($P(SRA(208.1),"^",2),1,12),12)_$J($E($P(SRA(208.1),"^",3),1,3),3)_$J(SRA("CON"),10)_$J($E($P(SRA(.2),"^",4),1,12),12)
- S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_" 8",SRACNT=SRACNT+1
- S SHEMP=SHEMP_$J($P(SRA(201),"^",11),5)_$J($P(SRA(202),"^",11),7)_$J($P(SRA(201),"^",12),5)_$J($P(SRA(202),"^",12),7)_$J($P(SRA(201),"^",13),4)_$J($P(SRA(202),"^",13),7)_$J($P(SRA(201),"^",14),4)_$J($P(SRA(202),"^",14),7)
- S SHEMP=SHEMP_$J($P(SRA(201),"^",15),5)_$J($P(SRA(202),"^",15),7)
- S SHEMP=SHEMP_$J($P(SRA(201),"^",28),6)_$J($P(SRA(202.1),"^"),7)
- S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_" 9",SRACNT=SRACNT+1
- D ^SROATM3
- Q
- ONE S MOE=$S(NYUK="NS":"S",NYUK="":" ",1:NYUK)
- Q
- IFELSE I NYUK["NO ICD" S SHEMP=SHEMP_$J(" ",8)
- E S SHEMP=SHEMP_$J(NYUK,8)
- Q
- CVA S X=$P(SRA(205),"^",21),SRCVA=$S(X="Y":"Y",1:1) I SRCVA=1 Q
- N SROCC S SROCC=0 F S SROCC=$O(^SRF(SRTN,16,SROCC)) Q:'SROCC I $P(^SRF(SRTN,16,SROCC,0),"^",2)=12 S X=$P(^SRF(SRTN,16,SROCC,0),"^",8) S:X'="" SRCVA=X Q
- Q
- RS ; resident supervision (attending code)
- N SRSR,SRX S (SRATT,SRSR)="",SRX=$G(^SRF(SRTN,.1)) D SRES
- S SRATT=$P(SRX,"^",10) I SRATT="" D
- .I SRSR=0 S SRATT=$S($P(^SRF(SRTN,0),"^",9)<3040401:1,1:9) Q
- .S SRATT=99
- Q
- SRES ; does site have residents?
- N SRDIV,SRSITE,Y S SRDIV=$P($G(^SRF(SRTN,8)),"^") I SRDIV S SRSITE=$O(^SRO(133,"B",SRDIV,0)),SRSR=$P(^SRO(133,SRSITE,0),"^",19)
- Q
- RETURN ; CPT of Returns
- S Y=$P($G(^SRO(136,NYUK,0)),"^",2) I Y S CNT=CNT+1,CPT(CNT)=$P($$CPT^ICPTCOD(Y),"^",2)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROATM2 6840 printed Feb 19, 2025@00:08:39 Page 2
- SROATM2 ;BIR/MAM - NON CARDIAC TRANSMISSION (CONT) ;09/15/2011
- +1 ;;3.0;Surgery;**38,39,45,47,57,60,62,68,81,88,97,129,125,142,153,160,174,175,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 KILL SRA
- FOR I=.2,.3,1.1,200.1,201:1:208,208.1,202.1,210,211,"VER1","VERD"
- SET SRA(I)=$GET(^SRF(SRTN,I))
- +7 SET SRA("CON")=$PIECE($GET(^SRF(SRTN,"CON")),"^")
- IF SRA("CON")
- IF $PIECE($GET(^SRF(SRA("CON"),30)),"^")!($PIECE($GET(^SRF(SRA("CON"),31)),"^",8))
- SET SRA("CON")=""
- +8 DO RS
- +9 SET SHEMP=SHEMP_$JUSTIFY($EXTRACT($PIECE(SRA(.2),"^",2),1,12),12)_$JUSTIFY($EXTRACT($PIECE(SRA(.2),"^",3),1,12),12)_$JUSTIFY(SRATT,2)_$JUSTIFY($PIECE(SRA(200.1),"^",4),2)_$JUSTIFY($PIECE($GET(^SRF(SRTN,200)),"^",54),2)
- +10 SET SRICD=$PIECE($GET(^SRO(136,SRTN,0)),"^",3)
- if SRICD
- SET SRICD=$PIECE($$ICD^SROICD(SRTN,SRICD),"^",2)
- SET SHEMP=SHEMP_$JUSTIFY(SRICD,8)_$JUSTIFY($PIECE(SRA(205),"^"),4)_" "
- +11 SET NYUK="N"
- SET SRET=0
- FOR
- SET SRET=$ORDER(^SRF(SRTN,29,SRET))
- if 'SRET
- QUIT
- SET CASE=$PIECE(^SRF(SRTN,29,SRET,0),"^")
- IF $PIECE($GET(^SRF(CASE,.2)),"^",10)
- SET NYUK="Y"
- QUIT
- +12 SET SHEMP=SHEMP_NYUK_$JUSTIFY($PIECE($GET(^SRF(SRTN,.4)),"^",7),1)_$JUSTIFY($EXTRACT($PIECE($GET(^SRF(SRTN,0)),"^",12)),1)_$JUSTIFY($PIECE($GET(^SRF(SRTN,0)),"^",3),1)
- +13 SET (SRADMIT,SRADMT)=0
- IF '$PIECE(SRA(208),"^",14)
- DO ADM^SROQ0A
- SET SRADMIT=$SELECT(SRADMT=0:"0",1:"1")
- +14 SET SHEMP=SHEMP_$JUSTIFY($EXTRACT($PIECE($GET(^SRF(SRTN,0)),"^",26)),1)_SRADMIT
- DO OCC^SROATMNO
- SET SHEMP=SHEMP_SRTMP_$JUSTIFY(SROCTYPE,1)_$JUSTIFY(SROC(35),2)_$JUSTIFY(SROC(36),2)
- +15 ; date of birth
- SET NYUK=$EXTRACT($PIECE(VADM(3),"^"),1,7)
- SET SHEMP=SHEMP_$JUSTIFY(NYUK,7)
- +16 SET SHEMP=SHEMP_$JUSTIFY(SROC(38),2)_$JUSTIFY(SROC(39),2)_$JUSTIFY(SROC(40),2)_$JUSTIFY(SROC(41),2)_$JUSTIFY(SROC(42),2)
- KILL SROC,SROCTYPE,SRTMP
- +17 ;
- +18 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
- SET SHEMP=$EXTRACT(SHEMP,1,11)_" 4"
- SET SRACNT=SRACNT+1
- +19 FOR MOE=1:1:6
- SET CPT(MOE)=""
- +20 SET (X,CNT)=0
- FOR
- SET X=$ORDER(^SRF(SRTN,29,X))
- if 'X!(CNT=6)
- QUIT
- IF $PIECE(^SRF(SRTN,29,X,0),"^",3)="R"
- SET NYUK=$PIECE(^SRF(SRTN,29,X,0),"^")
- DO RETURN
- +21 SET SHEMP=SHEMP_$JUSTIFY(CNT,2)
- +22 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)
- +23 FOR MOE=1:1:6
- SET CPT(MOE)=""
- +24 SET (X,CNT)=0
- FOR
- SET X=$ORDER(^SRF(SRTN,29,X))
- if 'X!(CNT=6)
- QUIT
- IF $PIECE(^SRF(SRTN,29,X,0),"^",3)'="R"
- SET NYUK=$PIECE(^SRF(SRTN,29,X,0),"^")
- DO RETURN
- +25 SET SHEMP=SHEMP_$JUSTIFY(CNT,2)
- +26 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)
- +27 SET SRSDATE=$PIECE(^SRF(SRTN,0),"^",9)
- KILL SRSEP
- DO OCC^SROAUTL0
- if '$DATA(SRO)
- SET SRO=""
- SET $PIECE(SRO," ",205)=""
- SET SHEMP=SHEMP_$EXTRACT(SRO,1,112)
- +28 ;
- +29 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
- SET SHEMP=$EXTRACT(SHEMP,1,11)_" 5"
- SET SRACNT=SRACNT+1
- +30 SET NYUK=$PIECE(SRA(205),"^",6)
- DO ONE
- SET SHEMP=SHEMP_MOE
- SET NYUK=$PIECE(SRA(205),"^",7)
- DO ONE
- SET SHEMP=SHEMP_MOE
- SET NYUK=$PIECE(SRA(205),"^",8)
- DO ONE
- SET SHEMP=SHEMP_MOE
- SET NYUK=$PIECE(SRA(205),"^",10)
- DO ONE
- SET SHEMP=SHEMP_MOE
- +31 SET NYUK="N"
- IF $PIECE(SRA(205),"^",11)="Y"!($PIECE(SRA(205),"^",28)="Y")
- SET NYUK="Y"
- +32 DO ONE
- SET SHEMP=SHEMP_MOE
- SET NYUK=$PIECE(SRA(205),"^",12)
- DO ONE
- SET SHEMP=SHEMP_MOE
- SET NYUK=$PIECE(SRA(205),"^",13)
- DO ONE
- SET SHEMP=SHEMP_MOE
- SET NYUK=$PIECE($GET(SROOC(29)),U)
- +33 DO IFELSE
- +34 SET NYUK=$PIECE(SRA(205),"^",16)
- DO ONE
- SET SHEMP=SHEMP_MOE
- SET NYUK=$PIECE(SRA(205),"^",17)
- DO ONE
- SET SHEMP=SHEMP_MOE
- SET NYUK=$PIECE(SRA(205),"^",18)
- DO ONE
- SET SHEMP=SHEMP_MOE
- SET NYUK=$PIECE($GET(SROOC(31)),U)
- +35 DO IFELSE
- +36 NEW SRCVA
- DO CVA
- SET SHEMP=SHEMP_SRCVA
- +37 SET NYUK=$PIECE(SRA(205),"^",22)
- DO ONE
- SET SHEMP=SHEMP_MOE
- SET NYUK=$PIECE(SRA(205),"^",23)
- DO ONE
- SET SHEMP=SHEMP_MOE
- SET NYUK=$PIECE($GET(SROOC(30)),U)
- +38 DO IFELSE
- +39 SET NYUK=$PIECE(SRA(205),"^",26)
- DO ONE
- SET SHEMP=SHEMP_MOE
- SET NYUK=$PIECE(SRA(205),"^",27)
- DO ONE
- SET SHEMP=SHEMP_MOE_" "
- SET NYUK=$PIECE($GET(SROOC(32)),U)
- +40 DO IFELSE
- +41 SET NYUK=$PIECE(SRA(205),"^",31)
- DO ONE
- SET SHEMP=SHEMP_MOE
- SET NYUK=$PIECE(SRA(205),"^",32)
- DO ONE
- SET SHEMP=SHEMP_MOE
- SET NYUK=$PIECE(SRA(205),"^",33)
- DO ONE
- SET SHEMP=SHEMP_MOE
- SET NYUK=$PIECE(SRA(205),"^",34)
- DO ONE
- SET SHEMP=SHEMP_MOE
- +42 SET NYUK=$PIECE(SRA(205),"^",35)
- DO ONE
- SET SHEMP=SHEMP_MOE
- SET NYUK=$PIECE($GET(SROOC(21)),U)
- DO IFELSE
- +43 SET SHEMP=SHEMP_$EXTRACT(SRO,113,196)
- SET NYUK=$PIECE(SRA(205),"^",37)
- DO ONE
- SET SHEMP=SHEMP_MOE
- SET NYUK=$PIECE($GET(SROOC(36)),U)
- DO IFELSE
- +44 SET SHEMP=SHEMP_$JUSTIFY($EXTRACT(SRO,204),1)
- +45 SET NYUK=$PIECE(SRA(205),"^",39)
- DO ONE
- SET SHEMP=SHEMP_MOE_$JUSTIFY($EXTRACT(SRO,197,203),7)
- +46 SET NYUK=$PIECE(SRA(205),"^",42)
- DO ONE
- SET SHEMP=SHEMP_MOE
- SET NYUK=$PIECE(SRA(205),"^",43)
- DO ONE
- SET SHEMP=SHEMP_MOE
- +47 SET SHEMP=SHEMP_$JUSTIFY($EXTRACT(SRO,206,212),7)_$JUSTIFY($EXTRACT(SRO,213,219),7)_$JUSTIFY($EXTRACT(SRO,220,224),5)
- +48 SET NYUK=$PIECE(SRA(205),"^",44)
- DO ONE
- SET SHEMP=SHEMP_MOE_$JUSTIFY($EXTRACT(SRO,225,231),7)
- +49 ;
- +50 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
- SET SHEMP=$EXTRACT(SHEMP,1,11)_" 6"
- SET SRACNT=SRACNT+1
- +51 SET SHEMP=SHEMP_$JUSTIFY($PIECE(SRA(201),"^"),5)_$JUSTIFY($PIECE(SRA(202),"^"),7)_$JUSTIFY($PIECE(SRA(201),"^",8),4)_$JUSTIFY($PIECE(SRA(202),"^",8),7)_...
- ... $JUSTIFY($PIECE(SRA(201),"^",9),5)_$JUSTIFY($PIECE(SRA(202),"^",9),7)_$JUSTIFY($PIECE(SRA(201),"^",5),5)_$JUSTIFY($PIECE(SRA(202),"^",5),7)
- +52 SET SHEMP=SHEMP_$JUSTIFY($PIECE(SRA(201),"^",4),4)_$JUSTIFY($PIECE(SRA(202),"^",4),7)
- +53 SET SHEMP=SHEMP_$JUSTIFY($PIECE(SRA(201),"^",27),5)_$JUSTIFY($PIECE(SRA(202),"^",27),7)
- +54 SET SHEMP=SHEMP_$JUSTIFY($PIECE(SRA(203),"^",15),5)_$JUSTIFY($PIECE(SRA(204),"^",15),7)
- +55 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
- SET SHEMP=$EXTRACT(SHEMP,1,11)_" 7"
- SET SRACNT=SRACNT+1
- +56 SET SHEMP=SHEMP_$JUSTIFY($EXTRACT($PIECE(SRA(208),"^",14),1,12),12)_" "_$JUSTIFY($PIECE($GET(SRA(208)),"^",11),2)_$JUSTIFY($PIECE($GET(SRA(208)),"^",10),2)_$JUSTIFY($EXTRACT($PIECE($GET(SRA(208)),"^",9),1,4),4)
- +57 SET SHEMP=SHEMP_$JUSTIFY($EXTRACT($PIECE(SRA(208),"^",15),1,12),12)_" "_$JUSTIFY($PIECE($GET(SRA(206)),"^",3),2)_$JUSTIFY($PIECE($GET(SRA(206)),"^",4),2)_$JUSTIFY($PIECE($GET(SRA(206)),"^",8),2)_" "
- +58 SET SHEMP=SHEMP_$JUSTIFY($EXTRACT($PIECE(SRA(208),"^",16),1,12),12)_$JUSTIFY($EXTRACT($PIECE(SRA(208),"^",17),1,12),12)_$JUSTIFY($EXTRACT($PIECE(SRA(.2),"^",12),1,12),12)_$JUSTIFY($EXTRACT($PIECE(SRA(.2),"^"),1,12),12)
- +59 SET SHEMP=SHEMP_$JUSTIFY($EXTRACT($PIECE(SRA(1.1),"^",8),1,12),12)_$JUSTIFY($EXTRACT($PIECE(SRA(208.1),"^"),1,12),12)_$JUSTIFY($EXTRACT(...
- ... $PIECE(SRA(208.1),"^",2),1,12),12)_$JUSTIFY($EXTRACT($PIECE(SRA(208.1),"^",3),1,3),3)_$JUSTIFY(SRA("CON"),10)_$JUSTIFY($EXTRACT($PIECE(SRA(.2),"^",4),1,12),12)
- +60 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
- SET SHEMP=$EXTRACT(SHEMP,1,11)_" 8"
- SET SRACNT=SRACNT+1
- +61 SET SHEMP=SHEMP_$JUSTIFY($PIECE(SRA(201),"^",11),5)_$JUSTIFY($PIECE(SRA(202),"^",11),7)_$JUSTIFY($PIECE(SRA(201),"^",12),5)_...
- ... $JUSTIFY($PIECE(SRA(202),"^",12),7)_$JUSTIFY($PIECE(SRA(201),"^",13),4)_$JUSTIFY($PIECE(SRA(202),"^",13),7)_$JUSTIFY($PIECE(SRA(201),"^",14),4)_$JUSTIFY($PIECE(SRA(202),"^",14),7)
- +62 SET SHEMP=SHEMP_$JUSTIFY($PIECE(SRA(201),"^",15),5)_$JUSTIFY($PIECE(SRA(202),"^",15),7)
- +63 SET SHEMP=SHEMP_$JUSTIFY($PIECE(SRA(201),"^",28),6)_$JUSTIFY($PIECE(SRA(202.1),"^"),7)
- +64 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
- SET SHEMP=$EXTRACT(SHEMP,1,11)_" 9"
- SET SRACNT=SRACNT+1
- +65 DO ^SROATM3
- +66 QUIT
- ONE SET MOE=$SELECT(NYUK="NS":"S",NYUK="":" ",1:NYUK)
- +1 QUIT
- IFELSE IF NYUK["NO ICD"
- SET SHEMP=SHEMP_$JUSTIFY(" ",8)
- +1 IF '$TEST
- SET SHEMP=SHEMP_$JUSTIFY(NYUK,8)
- +2 QUIT
- CVA SET X=$PIECE(SRA(205),"^",21)
- SET SRCVA=$SELECT(X="Y":"Y",1:1)
- IF SRCVA=1
- QUIT
- +1 NEW SROCC
- SET SROCC=0
- FOR
- SET SROCC=$ORDER(^SRF(SRTN,16,SROCC))
- if 'SROCC
- QUIT
- IF $PIECE(^SRF(SRTN,16,SROCC,0),"^",2)=12
- SET X=$PIECE(^SRF(SRTN,16,SROCC,0),"^",8)
- if X'=""
- SET SRCVA=X
- QUIT
- +2 QUIT
- RS ; resident supervision (attending code)
- +1 NEW SRSR,SRX
- SET (SRATT,SRSR)=""
- SET SRX=$GET(^SRF(SRTN,.1))
- DO SRES
- +2 SET SRATT=$PIECE(SRX,"^",10)
- IF SRATT=""
- Begin DoDot:1
- +3 IF SRSR=0
- SET SRATT=$SELECT($PIECE(^SRF(SRTN,0),"^",9)<3040401:1,1:9)
- QUIT
- +4 SET SRATT=99
- End DoDot:1
- +5 QUIT
- SRES ; does site have residents?
- +1 NEW SRDIV,SRSITE,Y
- SET SRDIV=$PIECE($GET(^SRF(SRTN,8)),"^")
- IF SRDIV
- SET SRSITE=$ORDER(^SRO(133,"B",SRDIV,0))
- SET SRSR=$PIECE(^SRO(133,SRSITE,0),"^",19)
- +2 QUIT
- RETURN ; CPT of Returns
- +1 SET Y=$PIECE($GET(^SRO(136,NYUK,0)),"^",2)
- IF Y
- SET CNT=CNT+1
- SET CPT(CNT)=$PIECE($$CPT^ICPTCOD(Y),"^",2)
- +2 QUIT