SR62UTL ;BIR/ADM - Post-install process for SR*3*62; [ 03/18/97 11:19 AM ]
;;3.0; Surgery ;**62**;24 Jun 93
Q
POST S ZTDESC="SR*3*62 - NSQIP Transmission",ZTRTN="TSK^SR62UTL",ZTIO="",ZTDTH=$H D ^%ZTLOAD
Q
TSK N SRA,SRCREATE,SRSDATE,SRSTATUS,SRTN,SRTYPE K ^TMP("SR62",$J)
S SRSDATE=2961000 F S SRSDATE=$O(^SRF("AC",SRSDATE)) Q:+SRSDATE<2961000 S SRTN=0 F S SRTN=$O(^SRF("AC",SRSDATE,SRTN)) Q:'SRTN D
.Q:'$P($G(^SRF(SRTN,.2)),"^",12)!$P($G(^SRF(SRTN,30)),"^")!($P($G(^SRF(SRTN,"NON")),"^")="Y")
.S SRA=$G(^SRF(SRTN,"RA")),SRSTATUS=$P(SRA,"^"),SRTYPE=$P(SRA,"^",2),SRCREATE=$P(SRA,"^",6) I (SRTYPE'="N")!(SRSTATUS'="T") D AQ Q
.I SRSTATUS="T" S ^TMP("SR62",$J,SRTN)="" S $P(^SRF(SRTN,.4),"^",2)="T" Q
EN1 S SITE=+$P($$SITE^SROVAR,"^",3),(SRY,SRN)=0
S SRTN=0 F S SRTN=$O(^TMP("SR62",$J,SRTN)) Q:'SRTN D
.S SRDIV=$P($G(^SRF(SRTN,8)),"^") I SRDIV S SRDIV=$$GET1^DIQ(4,SRDIV,99)
.S SRNODE=$P(^SRF(SRTN,"RA"),"^",6)
.S DFN=$P(^SRF(SRTN,0),"^") N I D DEM^VADPT
.I SRNODE="Y" D ASSESS
.I SRNODE="N" D EXCLUDE
D SEND
QR ; queue quarterly report for first quarter of FY97
S X=0 F S X=$O(^SRO(133,X)) Q:'X S $P(^SRO(133,X,0),"^",18)=""
S SRSTART=2961001,SREND=2961231,SRFLG=1,SRT=1 D EN^SROQT
Q
EXCLUDE S SRMAJMIN=$E($P($G(^SRF(SRTN,0)),U,3),1)
S SRDEATH=$E($P($G(^DPT(DFN,.35)),U),1,7)
S SRDTHUR=$E($P($G(^SRF(SRTN,.4)),U,7),1)
S SRSTATUS=$E($P($G(^SRF(SRTN,0)),U,12),1)
S DATE=$E($P(^SRF(SRTN,0),"^",9),1,7),SRAGE=$E(DATE,1,3)-$E($P(VADM(3),"^"),1,3)-($E(DATE,4,7)<$E($P(VADM(3),"^"),4,7))
K CPT F SRZ=1:1:10 S CPT(SRZ)=""
S (OPS,CNT)=0 F S OPS=$O(^SRF(SRTN,13,OPS)) Q:'OPS!(CNT=10) S CNT=CNT+1,X=$P($G(^SRF(SRTN,13,OPS,2)),"^") I X S CPT(CNT)=$P(^ICPT(X,0),"^")
S SRCPT=CPT(1)_"^"_CPT(2)_"^"_CPT(3)_"^"_CPT(4)_"^"_CPT(5)_"^"_CPT(6)_"^"_CPT(7)_"^"_CPT(8)_"^"_CPT(9)_"^"_CPT(10)
S SRWOUND=$P($G(^SRF(SRTN,0)),"^",16)
ASSESS S SRASA=$P($G(^SRF(SRTN,1.1)),U,3)
S SRATTEND=$E($P($G(^SRF(SRTN,.1)),U,16),1) I SRATTEND="" D RS^SROQ0A S SRATTEND=SRATT
S (SRADMIT,SRADMT)=0 I $E($P($G(^SRF(SRTN,0)),U,12),1)="O" D ADM^SROQ0A S SRADMIT=$S(SRADMT=0:"0",1:"1")
OCC F SRK=1:1:32 S SROC(SRK)=""
S (SRPO,SRSUB,SRIOFLAG)=0 F S SRPO=$O(^SRF(SRTN,10,SRPO)) Q:'SRPO S SRSUB=$P(^SRF(SRTN,10,SRPO,0),U,2) I SRSUB'="" S SROC(SRSUB)=SROC(SRSUB)+1,SRIOFLAG=1
S (SRPO,SRSUB,SRPOFLAG)=0 F S SRPO=$O(^SRF(SRTN,16,SRPO)) Q:'SRPO S SRSUB=$P(^SRF(SRTN,16,SRPO,0),U,2) I SRSUB'="" S SROC(SRSUB)=SROC(SRSUB)+1,SRPOFLAG=1
S (SROCTYPE,SRTMP)="" F SRK=1:1:32 S SRTMP=SRTMP_SROC(SRK)_"^"
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=""
I SRNODE="Y" S SRY=SRY+1,^TMP("SRAY",$J,SRY)=SITE_"^"_SRDIV_"^"_SRTN_"^"_SRNODE_"^"_SRATTEND_"^"_SRADMIT_"^"_SRTMP_"^"_SRASA_"^"_SROCTYPE
I SRNODE="N" S SRN=SRN+1,^TMP("SRAN",$J,SRN)=SITE_"^"_SRDIV_"^"_SRTN_"^"_SRNODE_"^"_SRATTEND_"^"_SRADMIT_"^"_SRTMP_"^"_SRMAJMIN_"^"_SRDEATH_"^"_SRDTHUR_"^"_SRSTATUS_"^"_SRAGE_"^"_SRASA_"^"_SRCPT_"^"_SRWOUND_"^"_SROCTYPE
Q
SEND ; send message to G.SRCOSERV RISK at Hines ISC
S ISC=0,NAME=$G(^XMB("NETNAME")) I NAME["FORUM"!(NAME["ISC-")!($E(NAME,1,3)="ISC")!(NAME["ISC.")!(NAME["TST") S ISC=1
S XMSUB="*** SR*3*62 ASSESSED FROM VAMC-"_SITE_" ***",XMDUZ=^XMB("NETNAME")
I ISC S XMY("G.RISK ASSESSMENT@"_^XMB("NETNAME"))=""
I 'ISC S XMY("G.SRCOSERV@ISC-CHICAGO.DOMAIN.EXT")=""
S XMTEXT="^TMP(""SRAY"",$J," N I D ^XMD
S XMSUB="*** SR*3*62 EXCLUDED FROM VAMC-"_SITE_" ***",XMDUZ=^XMB("NETNAME")
I ISC S XMY("G.RISK ASSESSMENT@"_^XMB("NETNAME"))=""
I 'ISC S XMY("G.SRCOSERV@ISC-CHICAGO.DOMAIN.EXT")=""
S XMTEXT="^TMP(""SRAN"",$J," N I D ^XMD
K DFN,^TMP("SR62"),^TMP("SRAY"),^TMP("SRAN"),SRTN,SITE,SRCAR,SRCNS,SRDA,SRDEATH,SRDFN,SRY,SRN,SROC,SRRES,SRSDATE,SRTDT,SRDTHUR,SRMAJMIN,SRTEMP,SR14,CPT,SRCPT,SRZ,SRZZ,SRDIV,SRADMIT,SRADMT,SRATT,SRK,SRNODE,SRATTEND,SRPO,SRSUB,SRTMP
S ZTREQ="@"
Q
AQ ; set ready to transmit field to ready
N SRTD D AQDT S $P(^SRF(SRTN,.4),"^",2)="R",^SRF("AQ",SRTD,SRTN)=""
Q
AQDT ; get quarterly transmission date for this case
N SRDAY,SRQTR,SRYR
S SRYR=$E(SRSDATE,1,3),SRDAY=$E(SRSDATE,4,7),SRQTR=$S(SRDAY<401:2,SRDAY<701:3,SRDAY<1001:4,1:1) I SRQTR=1 S SRYR=SRYR+1
S SRTD=SRYR_$S(SRQTR=1:"0214",SRQTR=2:"0515",SRQTR=3:"0814",1:"1114")
Q
PRE ; pre-install process for SR*3*62
N SRQOP,SRM,SRMQ
S SRQOP=$O(^DIC(19,"B","SRO QUARTERLY REPORT",0)),SRM=$O(^DIC(19,"B","SRO-CHIEF REPORTS",0)) Q:'SRQOP!'SRM
S SRMQ=$O(^DIC(19,SRM,10,"B",SRQOP,0)) Q:'SRMQ D DIK
S SRQM=$O(^DIC(19,"B","SROQ MENU",0)) Q:'SRQM S SRMQ=$O(^DIC(19,SRM,10,"B",SRQM,0)) Q:'SRMQ
DIK K DA,DIK S DA(1)=SRM,DA=SRMQ,DIK="^DIC(19,"_DA(1)_",10," D ^DIK K DA,DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSR62UTL 4736 printed Dec 13, 2024@02:38:48 Page 2
SR62UTL ;BIR/ADM - Post-install process for SR*3*62; [ 03/18/97 11:19 AM ]
+1 ;;3.0; Surgery ;**62**;24 Jun 93
+2 QUIT
POST SET ZTDESC="SR*3*62 - NSQIP Transmission"
SET ZTRTN="TSK^SR62UTL"
SET ZTIO=""
SET ZTDTH=$HOROLOG
DO ^%ZTLOAD
+1 QUIT
TSK NEW SRA,SRCREATE,SRSDATE,SRSTATUS,SRTN,SRTYPE
KILL ^TMP("SR62",$JOB)
+1 SET SRSDATE=2961000
FOR
SET SRSDATE=$ORDER(^SRF("AC",SRSDATE))
if +SRSDATE<2961000
QUIT
SET SRTN=0
FOR
SET SRTN=$ORDER(^SRF("AC",SRSDATE,SRTN))
if 'SRTN
QUIT
Begin DoDot:1
+2 if '$PIECE($GET(^SRF(SRTN,.2)),"^",12)!$PIECE($GET(^SRF(SRTN,30)),"^")!($PIECE($GET(^SRF(SRTN,"NON")),"^")="Y")
QUIT
+3 SET SRA=$GET(^SRF(SRTN,"RA"))
SET SRSTATUS=$PIECE(SRA,"^")
SET SRTYPE=$PIECE(SRA,"^",2)
SET SRCREATE=$PIECE(SRA,"^",6)
IF (SRTYPE'="N")!(SRSTATUS'="T")
DO AQ
QUIT
+4 IF SRSTATUS="T"
SET ^TMP("SR62",$JOB,SRTN)=""
SET $PIECE(^SRF(SRTN,.4),"^",2)="T"
QUIT
End DoDot:1
EN1 SET SITE=+$PIECE($$SITE^SROVAR,"^",3)
SET (SRY,SRN)=0
+1 SET SRTN=0
FOR
SET SRTN=$ORDER(^TMP("SR62",$JOB,SRTN))
if 'SRTN
QUIT
Begin DoDot:1
+2 SET SRDIV=$PIECE($GET(^SRF(SRTN,8)),"^")
IF SRDIV
SET SRDIV=$$GET1^DIQ(4,SRDIV,99)
+3 SET SRNODE=$PIECE(^SRF(SRTN,"RA"),"^",6)
+4 SET DFN=$PIECE(^SRF(SRTN,0),"^")
NEW I
DO DEM^VADPT
+5 IF SRNODE="Y"
DO ASSESS
+6 IF SRNODE="N"
DO EXCLUDE
End DoDot:1
+7 DO SEND
QR ; queue quarterly report for first quarter of FY97
+1 SET X=0
FOR
SET X=$ORDER(^SRO(133,X))
if 'X
QUIT
SET $PIECE(^SRO(133,X,0),"^",18)=""
+2 SET SRSTART=2961001
SET SREND=2961231
SET SRFLG=1
SET SRT=1
DO EN^SROQT
+3 QUIT
EXCLUDE SET SRMAJMIN=$EXTRACT($PIECE($GET(^SRF(SRTN,0)),U,3),1)
+1 SET SRDEATH=$EXTRACT($PIECE($GET(^DPT(DFN,.35)),U),1,7)
+2 SET SRDTHUR=$EXTRACT($PIECE($GET(^SRF(SRTN,.4)),U,7),1)
+3 SET SRSTATUS=$EXTRACT($PIECE($GET(^SRF(SRTN,0)),U,12),1)
+4 SET DATE=$EXTRACT($PIECE(^SRF(SRTN,0),"^",9),1,7)
SET SRAGE=$EXTRACT(DATE,1,3)-$EXTRACT($PIECE(VADM(3),"^"),1,3)-($EXTRACT(DATE,4,7)<$EXTRACT($PIECE(VADM(3),"^"),4,7))
+5 KILL CPT
FOR SRZ=1:1:10
SET CPT(SRZ)=""
+6 SET (OPS,CNT)=0
FOR
SET OPS=$ORDER(^SRF(SRTN,13,OPS))
if 'OPS!(CNT=10)
QUIT
SET CNT=CNT+1
SET X=$PIECE($GET(^SRF(SRTN,13,OPS,2)),"^")
IF X
SET CPT(CNT)=$PIECE(^ICPT(X,0),"^")
+7 SET SRCPT=CPT(1)_"^"_CPT(2)_"^"_CPT(3)_"^"_CPT(4)_"^"_CPT(5)_"^"_CPT(6)_"^"_CPT(7)_"^"_CPT(8)_"^"_CPT(9)_"^"_CPT(10)
+8 SET SRWOUND=$PIECE($GET(^SRF(SRTN,0)),"^",16)
ASSESS SET SRASA=$PIECE($GET(^SRF(SRTN,1.1)),U,3)
+1 SET SRATTEND=$EXTRACT($PIECE($GET(^SRF(SRTN,.1)),U,16),1)
IF SRATTEND=""
DO RS^SROQ0A
SET SRATTEND=SRATT
+2 SET (SRADMIT,SRADMT)=0
IF $EXTRACT($PIECE($GET(^SRF(SRTN,0)),U,12),1)="O"
DO ADM^SROQ0A
SET SRADMIT=$SELECT(SRADMT=0:"0",1:"1")
OCC FOR SRK=1:1:32
SET SROC(SRK)=""
+1 SET (SRPO,SRSUB,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'=""
SET SROC(SRSUB)=SROC(SRSUB)+1
SET SRIOFLAG=1
+2 SET (SRPO,SRSUB,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'=""
SET SROC(SRSUB)=SROC(SRSUB)+1
SET SRPOFLAG=1
+3 SET (SROCTYPE,SRTMP)=""
FOR SRK=1:1:32
SET SRTMP=SRTMP_SROC(SRK)_"^"
+4 IF SRIOFLAG=1
IF (SRPOFLAG=0)
SET SROCTYPE="I"
+5 IF SRIOFLAG=0
IF (SRPOFLAG=1)
SET SROCTYPE="P"
+6 IF SRIOFLAG=1
IF (SRPOFLAG=1)
SET SROCTYPE="B"
+7 IF SRIOFLAG=0
IF (SRPOFLAG=0)
SET SROCTYPE=""
+8 IF SRNODE="Y"
SET SRY=SRY+1
SET ^TMP("SRAY",$JOB,SRY)=SITE_"^"_SRDIV_"^"_SRTN_"^"_SRNODE_"^"_SRATTEND_"^"_SRADMIT_"^"_SRTMP_"^"_SRASA_"^"_SROCTYPE
+9 IF SRNODE="N"
SET SRN=SRN+1
SET ^TMP("SRAN",$JOB,SRN)=SITE_"^"_SRDIV_"^"_SRTN_"^"_SRNODE_"^"_SRATTEND_"^"_SRADMIT_"^"_SRTMP_"^"_SRMAJMIN_"^"_SRDEATH_"^"_SRDTHUR_"^"_SRSTATUS_"^"_SRAGE_"^"_SRASA_"^"_SRCPT_"^"_SRWOUND_"^"_SROCTYPE
+10 QUIT
SEND ; send message to G.SRCOSERV RISK at Hines ISC
+1 SET ISC=0
SET NAME=$GET(^XMB("NETNAME"))
IF NAME["FORUM"!(NAME["ISC-")!($EXTRACT(NAME,1,3)="ISC")!(NAME["ISC.")!(NAME["TST")
SET ISC=1
+2 SET XMSUB="*** SR*3*62 ASSESSED FROM VAMC-"_SITE_" ***"
SET XMDUZ=^XMB("NETNAME")
+3 IF ISC
SET XMY("G.RISK ASSESSMENT@"_^XMB("NETNAME"))=""
+4 IF 'ISC
SET XMY("G.SRCOSERV@ISC-CHICAGO.DOMAIN.EXT")=""
+5 SET XMTEXT="^TMP(""SRAY"",$J,"
NEW I
DO ^XMD
+6 SET XMSUB="*** SR*3*62 EXCLUDED FROM VAMC-"_SITE_" ***"
SET XMDUZ=^XMB("NETNAME")
+7 IF ISC
SET XMY("G.RISK ASSESSMENT@"_^XMB("NETNAME"))=""
+8 IF 'ISC
SET XMY("G.SRCOSERV@ISC-CHICAGO.DOMAIN.EXT")=""
+9 SET XMTEXT="^TMP(""SRAN"",$J,"
NEW I
DO ^XMD
+10 KILL DFN,^TMP("SR62"),^TMP("SRAY"),^TMP("SRAN"),SRTN,SITE,SRCAR,SRCNS,SRDA,SRDEATH,SRDFN,SRY,SRN,SROC,SRRES,SRSDATE,SRTDT,SRDTHUR,SRMAJMIN,SRTEMP,SR14,CPT,SRCPT,SRZ,SRZZ,SRDIV,SRADMIT,SRADMT,SRATT,SRK,SRNODE,SRATTEND,SRPO,SRSUB,SRTMP
+11 SET ZTREQ="@"
+12 QUIT
AQ ; set ready to transmit field to ready
+1 NEW SRTD
DO AQDT
SET $PIECE(^SRF(SRTN,.4),"^",2)="R"
SET ^SRF("AQ",SRTD,SRTN)=""
+2 QUIT
AQDT ; get quarterly transmission date for this case
+1 NEW SRDAY,SRQTR,SRYR
+2 SET SRYR=$EXTRACT(SRSDATE,1,3)
SET SRDAY=$EXTRACT(SRSDATE,4,7)
SET SRQTR=$SELECT(SRDAY<401:2,SRDAY<701:3,SRDAY<1001:4,1:1)
IF SRQTR=1
SET SRYR=SRYR+1
+3 SET SRTD=SRYR_$SELECT(SRQTR=1:"0214",SRQTR=2:"0515",SRQTR=3:"0814",1:"1114")
+4 QUIT
PRE ; pre-install process for SR*3*62
+1 NEW SRQOP,SRM,SRMQ
+2 SET SRQOP=$ORDER(^DIC(19,"B","SRO QUARTERLY REPORT",0))
SET SRM=$ORDER(^DIC(19,"B","SRO-CHIEF REPORTS",0))
if 'SRQOP!'SRM
QUIT
+3 SET SRMQ=$ORDER(^DIC(19,SRM,10,"B",SRQOP,0))
if 'SRMQ
QUIT
DO DIK
+4 SET SRQM=$ORDER(^DIC(19,"B","SROQ MENU",0))
if 'SRQM
QUIT
SET SRMQ=$ORDER(^DIC(19,SRM,10,"B",SRQM,0))
if 'SRMQ
QUIT
DIK KILL DA,DIK
SET DA(1)=SRM
SET DA=SRMQ
SET DIK="^DIC(19,"_DA(1)_",10,"
DO ^DIK
KILL DA,DIK
+1 QUIT
