SROQ30D ;BIR/ADM - 30-DAY READMISSION TRANSMISSION ;10/31/2011
;;3.0;Surgery;**176,182**;24 Jun 93;Build 49
;** NOTICE: This routine is part of an implementation of a nationally
;** controlled procedure. Local modifications to this routine
;** are prohibited.
;
; Reference to ^DGPM("APTT1" supported by DBIA #565
Q
MSG ; create mail message to server
S X=$$ACTIVE^XUSER(DUZ) I '+X S XMDUZ=.5
S XMSUB="VAMC-"_SRASITE_" 30-DAY READMITS ("_SRCNT_") - FY"_$E(SRYR,3,4)_" Q"_SRQTR
S SRD=^XMB("NETNAME"),ISC=0 I SRD["FO-"!(SRD["ISC-")!(SRD["ISC.")!(SRD["FORUM")!(SRD["TST") S ISC=1
K XMY I 'ISC S (XMY("G.SRCOSERV@FO-HINES.DOMAIN.EXT"),XMY("G.CARDIAC RISK ASSESSMENTS@DENVER.DOMAIN.EXT"))=""
I ISC S XMY("G.SR-QUARTERLY@"_SRD)=""
S XMTEXT="^TMP(""SRQTR"",$J," N I D ^XMD K ^TMP("SRQTR",$J),XMY,XMTEXT
I '$D(XMMG) D SITE
Q
EN ; entry point when run manually to generate current report
D CURRENT
EN1 D DATES K ^TMP("SRQTR",$J)
S SRASITE=+$P($$SITE^SROVAR,"^",3),SRSD=SRSTART-.0001,SRED=SREND+.9999,SRCNT=0,^TMP("SRQTR",$J,1)="#"_SRASITE_"^^^^^"
F S SRSD=$O(^SRF("AC",SRSD)) Q:SRSD>SRED!('SRSD) S SRTN=0 F S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN D CASE
D MSG,END
Q
CASE ; examine case
Q:$P($G(^SRF(SRTN,30)),"^")!'$P($G(^SRF(SRTN,.2)),"^",12)!($P($G(^SRF(SRTN,"NON")),"^")="Y")
N DFN,SR,SRADM,SRDISCH,SRPTF,SRRES
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 SR(0)=^SRF(SRTN,0),DFN=$P(SR(0),"^")
S SRDISCH=$P($G(^SRF(SRTN,208)),"^",15) I 'SRDISCH D PIMS I 'SRDISCH Q
; determine if patient was readmitted within 30 days after discharge
S SRADM=$O(^DGPM("APTT1",DFN,SRDISCH)) I 'SRADM Q
S X1=SRDISCH,X2=30 D C^%DTC S SR30=X,SRADM=$O(^DGPM("APTT1",DFN,SRDISCH)) Q:'SRADM!(SRADM>SR30)
S VAINDT=SRADM D INP^VADPT S SRX=$P(VAIN(3),"^"),SRSPE="" D SPEC
S SRPTF=VAIN(10),SRRES="" D RPC^DGPTFAPI(.SRRES,SRPTF)
S SRCNT=SRCNT+1,^TMP("SRQTR",$J,SRCNT)="#"_SRASITE_"^"_SRTN_"^"_SRDIV_"^"_SRADM_"^"_SRSPE_"^"_$P($G(SRRES(1)),"^",3)
Q
PIMS ; determine if inpatient surgery
N SRSDATE,SRSOUT S SRSOUT=0,(VAIP("D"),SRSDATE)=$P(SR(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)) Q:'SRDT!(SRDT>SR24) S VAIP("D")=SRDT D IN5^VADPT I 'VAIP(13) Q
I VAIP(13) D ADM Q:SRSOUT
Q
ADM ; get information related to admission
; determine if admission was for observation
; quit if no specialty defined for admission
S SRX=$P($G(VAIP(13,6)),"^") I SRX="" S SRDISCH=$E($P(VAIP(17,1),"^"),1,12),SRSOUT=1 Q
D SPEC S Y="18,23,24,36,41,65,94" I Y[SRSP D Q:SRSOUT
.; look for admission following discharge from observation
.S X1=$P($G(^SRF(SRTN,.2)),"^",12),X2=2 D C^%DTC S SR48=X,SRDT=$O(^DGPM("APTT1",DFN,$P(VAIP(13,1),"^"))) I 'SRDT!(SRDT>SR48) S SRDISCH="",SRSOUT=1 Q
.S VAIP("D")=SRDT D IN5^VADPT I 'VAIP(13) S SRDISCH="",SRSOUT=1
S SRDISCH=$E($P(VAIP(17,1),"^"),1,12)
Q
SPEC ; find specialty associated with movement
K DA,DIC,DIQ,DR,SRY S DIC=45.7,DR=1,DA=SRX,DIQ="SRY",DIQ(0)="EI" D EN^DIQ1 K DA,DIC,DIQ,DR S SRSP=SRY(45.7,SRX,1,"I"),SRSPE=SRY(45.7,SRX,1,"E")
Q
END K ^TMP("SRQTR",$J),DA,DIC,DIQ,DR,ISC,SR24,SR30,SR48,SRASITE,SRCNT,SRD,SRDAY,SRDIV,SRDT,SRE,SRED,SREMO
K SREND,SRFQ,SRQTR,SRSD,SRSMO,SRSOUT,SRSP,SRSPE,SRSTART,SRTN,SRX,SRY,SRYR,SRYRF,VAIN,VAINDT,VAIP,X,X1,X2,Y
S ZTREQ="@"
Q
SITE ; update site parameters file
S SRE=0 F S SRE=$O(^SRO(133,SRE)) Q:'SRE I $P(^SRO(133,SRE,0),"^",9)<SRFQ S $P(^(0),"^",9)=SRFQ
Q
NIGHT ; determine if current quarterly 30-day readmission report has been transmitted
D CURRENT S SRE=$O(^SRO(133,0)) I $P(^SRO(133,SRE,0),"^",9)'<SRFQ Q
D EN1
Q
DATES S SRSMO=$S(SRQTR=1:"1001",SRQTR=2:"0101",SRQTR=3:"0401",1:"0701"),SREMO=$S(SRQTR=1:"1231",SRQTR=2:"0331",SRQTR=3:"0630",1:"0930"),SRSTART=$S(SRQTR=1:SRYRF-1,1:SRYRF)_SRSMO,SREND=$S(SRQTR=1:SRYRF-1,1:SRYRF)_SREMO
Q
CURRENT ; get current reporting quarter
S SRYR=$E(DT,1,3),SRDAY=$E(DT,4,7),SRQTR=$S(SRDAY>930:3,SRDAY>630:2,SRDAY>331:1,1:4)
I SRQTR=4,SRDAY<401 S SRYR=SRYR-1
S SRYRF=SRYR,SRYR=SRYR+1700,SRFQ=SRYR_SRQTR
Q
SEL ; run for selected fiscal quarter
K DIR S DIR(0)="FO",DIR("A")="Enter fiscal year and quarter (e.g., 2012-3)" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!(X="") Q
D CHECK I '$D(X) D HELP G SEL
S SRYR=SRX,SRQTR=SRY,SRFQ=SRYR_SRQTR,SRYRF=SRX-1700
D EN1
Q
QTR D CHECK I '$D(X) D HELP
K SRX,SRY
Q
CHECK I $L(X)'=6!(X'["-") K X Q
I $P(X,"-",2)?1N,"1243"'[$P(X,"-",2) K X Q
I X'?4N1"-"1N K X Q
S SRX=$P(X,"-") I SRX<2011!(SRX>2030) K X Q
S SRY=$P(X,"-",2) I "1234"'[SRY K X Q
S X=SRX_SRY
Q
HELP K SRHELP S SRHELP(1)="",SRHELP(2)="Answer must be in format: FISCAL YEAR-QUARTER",SRHELP(3)="",SRHELP(4)="NOTE: A hyphen (-) must separate FISCAL YEAR and QUARTER. The FISCAL"
S SRHELP(5)=" YEAR must be in the range 2011 to 2030. QUARTER must be a",SRHELP(6)=" number (1, 2, 3 or 4).",SRHELP(7)="" D EN^DDIOL(.SRHELP) K SRHELP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROQ30D 5118 printed Dec 13, 2024@02:45:25 Page 2
SROQ30D ;BIR/ADM - 30-DAY READMISSION TRANSMISSION ;10/31/2011
+1 ;;3.0;Surgery;**176,182**;24 Jun 93;Build 49
+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 ^DGPM("APTT1" supported by DBIA #565
+7 QUIT
MSG ; create mail message to server
+1 SET X=$$ACTIVE^XUSER(DUZ)
IF '+X
SET XMDUZ=.5
+2 SET XMSUB="VAMC-"_SRASITE_" 30-DAY READMITS ("_SRCNT_") - FY"_$EXTRACT(SRYR,3,4)_" Q"_SRQTR
+3 SET SRD=^XMB("NETNAME")
SET ISC=0
IF SRD["FO-"!(SRD["ISC-")!(SRD["ISC.")!(SRD["FORUM")!(SRD["TST")
SET ISC=1
+4 KILL XMY
IF 'ISC
SET (XMY("G.SRCOSERV@FO-HINES.DOMAIN.EXT"),XMY("G.CARDIAC RISK ASSESSMENTS@DENVER.DOMAIN.EXT"))=""
+5 IF ISC
SET XMY("G.SR-QUARTERLY@"_SRD)=""
+6 SET XMTEXT="^TMP(""SRQTR"",$J,"
NEW I
DO ^XMD
KILL ^TMP("SRQTR",$JOB),XMY,XMTEXT
+7 IF '$DATA(XMMG)
DO SITE
+8 QUIT
EN ; entry point when run manually to generate current report
+1 DO CURRENT
EN1 DO DATES
KILL ^TMP("SRQTR",$JOB)
+1 SET SRASITE=+$PIECE($$SITE^SROVAR,"^",3)
SET SRSD=SRSTART-.0001
SET SRED=SREND+.9999
SET SRCNT=0
SET ^TMP("SRQTR",$JOB,1)="#"_SRASITE_"^^^^^"
+2 FOR
SET SRSD=$ORDER(^SRF("AC",SRSD))
if SRSD>SRED!('SRSD)
QUIT
SET SRTN=0
FOR
SET SRTN=$ORDER(^SRF("AC",SRSD,SRTN))
if 'SRTN
QUIT
DO CASE
+3 DO MSG
DO END
+4 QUIT
CASE ; examine case
+1 if $PIECE($GET(^SRF(SRTN,30)),"^")!'$PIECE($GET(^SRF(SRTN,.2)),"^",12)!($PIECE($GET(^SRF(SRTN,"NON")),"^")="Y")
QUIT
+2 NEW DFN,SR,SRADM,SRDISCH,SRPTF,SRRES
+3 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)
+4 SET SR(0)=^SRF(SRTN,0)
SET DFN=$PIECE(SR(0),"^")
+5 SET SRDISCH=$PIECE($GET(^SRF(SRTN,208)),"^",15)
IF 'SRDISCH
DO PIMS
IF 'SRDISCH
QUIT
+6 ; determine if patient was readmitted within 30 days after discharge
+7 SET SRADM=$ORDER(^DGPM("APTT1",DFN,SRDISCH))
IF 'SRADM
QUIT
+8 SET X1=SRDISCH
SET X2=30
DO C^%DTC
SET SR30=X
SET SRADM=$ORDER(^DGPM("APTT1",DFN,SRDISCH))
if 'SRADM!(SRADM>SR30)
QUIT
+9 SET VAINDT=SRADM
DO INP^VADPT
SET SRX=$PIECE(VAIN(3),"^")
SET SRSPE=""
DO SPEC
+10 SET SRPTF=VAIN(10)
SET SRRES=""
DO RPC^DGPTFAPI(.SRRES,SRPTF)
+11 SET SRCNT=SRCNT+1
SET ^TMP("SRQTR",$JOB,SRCNT)="#"_SRASITE_"^"_SRTN_"^"_SRDIV_"^"_SRADM_"^"_SRSPE_"^"_$PIECE($GET(SRRES(1)),"^",3)
+12 QUIT
PIMS ; determine if inpatient surgery
+1 NEW SRSDATE,SRSOUT
SET SRSOUT=0
SET (VAIP("D"),SRSDATE)=$PIECE(SR(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)
QUIT
SET VAIP("D")=SRDT
DO IN5^VADPT
IF 'VAIP(13)
QUIT
+4 IF VAIP(13)
DO ADM
if SRSOUT
QUIT
+5 QUIT
ADM ; get information related to admission
+1 ; determine if admission was for observation
+2 ; quit if no specialty defined for admission
+3 SET SRX=$PIECE($GET(VAIP(13,6)),"^")
IF SRX=""
SET SRDISCH=$EXTRACT($PIECE(VAIP(17,1),"^"),1,12)
SET SRSOUT=1
QUIT
+4 DO SPEC
SET Y="18,23,24,36,41,65,94"
IF Y[SRSP
Begin DoDot:1
+5 ; look for admission following discharge from observation
+6 SET X1=$PIECE($GET(^SRF(SRTN,.2)),"^",12)
SET X2=2
DO C^%DTC
SET SR48=X
SET SRDT=$ORDER(^DGPM("APTT1",DFN,$PIECE(VAIP(13,1),"^")))
IF 'SRDT!(SRDT>SR48)
SET SRDISCH=""
SET SRSOUT=1
QUIT
+7 SET VAIP("D")=SRDT
DO IN5^VADPT
IF 'VAIP(13)
SET SRDISCH=""
SET SRSOUT=1
End DoDot:1
if SRSOUT
QUIT
+8 SET SRDISCH=$EXTRACT($PIECE(VAIP(17,1),"^"),1,12)
+9 QUIT
SPEC ; find specialty associated with movement
+1 KILL DA,DIC,DIQ,DR,SRY
SET DIC=45.7
SET DR=1
SET DA=SRX
SET DIQ="SRY"
SET DIQ(0)="EI"
DO EN^DIQ1
KILL DA,DIC,DIQ,DR
SET SRSP=SRY(45.7,SRX,1,"I")
SET SRSPE=SRY(45.7,SRX,1,"E")
+2 QUIT
END KILL ^TMP("SRQTR",$JOB),DA,DIC,DIQ,DR,ISC,SR24,SR30,SR48,SRASITE,SRCNT,SRD,SRDAY,SRDIV,SRDT,SRE,SRED,SREMO
+1 KILL SREND,SRFQ,SRQTR,SRSD,SRSMO,SRSOUT,SRSP,SRSPE,SRSTART,SRTN,SRX,SRY,SRYR,SRYRF,VAIN,VAINDT,VAIP,X,X1,X2,Y
+2 SET ZTREQ="@"
+3 QUIT
SITE ; update site parameters file
+1 SET SRE=0
FOR
SET SRE=$ORDER(^SRO(133,SRE))
if 'SRE
QUIT
IF $PIECE(^SRO(133,SRE,0),"^",9)<SRFQ
SET $PIECE(^(0),"^",9)=SRFQ
+2 QUIT
NIGHT ; determine if current quarterly 30-day readmission report has been transmitted
+1 DO CURRENT
SET SRE=$ORDER(^SRO(133,0))
IF $PIECE(^SRO(133,SRE,0),"^",9)'<SRFQ
QUIT
+2 DO EN1
+3 QUIT
DATES SET SRSMO=$SELECT(SRQTR=1:"1001",SRQTR=2:"0101",SRQTR=3:"0401",1:"0701")
SET SREMO=$SELECT(SRQTR=1:"1231",SRQTR=2:"0331",SRQTR=3:"0630",1:"0930")
SET SRSTART=$SELECT(SRQTR=1:SRYRF-1,1:SRYRF)_SRSMO
SET SREND=$SELECT(SRQTR=1:SRYRF-1,1:SRYRF)_SREMO
+1 QUIT
CURRENT ; get current reporting quarter
+1 SET SRYR=$EXTRACT(DT,1,3)
SET SRDAY=$EXTRACT(DT,4,7)
SET SRQTR=$SELECT(SRDAY>930:3,SRDAY>630:2,SRDAY>331:1,1:4)
+2 IF SRQTR=4
IF SRDAY<401
SET SRYR=SRYR-1
+3 SET SRYRF=SRYR
SET SRYR=SRYR+1700
SET SRFQ=SRYR_SRQTR
+4 QUIT
SEL ; run for selected fiscal quarter
+1 KILL DIR
SET DIR(0)="FO"
SET DIR("A")="Enter fiscal year and quarter (e.g., 2012-3)"
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!(X="")
QUIT
+2 DO CHECK
IF '$DATA(X)
DO HELP
GOTO SEL
+3 SET SRYR=SRX
SET SRQTR=SRY
SET SRFQ=SRYR_SRQTR
SET SRYRF=SRX-1700
+4 DO EN1
+5 QUIT
QTR DO CHECK
IF '$DATA(X)
DO HELP
+1 KILL SRX,SRY
+2 QUIT
CHECK IF $LENGTH(X)'=6!(X'["-")
KILL X
QUIT
+1 IF $PIECE(X,"-",2)?1N
IF "1243"'[$PIECE(X,"-",2)
KILL X
QUIT
+2 IF X'?4N1"-"1N
KILL X
QUIT
+3 SET SRX=$PIECE(X,"-")
IF SRX<2011!(SRX>2030)
KILL X
QUIT
+4 SET SRY=$PIECE(X,"-",2)
IF "1234"'[SRY
KILL X
QUIT
+5 SET X=SRX_SRY
+6 QUIT
HELP KILL SRHELP
SET SRHELP(1)=""
SET SRHELP(2)="Answer must be in format: FISCAL YEAR-QUARTER"
SET SRHELP(3)=""
SET SRHELP(4)="NOTE: A hyphen (-) must separate FISCAL YEAR and QUARTER. The FISCAL"
+1 SET SRHELP(5)=" YEAR must be in the range 2011 to 2030. QUARTER must be a"
SET SRHELP(6)=" number (1, 2, 3 or 4)."
SET SRHELP(7)=""
DO EN^DDIOL(.SRHELP)
KILL SRHELP
+2 QUIT
