SROESUTL ;BIR/ADM - SURGERY E-SIG UTILITY ;09/22/04
;;3.0; Surgery ;**100,134**;24 Jun 93
;** NOTICE: This routine is part of an implementation of a nationally
;** controlled procedure. Local modifications to this routine
;** are prohibited.
;
; Reference to EXTRACT^TIULQ supported by DBIA #2693
;
TIU ; get document specifics from TIU
D EXTRACT^TIULQ(SRTIU,"SRT",.SRERR)
S SRDOC=SRT(SRTIU,.01,"E"),SRCASE=$P(SRT(SRTIU,1405,"I"),";")
Q
DELETE(SRTIU) ; delete action
N SR,SRCASE,SRDOC,SRERR,SRFLD,SRT D TIU
S SRFLD=$S(SRDOC["OPERATION":1000,SRDOC["NURSE INTRAOP":1001,SRDOC["PROCEDURE":1002,1:1003) D
.S SR=$G(^SRF(SRCASE,"TIU"))
.I SRFLD=1000,$P(SR,"^")=SRTIU D AT Q
.I SRFLD=1001,$P(SR,"^",2)=SRTIU D AT Q
.I SRFLD=1002,$P(SR,"^",3)=SRTIU D AT Q
.I SRFLD=1003,$P(SR,"^",4)=SRTIU D AT
Q
AT N SRY S SRY(130,SROP_",",SRFLD)="@" D FILE^DIE("","SRY")
Q
RETRACT(SRTIU) ; retraction action
D DELETE(SRTIU),ALERT(SRTIU)
Q
ALERT(SRTIU) ; issue alert to author of document
N SRAUTHOR,SRDOC,SRCASE,SRERR,SRT
D TIU S SRAUTHOR=SRT(SRTIU,1202,"I") Q:'SRAUTHOR
S XQAMSG=SRDOC_" retracted on case #"_SRCASE_"."
S XQA(SRAUTHOR)="",XQADATA=SRCASE_"^"_SRDOC,XQAROU="ACTION^SROESUTL"
D SETUP^XQALERT
Q
ACTION ; alert action
Q:'$D(XQADATA) N DFN,SR,SRSDT,SRTN,SRDOC,SRY,VA,VADM,Y
S SRTN=$P(XQADATA,"^"),SRDOC=$P(XQADATA,"^",2) Q:'SRTN!(SRDOC="")
S SR=$G(^SRF(SRTN,0)) Q:SR=""
S DFN=$P(SR,"^") D DEM^VADPT S Y=$P(SR,"^",9) D DD^%DT S SRSDT=Y
S SRY(1)=SRDOC_" retracted on case #"_SRTN,SRY(1,"F")="!!!"
S SRY(2)=VADM(1)_" ("_VA("PID")_") Op Date: "_SRSDT
S SRY(3)="Principal Procedure: "_$P(^SRF(SRTN,"OP"),"^"),SRY(4)=" " D EN^DDIOL(.SRY)
Q
STATUS(SRTIU) ; get signature status
N SRT,STATUS
D EXTRACT^TIULQ(SRTIU,"SRT",.SRERR,".05") S STATUS=SRT(SRTIU,.05,"I")
Q STATUS
SIGNED(SRCASE) ;is NIR or AR on this case or on concurrent case signed?
N SRCONCC,SRI,SRND,SRSINED
S SRSINED=0,SRND=$G(^SRF(SRCASE,"TIU"))
F SRI=2,4 S SRTIU=$P(SRND,"^",SRI) I SRTIU,$$STATUS(SRTIU)=7 S SRSINED=1 Q
S SRCONCC=$P($G(^SRF(SRCASE,"CON")),"^") I SRCONCC D
.S SRND=$G(^SRF(SRCONCC,"TIU"))
.F SRI=2,4 S SRTIU=$P(SRND,"^",SRI) I SRTIU,$$STATUS(SRTIU)=7 S SRSINED=1 Q
Q SRSINED
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROESUTL 2254 printed Sep 23, 2025@20:20:07 Page 2
SROESUTL ;BIR/ADM - SURGERY E-SIG UTILITY ;09/22/04
+1 ;;3.0; Surgery ;**100,134**;24 Jun 93
+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 EXTRACT^TIULQ supported by DBIA #2693
+7 ;
TIU ; get document specifics from TIU
+1 DO EXTRACT^TIULQ(SRTIU,"SRT",.SRERR)
+2 SET SRDOC=SRT(SRTIU,.01,"E")
SET SRCASE=$PIECE(SRT(SRTIU,1405,"I"),";")
+3 QUIT
DELETE(SRTIU) ; delete action
+1 NEW SR,SRCASE,SRDOC,SRERR,SRFLD,SRT
DO TIU
+2 SET SRFLD=$SELECT(SRDOC["OPERATION":1000,SRDOC["NURSE INTRAOP":1001,SRDOC["PROCEDURE":1002,1:1003)
Begin DoDot:1
+3 SET SR=$GET(^SRF(SRCASE,"TIU"))
+4 IF SRFLD=1000
IF $PIECE(SR,"^")=SRTIU
DO AT
QUIT
+5 IF SRFLD=1001
IF $PIECE(SR,"^",2)=SRTIU
DO AT
QUIT
+6 IF SRFLD=1002
IF $PIECE(SR,"^",3)=SRTIU
DO AT
QUIT
+7 IF SRFLD=1003
IF $PIECE(SR,"^",4)=SRTIU
DO AT
End DoDot:1
+8 QUIT
AT NEW SRY
SET SRY(130,SROP_",",SRFLD)="@"
DO FILE^DIE("","SRY")
+1 QUIT
RETRACT(SRTIU) ; retraction action
+1 DO DELETE(SRTIU)
DO ALERT(SRTIU)
+2 QUIT
ALERT(SRTIU) ; issue alert to author of document
+1 NEW SRAUTHOR,SRDOC,SRCASE,SRERR,SRT
+2 DO TIU
SET SRAUTHOR=SRT(SRTIU,1202,"I")
if 'SRAUTHOR
QUIT
+3 SET XQAMSG=SRDOC_" retracted on case #"_SRCASE_"."
+4 SET XQA(SRAUTHOR)=""
SET XQADATA=SRCASE_"^"_SRDOC
SET XQAROU="ACTION^SROESUTL"
+5 DO SETUP^XQALERT
+6 QUIT
ACTION ; alert action
+1 if '$DATA(XQADATA)
QUIT
NEW DFN,SR,SRSDT,SRTN,SRDOC,SRY,VA,VADM,Y
+2 SET SRTN=$PIECE(XQADATA,"^")
SET SRDOC=$PIECE(XQADATA,"^",2)
if 'SRTN!(SRDOC="")
QUIT
+3 SET SR=$GET(^SRF(SRTN,0))
if SR=""
QUIT
+4 SET DFN=$PIECE(SR,"^")
DO DEM^VADPT
SET Y=$PIECE(SR,"^",9)
DO DD^%DT
SET SRSDT=Y
+5 SET SRY(1)=SRDOC_" retracted on case #"_SRTN
SET SRY(1,"F")="!!!"
+6 SET SRY(2)=VADM(1)_" ("_VA("PID")_") Op Date: "_SRSDT
+7 SET SRY(3)="Principal Procedure: "_$PIECE(^SRF(SRTN,"OP"),"^")
SET SRY(4)=" "
DO EN^DDIOL(.SRY)
+8 QUIT
STATUS(SRTIU) ; get signature status
+1 NEW SRT,STATUS
+2 DO EXTRACT^TIULQ(SRTIU,"SRT",.SRERR,".05")
SET STATUS=SRT(SRTIU,.05,"I")
+3 QUIT STATUS
SIGNED(SRCASE) ;is NIR or AR on this case or on concurrent case signed?
+1 NEW SRCONCC,SRI,SRND,SRSINED
+2 SET SRSINED=0
SET SRND=$GET(^SRF(SRCASE,"TIU"))
+3 FOR SRI=2,4
SET SRTIU=$PIECE(SRND,"^",SRI)
IF SRTIU
IF $$STATUS(SRTIU)=7
SET SRSINED=1
QUIT
+4 SET SRCONCC=$PIECE($GET(^SRF(SRCASE,"CON")),"^")
IF SRCONCC
Begin DoDot:1
+5 SET SRND=$GET(^SRF(SRCONCC,"TIU"))
+6 FOR SRI=2,4
SET SRTIU=$PIECE(SRND,"^",SRI)
IF SRTIU
IF $$STATUS(SRTIU)=7
SET SRSINED=1
QUIT
End DoDot:1
+7 QUIT SRSINED
