Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SROESUTL

SROESUTL.m

Go to the documentation of this file.
  1. SROESUTL ;BIR/ADM - SURGERY E-SIG UTILITY ;09/22/04
  1. ;;3.0; Surgery ;**100,134**;24 Jun 93
  1. ;** NOTICE: This routine is part of an implementation of a nationally
  1. ;** controlled procedure. Local modifications to this routine
  1. ;** are prohibited.
  1. ;
  1. ; Reference to EXTRACT^TIULQ supported by DBIA #2693
  1. ;
  1. TIU ; get document specifics from TIU
  1. D EXTRACT^TIULQ(SRTIU,"SRT",.SRERR)
  1. S SRDOC=SRT(SRTIU,.01,"E"),SRCASE=$P(SRT(SRTIU,1405,"I"),";")
  1. Q
  1. DELETE(SRTIU) ; delete action
  1. N SR,SRCASE,SRDOC,SRERR,SRFLD,SRT D TIU
  1. S SRFLD=$S(SRDOC["OPERATION":1000,SRDOC["NURSE INTRAOP":1001,SRDOC["PROCEDURE":1002,1:1003) D
  1. .S SR=$G(^SRF(SRCASE,"TIU"))
  1. .I SRFLD=1000,$P(SR,"^")=SRTIU D AT Q
  1. .I SRFLD=1001,$P(SR,"^",2)=SRTIU D AT Q
  1. .I SRFLD=1002,$P(SR,"^",3)=SRTIU D AT Q
  1. .I SRFLD=1003,$P(SR,"^",4)=SRTIU D AT
  1. Q
  1. AT N SRY S SRY(130,SROP_",",SRFLD)="@" D FILE^DIE("","SRY")
  1. Q
  1. RETRACT(SRTIU) ; retraction action
  1. D DELETE(SRTIU),ALERT(SRTIU)
  1. Q
  1. ALERT(SRTIU) ; issue alert to author of document
  1. N SRAUTHOR,SRDOC,SRCASE,SRERR,SRT
  1. D TIU S SRAUTHOR=SRT(SRTIU,1202,"I") Q:'SRAUTHOR
  1. S XQAMSG=SRDOC_" retracted on case #"_SRCASE_"."
  1. S XQA(SRAUTHOR)="",XQADATA=SRCASE_"^"_SRDOC,XQAROU="ACTION^SROESUTL"
  1. D SETUP^XQALERT
  1. Q
  1. ACTION ; alert action
  1. Q:'$D(XQADATA) N DFN,SR,SRSDT,SRTN,SRDOC,SRY,VA,VADM,Y
  1. S SRTN=$P(XQADATA,"^"),SRDOC=$P(XQADATA,"^",2) Q:'SRTN!(SRDOC="")
  1. S SR=$G(^SRF(SRTN,0)) Q:SR=""
  1. S DFN=$P(SR,"^") D DEM^VADPT S Y=$P(SR,"^",9) D DD^%DT S SRSDT=Y
  1. S SRY(1)=SRDOC_" retracted on case #"_SRTN,SRY(1,"F")="!!!"
  1. S SRY(2)=VADM(1)_" ("_VA("PID")_") Op Date: "_SRSDT
  1. S SRY(3)="Principal Procedure: "_$P(^SRF(SRTN,"OP"),"^"),SRY(4)=" " D EN^DDIOL(.SRY)
  1. Q
  1. STATUS(SRTIU) ; get signature status
  1. N SRT,STATUS
  1. D EXTRACT^TIULQ(SRTIU,"SRT",.SRERR,".05") S STATUS=SRT(SRTIU,.05,"I")
  1. Q STATUS
  1. SIGNED(SRCASE) ;is NIR or AR on this case or on concurrent case signed?
  1. N SRCONCC,SRI,SRND,SRSINED
  1. S SRSINED=0,SRND=$G(^SRF(SRCASE,"TIU"))
  1. F SRI=2,4 S SRTIU=$P(SRND,"^",SRI) I SRTIU,$$STATUS(SRTIU)=7 S SRSINED=1 Q
  1. S SRCONCC=$P($G(^SRF(SRCASE,"CON")),"^") I SRCONCC D
  1. .S SRND=$G(^SRF(SRCONCC,"TIU"))
  1. .F SRI=2,4 S SRTIU=$P(SRND,"^",SRI) I SRTIU,$$STATUS(SRTIU)=7 S SRSINED=1 Q
  1. Q SRSINED