- SROATMNO ;BIR/MAM - TRANSMIT NO ASSESSMENT ;09/12/2011
- ;;3.0;Surgery;**27,38,47,62,68,79,83,81,88,93,95,97,129,125,142,153,160,166,174,175,176,177,182,184,200**;24 Jun 93;Build 9
- ;** 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 SR1L,SR10SP,SRINTUB,SR95PO,SR95PO1,SRLO,SRPID,TDATE,SRDISP K ^TMP("SRA",$J) S SRATOT=0,SRASITE=+$P($$SITE^SROVAR,"^",3),(SRAMNUM,SRACNT)=1
- S Z=$E(DT,1,3)-2,SRLO=Z_"1215"
- S TDATE=0 F S TDATE=$O(^SRF("AQ",TDATE)) Q:TDATE="" I DT'<TDATE S SRTN=0 F S SRTN=$O(^SRF("AQ",TDATE,SRTN)) Q:'SRTN D SET
- S SRATOTM=SRAMNUM,SR1L=1 D ^SROATM4
- Q
- SET I $P($G(^SRF(SRTN,.4)),"^",2)="T"!(TDATE<SRLO) K ^SRF("AQ",TDATE,SRTN) Q
- I $P($G(^SRF(SRTN,"NON")),"^")="Y" K ^SRF("AQ",TDATE,SRTN) S $P(^SRF(SRTN,.4),"^",2)="" Q
- I $P($G(^SRF(SRTN,"RA")),"^",6)="Y",$P($G(^SRF(SRTN,"RA")),"^",2)="N" K ^SRF("AQ",TDATE,SRTN) Q
- I $P($G(^SRF(SRTN,0)),"^",9)="" K ^SRF("AQ",TDATE,SRTN) Q
- S SR10SP=" " K DA,DIE,DR S DA=SRTN,DIE=130,DR="905///R" D ^DIE K DR,DA,DIE
- S SRA(0)=^SRF(SRTN,0),DATE=$E($P(SRA(0),"^",9),1,7),SPEC=$P(SRA(0),"^",4) S:SPEC SPEC=$P(^DIC(45.3,$P(^SRO(137.45,SPEC,0),"^",2),0),"^")
- S EMERG=$P(SRA(0),"^",10),EMERG=$S(EMERG="EM":"Y",1:"N")
- K SRTECH,SRZ S SRT=0 F S SRT=$O(^SRF(SRTN,6,SRT)) Q:'SRT D ^SROPRIN Q:$D(SRZ)
- I $D(SRTECH) S SRINTUB=$P($G(^SRF(SRTN,6,SRT,8)),"^",2)
- I '$D(SRTECH) S (SRTECH,SRINTUB)=""
- S CPT=$P($G(^SRO(136,SRTN,0)),"^",2),SRPMOD="" I CPT S CPT=$P($$CPT^ICPTCOD(CPT),"^",2) D
- .S SRM=0,SRCNT=1 F S SRM=$O(^SRO(136,SRTN,1,SRM)) Q:'SRM D Q:SRCNT>5
- ..S X=$P(^SRO(136,SRTN,1,SRM,0),"^") I X S Y=$P($$MOD^ICPTMOD(X,"I"),"^",2),SRPMOD=SRPMOD_Y,SRCNT=SRCNT+1
- S DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRDOB=$E($P(VADM(3),"^"),1,7),SRDEATH=$P(VADM(6),U),SRSEX=$P(VADM(5),"^")
- 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)
- D RS^SROATM2
- S SRMAJMIN=$E($P($G(^SRF(SRTN,0)),U,3),1)
- S SRDTHUR=$E($P($G(^SRF(SRTN,.4)),U,7),1)
- S SRSTATUS=$S($P($G(^SRF(SRTN,208)),"^",14):"I",1:$E($P($G(^SRF(SRTN,0)),U,12),1))
- S (SRSDATE,VAIP("D"))=$P(SRA(0),"^",9) D IN5^VADPT S SRSTATUS=$S(VAIP(13):"I",1:"O")
- S SRDIS="" I VAIP(13) D ADM1^SROAPIMS S SRDIS=$G(SRVADPT(8)) K VAIP,SRVADPT
- S SRAGE="" I $P(VADM(3),"^") S SRAGE=$E(DATE,1,3)-$E($P(VADM(3),"^"),1,3)-($E(DATE,4,7)<$E($P(VADM(3),"^"),4,7))
- S SRASA="",Y=$P($G(^SRF(SRTN,1.1)),"^",3) S:Y X=$P($G(^SRO(132.8,Y,0)),"^"),SRASA=$E(X,1,2)
- ; Admission wi 14 days following outpatient surgery due to an Occurrence
- S (SRADMIT,SRADMT)=0 I SRSTATUS="O" D ADM^SROQ0A S SRADMIT=$S(SRADMT=0:"0",1:"1")
- S EXC=$P($G(^SRF(SRTN,"RA")),"^",7),SRWOUND=$P($G(^SRF(SRTN,"1.0")),"^",8)
- D OCC
- S SRNODE=" X" S:$P($G(^SRF(SRTN,"RA")),U,6)="N" SRNODE=" *" S:$P($G(^SRF(SRTN,"RA")),U,2)="C" SRNODE=" C"
- ;
- S SRTEMP="@"_$J(SRASITE,3)_$J(SRTN,7)_SRNODE_$J(DATE,7)_$J(SRTECH,3)_$J(EMERG,1)_$J(SPEC,3)_$J(CPT,5)_$J(EXC,1)_$J(SRPID,20)_$J(SRDIV,6)_$J(SRSEX,1)
- S SRTEMP=SRTEMP_$J(SRMAJMIN,1)_$J($E(SRDEATH,1,7),7)_$J(SRDTHUR,1)_$J(SRSTATUS,1)_$J(SRAGE,3)_$J(SRASA,2)_$J(SRADMIT,1)_SRTMP
- K CPT,SRMOD F SRZ=1:1:10 S (CPT(SRZ),SRMOD(SRZ))=""
- 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 MOD
- S SRCC=$P($G(^SRF(SRTN,"CON")),"^"),SRBLANK=" "
- I SRCC,$P($G(^SRF(SRCC,30)),"^")!($P($G(^SRF(SRCC,31)),"^",8)) S SRCC=""
- S SRTEMP=SRTEMP_$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)_$J(SRWOUND,2)_$J(SROCTYPE,1)_SRBLANK_$J(SRCC,10)_$J($E(SRDEATH,1,12),12)_$J($E(SRDIS,1,12),12)
- S Y=$P(^SRF(SRTN,0),"^",26)
- S SRTEMP=SRTEMP_$J($P($G(^SRF(SRTN,30)),"^",6),1)_$J($P($G(^SRF(SRTN,.1)),"^",21),1)_$J(Y,1)
- N SROBOT S SROBOT=$P($G(^SRF(SRTN,"OP")),U,3),SRTEMP=SRTEMP_$J(SROBOT,2)
- ;
- S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRTEMP,SRACNT=SRACNT+1
- S SRICD=$P($G(^SRO(136,SRTN,0)),"^",3) S:SRICD SRICD=$P($$ICD^SROICD(SRTN,SRICD),"^",2)
- N SRCVA D CVA S SRA(.2)=$G(^SRF(SRTN,.2))
- S SRTEMP="@"_$J(SRASITE,3)_$J(SRTN,7)_" B"_$J($E($P(SRA(.2),"^"),1,12),12)_$J($E($P(SRA(.2),"^",4),1,12),12)_$E(SRPMOD_SR10SP,1,10)
- F I=1:1:10 S SRTEMP=SRTEMP_$E(SRMOD(I)_SR10SP,1,10)
- S SRTEMP=SRTEMP_$J(SRINTUB,1)_SR95PO_$J(SRATT,2)_$J(SRDOB,7)_$J(SRICD,8)_$J(SROC(38),2)_$J(SROC(39),2)
- S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRTEMP_$J($P(SRA(.2),"^",10),12)_$J($P(SRA(.2),"^",12),12)_$J($P(SRA(.2),"^",2),12)_$J($P(SRA(.2),"^",3),12)_$J(SRCVA,1),SRACNT=SRACNT+1
- S SRA(.9)=$G(^SRF(SRTN,.9)),SRA("VER")=$G(^SRF(SRTN,"VER")),SRA(52)=$G(^SRF(SRTN,52))
- S SRTEMP="@"_$J(SRASITE,3)_$J(SRTN,7)_" D"_$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)
- S SRTEMP=SRTEMP_$J($E($P($G(^SRF(SRTN,30)),"^"),1,12),12)_$J($P($G(^SRF(SRTN,31)),"^",8),4)_$J($P($G(^SRF(SRTN,30)),"^",4),50)
- F I=7:1:18 S SRTEMP=SRTEMP_$J($P(SRA("VER"),"^",I),2)
- S SROR="",Y=$P(^SRF(SRTN,0),"^",2),C=$P(^DD(130,.02,0),"^",2) I Y'="" D Y^DIQ S SROR=Y
- S SRTEMP=SRTEMP_$J($E(SROR,1,30),30) F I=1:1:6 S SRTEMP=SRTEMP_$J($P(SRA(52),"^",I),2)
- S SRDISP=$P($G(^SRF(SRTN,.4)),"^",6) S:SRDISP SRDISP=$P($G(^SRO(131.6,SRDISP,0)),"^",2)
- S SRTEMP=SRTEMP_$$ADD182^SROATCM1(SRTN)_$J($P($G(^SRF(SRTN,30)),"^",5),1)_$J(SRDISP,3)_SR95PO1
- S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRTEMP,SRACNT=SRACNT+1
- D ^SROATMN1
- I SRACNT>100 S SRACNT=1,SRAMNUM=SRAMNUM+1
- S SRATOT=SRATOT+1
- S X=$E($P(^SRF(SRTN,0),"^",9),1,5)_"00",^TMP("SRWL",$J,X)=""
- K DATE,ANES,EMERG,EXC,SPEC,SRADMIT,SRADMT,SRATT,SRBLANK,SRCC,SRDIV,SRDOB,SRDTHUR,SRICD,SRIO,SRMAJMIN,SROCTYPE,SROR,SRSEX,SRTEMP,SRTMP,SRWOUND,SRZ,SR14,CPT
- Q
- OCC ; total of each occurrence by category
- N SRIOFLAG,SRPOFLAG
- F SRK=1:1:42 S SROC(SRK)=""
- S (SRPO,SRIOFLAG)=0 F S SRPO=$O(^SRF(SRTN,10,SRPO)) Q:'SRPO S SRSUB=$P(^SRF(SRTN,10,SRPO,0),U,2) I SRSUB'="" D
- .S SROC(SRSUB)=SROC(SRSUB)+1,SRIOFLAG=1
- S (SRPO,SRPOFLAG)=0 F S SRPO=$O(^SRF(SRTN,16,SRPO)) Q:'SRPO S SRSUB=$P(^SRF(SRTN,16,SRPO,0),U,2) I SRSUB'="" D
- .S SROC(SRSUB)=SROC(SRSUB)+1,SRPOFLAG=1
- S (SROCTYPE,SRTMP)="" F SRK=1:1:10 S SRTMP=SRTMP_$J(SROC(SRK),2)
- S SRTMP=SRTMP_$J(SROC(37),2) F SRK=12:1:32 S SRTMP=SRTMP_$J(SROC(SRK),2)
- S SR95PO=$J(SROC(33),2)_$J(SROC(34),2)_$J(SROC(35),2)_$J(SROC(36),2)
- S SR95PO1=$J(SROC(40),2)_$J(SROC(41),2)_$J(SROC(42),2)
- I SRIOFLAG=1,(SRPOFLAG=0) S SROCTYPE="I"
- I SRIOFLAG=0,(SRPOFLAG=1) S SROCTYPE="P"
- I SRIOFLAG=1,(SRPOFLAG=1) S SROCTYPE="B"
- I SRIOFLAG=0,(SRPOFLAG=0) S SROCTYPE=""
- Q
- MOD N SRM S SRM=0,SRCNT=1 F S SRM=$O(^SRO(136,SRTN,3,OPS,1,SRM)) Q:'SRM D Q:SRCNT>5
- .S X=$P(^SRO(136,SRTN,3,OPS,1,SRM,0),"^"),Y=$P($$MOD^ICPTMOD(X,"I"),"^",2)
- .I Y'="" S SRMOD(CNT)=SRMOD(CNT)_Y,SRCNT=SRCNT+1
- Q
- CVA S X=$P($G(^SRF(SRTN,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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROATMNO 7296 printed Jan 18, 2025@03:43:25 Page 2
- SROATMNO ;BIR/MAM - TRANSMIT NO ASSESSMENT ;09/12/2011
- +1 ;;3.0;Surgery;**27,38,47,62,68,79,83,81,88,93,95,97,129,125,142,153,160,166,174,175,176,177,182,184,200**;24 Jun 93;Build 9
- +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 SR1L,SR10SP,SRINTUB,SR95PO,SR95PO1,SRLO,SRPID,TDATE,SRDISP
- KILL ^TMP("SRA",$JOB)
- SET SRATOT=0
- SET SRASITE=+$PIECE($$SITE^SROVAR,"^",3)
- SET (SRAMNUM,SRACNT)=1
- +9 SET Z=$EXTRACT(DT,1,3)-2
- SET SRLO=Z_"1215"
- +10 SET TDATE=0
- FOR
- SET TDATE=$ORDER(^SRF("AQ",TDATE))
- if TDATE=""
- QUIT
- IF DT'<TDATE
- SET SRTN=0
- FOR
- SET SRTN=$ORDER(^SRF("AQ",TDATE,SRTN))
- if 'SRTN
- QUIT
- DO SET
- +11 SET SRATOTM=SRAMNUM
- SET SR1L=1
- DO ^SROATM4
- +12 QUIT
- SET IF $PIECE($GET(^SRF(SRTN,.4)),"^",2)="T"!(TDATE<SRLO)
- KILL ^SRF("AQ",TDATE,SRTN)
- QUIT
- +1 IF $PIECE($GET(^SRF(SRTN,"NON")),"^")="Y"
- KILL ^SRF("AQ",TDATE,SRTN)
- SET $PIECE(^SRF(SRTN,.4),"^",2)=""
- QUIT
- +2 IF $PIECE($GET(^SRF(SRTN,"RA")),"^",6)="Y"
- IF $PIECE($GET(^SRF(SRTN,"RA")),"^",2)="N"
- KILL ^SRF("AQ",TDATE,SRTN)
- QUIT
- +3 IF $PIECE($GET(^SRF(SRTN,0)),"^",9)=""
- KILL ^SRF("AQ",TDATE,SRTN)
- QUIT
- +4 SET SR10SP=" "
- KILL DA,DIE,DR
- SET DA=SRTN
- SET DIE=130
- SET DR="905///R"
- DO ^DIE
- KILL DR,DA,DIE
- +5 SET SRA(0)=^SRF(SRTN,0)
- SET DATE=$EXTRACT($PIECE(SRA(0),"^",9),1,7)
- SET SPEC=$PIECE(SRA(0),"^",4)
- if SPEC
- SET SPEC=$PIECE(^DIC(45.3,$PIECE(^SRO(137.45,SPEC,0),"^",2),0),"^")
- +6 SET EMERG=$PIECE(SRA(0),"^",10)
- SET EMERG=$SELECT(EMERG="EM":"Y",1:"N")
- +7 KILL SRTECH,SRZ
- SET SRT=0
- FOR
- SET SRT=$ORDER(^SRF(SRTN,6,SRT))
- if 'SRT
- QUIT
- DO ^SROPRIN
- if $DATA(SRZ)
- QUIT
- +8 IF $DATA(SRTECH)
- SET SRINTUB=$PIECE($GET(^SRF(SRTN,6,SRT,8)),"^",2)
- +9 IF '$DATA(SRTECH)
- SET (SRTECH,SRINTUB)=""
- +10 SET CPT=$PIECE($GET(^SRO(136,SRTN,0)),"^",2)
- SET SRPMOD=""
- IF CPT
- SET CPT=$PIECE($$CPT^ICPTCOD(CPT),"^",2)
- Begin DoDot:1
- +11 SET SRM=0
- SET SRCNT=1
- FOR
- SET SRM=$ORDER(^SRO(136,SRTN,1,SRM))
- if 'SRM
- QUIT
- Begin DoDot:2
- +12 SET X=$PIECE(^SRO(136,SRTN,1,SRM,0),"^")
- IF X
- SET Y=$PIECE($$MOD^ICPTMOD(X,"I"),"^",2)
- SET SRPMOD=SRPMOD_Y
- SET SRCNT=SRCNT+1
- End DoDot:2
- if SRCNT>5
- QUIT
- End DoDot:1
- +13 SET DFN=$PIECE(SRA(0),"^")
- NEW I
- DO DEM^VADPT
- SET SRDOB=$EXTRACT($PIECE(VADM(3),"^"),1,7)
- SET SRDEATH=$PIECE(VADM(6),U)
- SET SRSEX=$PIECE(VADM(5),"^")
- +14 ; remove hyphens from PID
- SET SRPID=VA("PID")
- SET SRPID=$TRANSLATE(SRPID,"-","")
- +15 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)
- +16 DO RS^SROATM2
- +17 SET SRMAJMIN=$EXTRACT($PIECE($GET(^SRF(SRTN,0)),U,3),1)
- +18 SET SRDTHUR=$EXTRACT($PIECE($GET(^SRF(SRTN,.4)),U,7),1)
- +19 SET SRSTATUS=$SELECT($PIECE($GET(^SRF(SRTN,208)),"^",14):"I",1:$EXTRACT($PIECE($GET(^SRF(SRTN,0)),U,12),1))
- +20 SET (SRSDATE,VAIP("D"))=$PIECE(SRA(0),"^",9)
- DO IN5^VADPT
- SET SRSTATUS=$SELECT(VAIP(13):"I",1:"O")
- +21 SET SRDIS=""
- IF VAIP(13)
- DO ADM1^SROAPIMS
- SET SRDIS=$GET(SRVADPT(8))
- KILL VAIP,SRVADPT
- +22 SET SRAGE=""
- IF $PIECE(VADM(3),"^")
- SET SRAGE=$EXTRACT(DATE,1,3)-$EXTRACT($PIECE(VADM(3),"^"),1,3)-($EXTRACT(DATE,4,7)<$EXTRACT($PIECE(VADM(3),"^"),4,7))
- +23 SET SRASA=""
- SET Y=$PIECE($GET(^SRF(SRTN,1.1)),"^",3)
- if Y
- SET X=$PIECE($GET(^SRO(132.8,Y,0)),"^")
- SET SRASA=$EXTRACT(X,1,2)
- +24 ; Admission wi 14 days following outpatient surgery due to an Occurrence
- +25 SET (SRADMIT,SRADMT)=0
- IF SRSTATUS="O"
- DO ADM^SROQ0A
- SET SRADMIT=$SELECT(SRADMT=0:"0",1:"1")
- +26 SET EXC=$PIECE($GET(^SRF(SRTN,"RA")),"^",7)
- SET SRWOUND=$PIECE($GET(^SRF(SRTN,"1.0")),"^",8)
- +27 DO OCC
- +28 SET SRNODE=" X"
- if $PIECE($GET(^SRF(SRTN,"RA")),U,6)="N"
- SET SRNODE=" *"
- if $PIECE($GET(^SRF(SRTN,"RA")),U,2)="C"
- SET SRNODE=" C"
- +29 ;
- +30 SET SRTEMP="@"_$JUSTIFY(SRASITE,3)_$JUSTIFY(SRTN,7)_SRNODE_$JUSTIFY(DATE,7)_$JUSTIFY(SRTECH,3)_$JUSTIFY(EMERG,1)_$JUSTIFY(SPEC,3)_$JUSTIFY(CPT,5)_$JUSTIFY(EXC,1)_$JUSTIFY(SRPID,20)_$JUSTIFY(SRDIV,6)_$JUSTIFY(SRSEX,1)
- +31 SET SRTEMP=SRTEMP_$JUSTIFY(SRMAJMIN,1)_$JUSTIFY($EXTRACT(SRDEATH,1,7),7)_$JUSTIFY(SRDTHUR,1)_$JUSTIFY(SRSTATUS,1)_$JUSTIFY(SRAGE,3)_$JUSTIFY(SRASA,2)_$JUSTIFY(SRADMIT,1)_SRTMP
- +32 KILL CPT,SRMOD
- FOR SRZ=1:1:10
- SET (CPT(SRZ),SRMOD(SRZ))=""
- +33 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 MOD
- +34 SET SRCC=$PIECE($GET(^SRF(SRTN,"CON")),"^")
- SET SRBLANK=" "
- +35 IF SRCC
- IF $PIECE($GET(^SRF(SRCC,30)),"^")!($PIECE($GET(^SRF(SRCC,31)),"^",8))
- SET SRCC=""
- +36 SET SRTEMP=SRTEMP_$JUSTIFY(CPT(1),5)_$JUSTIFY(CPT(2),5)_...
- SET $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)_...
- ... $JUSTIFY(SRWOUND,2)_$JUSTIFY(SROCTYPE,1)_SRBLANK_$JUSTIFY(SRCC,10)_$JUSTIFY($EXTRACT(SRDEATH,1,12),12)_$JUSTIFY($EXTRACT(SRDIS,1,12),12)
- +37 SET Y=$PIECE(^SRF(SRTN,0),"^",26)
- +38 SET SRTEMP=SRTEMP_$JUSTIFY($PIECE($GET(^SRF(SRTN,30)),"^",6),1)_$JUSTIFY($PIECE($GET(^SRF(SRTN,.1)),"^",21),1)_$JUSTIFY(Y,1)
- +39 NEW SROBOT
- SET SROBOT=$PIECE($GET(^SRF(SRTN,"OP")),U,3)
- SET SRTEMP=SRTEMP_$JUSTIFY(SROBOT,2)
- +40 ;
- +41 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SRTEMP
- SET SRACNT=SRACNT+1
- +42 SET SRICD=$PIECE($GET(^SRO(136,SRTN,0)),"^",3)
- if SRICD
- SET SRICD=$PIECE($$ICD^SROICD(SRTN,SRICD),"^",2)
- +43 NEW SRCVA
- DO CVA
- SET SRA(.2)=$GET(^SRF(SRTN,.2))
- +44 SET SRTEMP="@"_$JUSTIFY(SRASITE,3)_$JUSTIFY(SRTN,7)_" B"_$JUSTIFY($EXTRACT($PIECE(SRA(.2),"^"),1,12),12)_$JUSTIFY($EXTRACT($PIECE(SRA(.2),"^",4),1,12),12)_$EXTRACT(SRPMOD_SR10SP,1,10)
- +45 FOR I=1:1:10
- SET SRTEMP=SRTEMP_$EXTRACT(SRMOD(I)_SR10SP,1,10)
- +46 SET SRTEMP=SRTEMP_$JUSTIFY(SRINTUB,1)_SR95PO_$JUSTIFY(SRATT,2)_$JUSTIFY(SRDOB,7)_$JUSTIFY(SRICD,8)_$JUSTIFY(SROC(38),2)_$JUSTIFY(SROC(39),2)
- +47 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SRTEMP_$JUSTIFY($PIECE(SRA(.2),"^",10),12)_$JUSTIFY($PIECE(SRA(.2),"^",12),12)_$JUSTIFY($PIECE(SRA(.2),"^",2),12)_$JUSTIFY($PIECE(SRA(.2),"^",3),12)_$JUSTIFY(SRCVA,1)
- SET SRACNT=SRACNT+1
- +48 SET SRA(.9)=$GET(^SRF(SRTN,.9))
- SET SRA("VER")=$GET(^SRF(SRTN,"VER"))
- SET SRA(52)=$GET(^SRF(SRTN,52))
- +49 SET SRTEMP="@"_$JUSTIFY(SRASITE,3)_$JUSTIFY(SRTN,7)_" D"_$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)
- +50 SET SRTEMP=SRTEMP_$JUSTIFY($EXTRACT($PIECE($GET(^SRF(SRTN,30)),"^"),1,12),12)_$JUSTIFY($PIECE($GET(^SRF(SRTN,31)),"^",8),4)_$JUSTIFY($PIECE($GET(^SRF(SRTN,30)),"^",4),50)
- +51 FOR I=7:1:18
- SET SRTEMP=SRTEMP_$JUSTIFY($PIECE(SRA("VER"),"^",I),2)
- +52 SET SROR=""
- SET Y=$PIECE(^SRF(SRTN,0),"^",2)
- SET C=$PIECE(^DD(130,.02,0),"^",2)
- IF Y'=""
- DO Y^DIQ
- SET SROR=Y
- +53 SET SRTEMP=SRTEMP_$JUSTIFY($EXTRACT(SROR,1,30),30)
- FOR I=1:1:6
- SET SRTEMP=SRTEMP_$JUSTIFY($PIECE(SRA(52),"^",I),2)
- +54 SET SRDISP=$PIECE($GET(^SRF(SRTN,.4)),"^",6)
- if SRDISP
- SET SRDISP=$PIECE($GET(^SRO(131.6,SRDISP,0)),"^",2)
- +55 SET SRTEMP=SRTEMP_$$ADD182^SROATCM1(SRTN)_$JUSTIFY($PIECE($GET(^SRF(SRTN,30)),"^",5),1)_$JUSTIFY(SRDISP,3)_SR95PO1
- +56 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SRTEMP
- SET SRACNT=SRACNT+1
- +57 DO ^SROATMN1
- +58 IF SRACNT>100
- SET SRACNT=1
- SET SRAMNUM=SRAMNUM+1
- +59 SET SRATOT=SRATOT+1
- +60 SET X=$EXTRACT($PIECE(^SRF(SRTN,0),"^",9),1,5)_"00"
- SET ^TMP("SRWL",$JOB,X)=""
- +61 KILL DATE,ANES,EMERG,EXC,SPEC,SRADMIT,SRADMT,SRATT,SRBLANK,SRCC,SRDIV,SRDOB,SRDTHUR,SRICD,SRIO,SRMAJMIN,SROCTYPE,SROR,SRSEX,SRTEMP,SRTMP,SRWOUND,SRZ,SR14,CPT
- +62 QUIT
- OCC ; total of each occurrence by category
- +1 NEW SRIOFLAG,SRPOFLAG
- +2 FOR SRK=1:1:42
- SET SROC(SRK)=""
- +3 SET (SRPO,SRIOFLAG)=0
- FOR
- SET SRPO=$ORDER(^SRF(SRTN,10,SRPO))
- if 'SRPO
- QUIT
- SET SRSUB=$PIECE(^SRF(SRTN,10,SRPO,0),U,2)
- IF SRSUB'=""
- Begin DoDot:1
- +4 SET SROC(SRSUB)=SROC(SRSUB)+1
- SET SRIOFLAG=1
- End DoDot:1
- +5 SET (SRPO,SRPOFLAG)=0
- FOR
- SET SRPO=$ORDER(^SRF(SRTN,16,SRPO))
- if 'SRPO
- QUIT
- SET SRSUB=$PIECE(^SRF(SRTN,16,SRPO,0),U,2)
- IF SRSUB'=""
- Begin DoDot:1
- +6 SET SROC(SRSUB)=SROC(SRSUB)+1
- SET SRPOFLAG=1
- End DoDot:1
- +7 SET (SROCTYPE,SRTMP)=""
- FOR SRK=1:1:10
- SET SRTMP=SRTMP_$JUSTIFY(SROC(SRK),2)
- +8 SET SRTMP=SRTMP_$JUSTIFY(SROC(37),2)
- FOR SRK=12:1:32
- SET SRTMP=SRTMP_$JUSTIFY(SROC(SRK),2)
- +9 SET SR95PO=$JUSTIFY(SROC(33),2)_$JUSTIFY(SROC(34),2)_$JUSTIFY(SROC(35),2)_$JUSTIFY(SROC(36),2)
- +10 SET SR95PO1=$JUSTIFY(SROC(40),2)_$JUSTIFY(SROC(41),2)_$JUSTIFY(SROC(42),2)
- +11 IF SRIOFLAG=1
- IF (SRPOFLAG=0)
- SET SROCTYPE="I"
- +12 IF SRIOFLAG=0
- IF (SRPOFLAG=1)
- SET SROCTYPE="P"
- +13 IF SRIOFLAG=1
- IF (SRPOFLAG=1)
- SET SROCTYPE="B"
- +14 IF SRIOFLAG=0
- IF (SRPOFLAG=0)
- SET SROCTYPE=""
- +15 QUIT
- MOD NEW SRM
- SET SRM=0
- SET SRCNT=1
- FOR
- SET SRM=$ORDER(^SRO(136,SRTN,3,OPS,1,SRM))
- if 'SRM
- QUIT
- Begin DoDot:1
- +1 SET X=$PIECE(^SRO(136,SRTN,3,OPS,1,SRM,0),"^")
- SET Y=$PIECE($$MOD^ICPTMOD(X,"I"),"^",2)
- +2 IF Y'=""
- SET SRMOD(CNT)=SRMOD(CNT)_Y
- SET SRCNT=SRCNT+1
- End DoDot:1
- if SRCNT>5
- QUIT
- +3 QUIT
- CVA SET X=$PIECE($GET(^SRF(SRTN,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