SROATCM ;BIR/MAM - TRANSMIT CARDIAC ASSESSMENTS ;03/02/06
;;3.0;Surgery;**38,55,68,90,93,95,99,125,153,174,175,177,182,184**;24 Jun 93;Build 35
;
; Reference to ^DGPM("APTT1" supported by DBIA #565
; Reference to File #405 supported by DBIA #3029
; Reference to Field #27.02 in File #2 supported by DBIA #1850
;
K ^TMP("SRA",$J) S SRATOT=0,SRASITE=+$P($$SITE^SROVAR,"^",3),(SRAMNUM,SRACNT)=1
S SRADFN=0 F S SRADFN=$O(^SRF("ARS","C","C",SRADFN)) Q:'SRADFN S SRTN=0 F S SRTN=$O(^SRF("ARS","C","C",SRADFN,SRTN)) Q:'SRTN D STUFF
S SRATOTM=SRAMNUM D ^SROATCM2
Q
STUFF ; stuff entries into ^TMP("SRA",$J
; check for fouled up ARS x ref
I $P(^SRF(SRTN,"RA"),"^",2)="N" K ^SRF("ARS","C","C",SRADFN,SRTN) K DR S DIE=130,DR="235///C",DA=SRTN D ^DIE K DR Q
; the next line is commented out to allow re-transmissions
;S SRART=$P(^SRF(SRTN,"RA"),"^",3) I SRART S DIE=130,DR="235///T",DA=SRTN D ^DIE K DR,DA,DIE Q
I $P(^SRF(SRTN,"RA"),"^",2)'="C" Q
I SRACNT>100 S SRACNT=1,SRAMNUM=SRAMNUM+1
S SRATOT=SRATOT+1 K SRA,VADM
F I=0,200,205:1:208 S SRA(I)=$G(SRF(SRTN,I))
D ^SROATCM1,P93
K SHEMP,SRA,VADM,VAPA
S X=$E($P(^SRF(SRTN,0),"^",9),1,5)_"00",^TMP("SRWL",$J,X)=""
Q
P93 ; referring & follow-up sites, patient address & phone number
N SRPREF,SRREF,SRREFP,SRFOL,SRFOLP,SRSOUT,SRY S (SRPREF,SRREF,SRREFP,SRFOL,SRFOLP)="",SRSOUT=0,(VAIP("D"),SRSDATE)=$P(SRA(0),"^",9) D IN5^VADPT
; if not admitted before surgery, look for admission within 24 hours of leaving OR
I 'VAIP(13) S X1=$P($G(^SRF(SRTN,.2)),"^",12),X2=1 D C^%DTC S SR24=X,SRDT=$O(^DGPM("APTT1",DFN,SRSDATE)) G:'SRDT!(SRDT>SR24) TS S VAIP("D")=SRDT D IN5^VADPT
TS I VAIP(13) K DA,DIC,DIQ,DR S DIC=405,DR=.05,DA=VAIP(13),DIQ="SRY",DIQ(0)="IE" D EN^DIQ1 S SRREF=SRY(405,VAIP(13),.05,"E"),SRREFP=SRY(405,VAIP(13),.05,"I") I SRREFP S SRREFP=$$GET1^DIQ(4,SRREFP,99)
I VAIP(17) K DA,DIC,DIQ,DR,SRY S DIC=405,DR=.05,DA=VAIP(17),DIQ="SRY",DIQ(0)="IE" D EN^DIQ1 S SRFOL=SRY(405,VAIP(17),.05,"E"),SRFOLP=SRY(405,VAIP(17),.05,"I") I SRFOLP S SRFOLP=$$GET1^DIQ(4,SRFOLP,99)
S SHEMP=$E(SHEMP,1,11)_" 18"_$J(VAPA(1),35)_$J(VAPA(2),30),^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
S SHEMP=$E(SHEMP,1,11)_" 19"_$J(VAPA(3),30)_$J(VAPA(4),15)
K DA,DIC,DIQ,DR,SRY S X=$P(VAPA(5),"^") I X S DIC=5,DA=X,DR=1,DIQ="SRY",DIQ(0)="E" D EN^DIQ1 S X=SRY(5,$P(VAPA(5),"^"),1,"E")
S SHEMP=SHEMP_$J(X,5),^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1,SHEMP=$E(SHEMP,1,11)_" 20"_$J(VAPA(8),20)_$J($TR(SRREF,","," "),30)_$J(SRREFP,6)
K DA,DIC,DIQ,DR,SRY S DIC="^DPT(",DIQ="SRY",DIQ(0)="I",DA=DFN,DR=27.02 D EN^DIQ1 S X=$G(SRY(2,DFN,27.02,"I")) I X S SRPREF=$$GET1^DIQ(4,X,99)
S SHEMP=SHEMP_$J(SRPREF,6)
S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1,SHEMP=$E(SHEMP,1,11)_" 21"_$J($TR(SRFOL,","," "),30)_$J(SRFOLP,6)
S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
S SHEMP=$E(SHEMP,1,11)_" 22"_$J($P(SRA(201),"^",21),6)_$J($P(SRA(202),"^",21),7)_$J($P(SRA(201),"^",22),6)_$J($P(SRA(202),"^",22),7)
S SHEMP=SHEMP_$J($P(SRA(201),"^",23),6)_$J($P(SRA(202),"^",23),7)_$J($P(SRA(201),"^",24),6)_$J($P(SRA(202),"^",24),7)
S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
;
S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT S SHEMP=$E(SHEMP,1,11)_" 23"_$J($P(SRA(201),"^",25),6)_$J($P(SRA(202),"^",25),7)_$J($P(SRA(201),"^",26),6)_$J($P(SRA(202),"^",26),7)_$J($P(VADM(3),"^"),7) K VADM
S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP_$$ADD182^SROATCM1(SRTN),SRACNT=SRACNT+1
S SHEMP=$E(SHEMP,1,11)_" 24"_$J($P(SRA(208),"^",10),2)_$J($P(SRA(200),"^",57),2)_$J($P(SRA(207),"^",24),2)_$J($P(SRA(207),"^",25),2)_$J($P(SRA(206),"^",39),2)
N SR22,SR23 S SR22=$P(SRA(208),"^",22),SR23=$P(SRA(208),"^",23)
N SRIP1,SRIP2 S (SRIP1,SRIP2)=""
D NMCS S SHEMP=SHEMP_$J(SRIP,2)_$J(" ",2)_$S(SR22:$J(SR22,12,4),1:$J(SR22,12))_$S(SR23:$J(SR23,12,4),1:$J(SR23,12))_$J($P(SRA(206),"^",41),2)
S SHEMP=SHEMP_$J($P(SRA(207),"^",26),3)
;
N VAINDT,SRPTF,SRRES,SRDISTYP
S VAINDT=$P(SRA(208),"^",15)-.0001 D INP^VADPT S SRPTF=VAIN(10)
S SRRES="" D RPC^DGPTFAPI(.SRRES,SRPTF)
S SRRES(0)=$G(SRRES(0)),SRRES(1)=$G(SRRES(1)),SRRES(2)=$G(SRRES(2))
S SRDISTYP=$P(SRRES(1),U)
I SRDISTYP]"" S SRDISTYP=$S(SRDISTYP="REGULAR":1,SRDISTYP="NBC OR WHILE ASIH":2,SRDISTYP="EXPIRATION 6 MONTH LIMIT":3,SRDISTYP="IRREGULAR":4,SRDISTYP="TRANSFER":5,SRDISTYP="DEATH WITH AUTOPSY":6,SRDISTYP="DEATH WITHOUT AUTOPSY":7,1:"")
S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP_$J($P(SRRES(1),U,3),8)_$J($P(SRA(205),"^",40),2)_$J(SRIP1,1)_$J(SRIP2,1)_$J($P($G(^SRF(SRTN,.1)),"^",21),1)
S SRACNT=SRACNT+1,SHEMP=$E(SHEMP,1,11)_" 25"_$J(SRDISTYP,2) I $D(SRRES(2)) F I=1:1:7 S SHEMP=SHEMP_$J($P(SRRES(2),"^",I),8)
S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
D ^SROATCM3
Q
NMCS S SRIP=$P(SRA(206),"^",40) I SRIP'="Y" Q
N SROCC
S SROCC=0 F S SROCC=$O(^SRF(SRTN,10,SROCC)) Q:'SROCC I $P(^SRF(SRTN,10,SROCC,0),"^",2)=34 S SRIP="I",SRIP1=$P(^SRF(SRTN,10,SROCC,0),"^",7) Q
S SROCC=0 F S SROCC=$O(^SRF(SRTN,16,SROCC)) Q:'SROCC I $P(^SRF(SRTN,16,SROCC,0),"^",2)=34 S:SRIP="Y" SRIP="P" S SRIP2=$P(^SRF(SRTN,16,SROCC,0),"^",14) Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROATCM 5126 printed Sep 23, 2025@20:18:30 Page 2
SROATCM ;BIR/MAM - TRANSMIT CARDIAC ASSESSMENTS ;03/02/06
+1 ;;3.0;Surgery;**38,55,68,90,93,95,99,125,153,174,175,177,182,184**;24 Jun 93;Build 35
+2 ;
+3 ; Reference to ^DGPM("APTT1" supported by DBIA #565
+4 ; Reference to File #405 supported by DBIA #3029
+5 ; Reference to Field #27.02 in File #2 supported by DBIA #1850
+6 ;
+7 KILL ^TMP("SRA",$JOB)
SET SRATOT=0
SET SRASITE=+$PIECE($$SITE^SROVAR,"^",3)
SET (SRAMNUM,SRACNT)=1
+8 SET SRADFN=0
FOR
SET SRADFN=$ORDER(^SRF("ARS","C","C",SRADFN))
if 'SRADFN
QUIT
SET SRTN=0
FOR
SET SRTN=$ORDER(^SRF("ARS","C","C",SRADFN,SRTN))
if 'SRTN
QUIT
DO STUFF
+9 SET SRATOTM=SRAMNUM
DO ^SROATCM2
+10 QUIT
STUFF ; stuff entries into ^TMP("SRA",$J
+1 ; check for fouled up ARS x ref
+2 IF $PIECE(^SRF(SRTN,"RA"),"^",2)="N"
KILL ^SRF("ARS","C","C",SRADFN,SRTN)
KILL DR
SET DIE=130
SET DR="235///C"
SET DA=SRTN
DO ^DIE
KILL DR
QUIT
+3 ; the next line is commented out to allow re-transmissions
+4 ;S SRART=$P(^SRF(SRTN,"RA"),"^",3) I SRART S DIE=130,DR="235///T",DA=SRTN D ^DIE K DR,DA,DIE Q
+5 IF $PIECE(^SRF(SRTN,"RA"),"^",2)'="C"
QUIT
+6 IF SRACNT>100
SET SRACNT=1
SET SRAMNUM=SRAMNUM+1
+7 SET SRATOT=SRATOT+1
KILL SRA,VADM
+8 FOR I=0,200,205:1:208
SET SRA(I)=$GET(SRF(SRTN,I))
+9 DO ^SROATCM1
DO P93
+10 KILL SHEMP,SRA,VADM,VAPA
+11 SET X=$EXTRACT($PIECE(^SRF(SRTN,0),"^",9),1,5)_"00"
SET ^TMP("SRWL",$JOB,X)=""
+12 QUIT
P93 ; referring & follow-up sites, patient address & phone number
+1 NEW SRPREF,SRREF,SRREFP,SRFOL,SRFOLP,SRSOUT,SRY
SET (SRPREF,SRREF,SRREFP,SRFOL,SRFOLP)=""
SET SRSOUT=0
SET (VAIP("D"),SRSDATE)=$PIECE(SRA(0),"^",9)
DO IN5^VADPT
+2 ; if not admitted before surgery, look for admission within 24 hours of leaving OR
+3 IF 'VAIP(13)
SET X1=$PIECE($GET(^SRF(SRTN,.2)),"^",12)
SET X2=1
DO C^%DTC
SET SR24=X
SET SRDT=$ORDER(^DGPM("APTT1",DFN,SRSDATE))
if 'SRDT!(SRDT>SR24)
GOTO TS
SET VAIP("D")=SRDT
DO IN5^VADPT
TS IF VAIP(13)
KILL DA,DIC,DIQ,DR
SET DIC=405
SET DR=.05
SET DA=VAIP(13)
SET DIQ="SRY"
SET DIQ(0)="IE"
DO EN^DIQ1
SET SRREF=SRY(405,VAIP(13),.05,"E")
SET SRREFP=SRY(405,VAIP(13),.05,"I")
IF SRREFP
SET SRREFP=$$GET1^DIQ(4,SRREFP,99)
+1 IF VAIP(17)
KILL DA,DIC,DIQ,DR,SRY
SET DIC=405
SET DR=.05
SET DA=VAIP(17)
SET DIQ="SRY"
SET DIQ(0)="IE"
DO EN^DIQ1
SET SRFOL=SRY(405,VAIP(17),.05,"E")
SET SRFOLP=SRY(405,VAIP(17),.05,"I")
IF SRFOLP
SET SRFOLP=$$GET1^DIQ(4,SRFOLP,99)
+2 SET SHEMP=$EXTRACT(SHEMP,1,11)_" 18"_$JUSTIFY(VAPA(1),35)_$JUSTIFY(VAPA(2),30)
SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
SET SRACNT=SRACNT+1
+3 SET SHEMP=$EXTRACT(SHEMP,1,11)_" 19"_$JUSTIFY(VAPA(3),30)_$JUSTIFY(VAPA(4),15)
+4 KILL DA,DIC,DIQ,DR,SRY
SET X=$PIECE(VAPA(5),"^")
IF X
SET DIC=5
SET DA=X
SET DR=1
SET DIQ="SRY"
SET DIQ(0)="E"
DO EN^DIQ1
SET X=SRY(5,$PIECE(VAPA(5),"^"),1,"E")
+5 SET SHEMP=SHEMP_$JUSTIFY(X,5)
SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
SET SRACNT=SRACNT+1
SET SHEMP=$EXTRACT(SHEMP,1,11)_" 20"_$JUSTIFY(VAPA(8),20)_$JUSTIFY($TRANSLATE(SRREF,","," "),30)_$JUSTIFY(SRREFP,6)
+6 KILL DA,DIC,DIQ,DR,SRY
SET DIC="^DPT("
SET DIQ="SRY"
SET DIQ(0)="I"
SET DA=DFN
SET DR=27.02
DO EN^DIQ1
SET X=$GET(SRY(2,DFN,27.02,"I"))
IF X
SET SRPREF=$$GET1^DIQ(4,X,99)
+7 SET SHEMP=SHEMP_$JUSTIFY(SRPREF,6)
+8 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
SET SRACNT=SRACNT+1
SET SHEMP=$EXTRACT(SHEMP,1,11)_" 21"_$JUSTIFY($TRANSLATE(SRFOL,","," "),30)_$JUSTIFY(SRFOLP,6)
+9 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
SET SRACNT=SRACNT+1
+10 SET SHEMP=$EXTRACT(SHEMP,1,11)_" 22"_$JUSTIFY($PIECE(SRA(201),"^",21),6)_$JUSTIFY($PIECE(SRA(202),"^",21),7)_$JUSTIFY($PIECE(SRA(201),"^",22),6)_$JUSTIFY($PIECE(SRA(202),"^",22),7)
+11 SET SHEMP=SHEMP_$JUSTIFY($PIECE(SRA(201),"^",23),6)_$JUSTIFY($PIECE(SRA(202),"^",23),7)_$JUSTIFY($PIECE(SRA(201),"^",24),6)_$JUSTIFY($PIECE(SRA(202),"^",24),7)
+12 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
SET SRACNT=SRACNT+1
+13 ;
+14 SET DFN=$PIECE(^SRF(SRTN,0),"^")
DO DEM^VADPT
SET SHEMP=$EXTRACT(SHEMP,1,11)_" 23"_$JUSTIFY($PIECE(SRA(201),"^",25),6)_$JUSTIFY($PIECE(SRA(202),"^",25),7)_$JUSTIFY($PIECE(SRA(201),"^",26),6)_$JUSTIFY($PIECE(SRA(202),"^",26),7)_$JUSTIFY($PIECE(VADM(3),"^"),7)
KILL VADM
+15 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP_$$ADD182^SROATCM1(SRTN)
SET SRACNT=SRACNT+1
+16 SET SHEMP=$EXTRACT(SHEMP,1,11)_" 24"_$JUSTIFY($PIECE(SRA(208),"^",10),2)_$JUSTIFY($PIECE(SRA(200),"^",57),2)_$JUSTIFY($PIECE(SRA(207),"^",24),2)_$JUSTIFY($PIECE(SRA(207),"^",25),2)_$JUSTIFY($PIECE(SRA(206),"^",39),2)
+17 NEW SR22,SR23
SET SR22=$PIECE(SRA(208),"^",22)
SET SR23=$PIECE(SRA(208),"^",23)
+18 NEW SRIP1,SRIP2
SET (SRIP1,SRIP2)=""
+19 DO NMCS
SET SHEMP=SHEMP_$JUSTIFY(SRIP,2)_$JUSTIFY(" ",2)_$SELECT(SR22:$JUSTIFY(SR22,12,4),1:$JUSTIFY(SR22,12))_$SELECT(SR23:$JUSTIFY(SR23,12,4),1:$JUSTIFY(SR23,12))_$JUSTIFY($PIECE(SRA(206),"^",41),2)
+20 SET SHEMP=SHEMP_$JUSTIFY($PIECE(SRA(207),"^",26),3)
+21 ;
+22 NEW VAINDT,SRPTF,SRRES,SRDISTYP
+23 SET VAINDT=$PIECE(SRA(208),"^",15)-.0001
DO INP^VADPT
SET SRPTF=VAIN(10)
+24 SET SRRES=""
DO RPC^DGPTFAPI(.SRRES,SRPTF)
+25 SET SRRES(0)=$GET(SRRES(0))
SET SRRES(1)=$GET(SRRES(1))
SET SRRES(2)=$GET(SRRES(2))
+26 SET SRDISTYP=$PIECE(SRRES(1),U)
+27 IF SRDISTYP]""
SET SRDISTYP=$SELECT(SRDISTYP="REGULAR":1,SRDISTYP="NBC OR WHILE ASIH":2,SRDISTYP="EXPIRATION 6 MONTH LIMIT":3,SRDISTYP="IRREGULAR":4,SRDISTYP="TRANSFER":5,SRDISTYP="DEATH WITH AUTOPSY":6,SRDISTYP="DEATH WITHOUT AUTOPSY":7,1:"")
+28 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP_$JUSTIFY($PIECE(SRRES(1),U,3),8)_$JUSTIFY($PIECE(SRA(205),"^",40),2)_$JUSTIFY(SRIP1,1)_$JUSTIFY(SRIP2,1)_$JUSTIFY($PIECE($GET(^SRF(SRTN,.1)),"^",21),1)
+29 SET SRACNT=SRACNT+1
SET SHEMP=$EXTRACT(SHEMP,1,11)_" 25"_$JUSTIFY(SRDISTYP,2)
IF $DATA(SRRES(2))
FOR I=1:1:7
SET SHEMP=SHEMP_$JUSTIFY($PIECE(SRRES(2),"^",I),8)
+30 SET ^TMP("SRA",$JOB,SRAMNUM,SRACNT,0)=SHEMP
SET SRACNT=SRACNT+1
+31 DO ^SROATCM3
+32 QUIT
NMCS SET SRIP=$PIECE(SRA(206),"^",40)
IF SRIP'="Y"
QUIT
+1 NEW SROCC
+2 SET SROCC=0
FOR
SET SROCC=$ORDER(^SRF(SRTN,10,SROCC))
if 'SROCC
QUIT
IF $PIECE(^SRF(SRTN,10,SROCC,0),"^",2)=34
SET SRIP="I"
SET SRIP1=$PIECE(^SRF(SRTN,10,SROCC,0),"^",7)
QUIT
+3 SET SROCC=0
FOR
SET SROCC=$ORDER(^SRF(SRTN,16,SROCC))
if 'SROCC
QUIT
IF $PIECE(^SRF(SRTN,16,SROCC,0),"^",2)=34
if SRIP="Y"
SET SRIP="P"
SET SRIP2=$PIECE(^SRF(SRTN,16,SROCC,0),"^",14)
QUIT
+4 QUIT
