EC2P156 ;ALB/CMD - EC Procedure Reasons Update ;12/22/21 18:59
;;2.0;EVENT CAPTURE;**156**;8 May 96;Build 28
;
; This routine is used as a post-init in a KIDS build
; to update the EC Procedure Reasons file (#720.4).
;
; Reference to ^DIE supported by ICR# 10018
; Reference to ^XMD supported by ICR #10070
; Reference to ^TMP($J) supported by SACC 2.3.2.5.1
; Reference to ^XUSEC(key) supported by ICR #10076
;
POST ;Post-install activities
;Update Procedure Reasons to Inactivate CHAPLAIN Procedure Reasons and send mail message with results
D INACTPR ;inactivate all CHAPLAIN procedure reasons
Q
;
INACTPR ;Inactivate all CHAPLAIN Procedure Reasons and send mail message with results
N ECPRNM,ECPRIEN,ECPR,DA,DIE,DR
S ECPRNM=""
F S ECPRNM=$O(^ECR("B",ECPRNM)) Q:ECPRNM="" I $E(ECPRNM,1,5)="CHAP " D
. S ECPRIEN=$O(^ECR("B",ECPRNM,""))
. I '$P(^ECR(ECPRIEN,0),"^",2) Q ;Skip if procedure reason is already inactive
. ;Inactivate the CHAP Procedure Reason
. S DA=ECPRIEN,DR=".02////0",DIE="^ECR(" D ^DIE
. S ECPR(ECPRNM)=""
D MAIL(.ECPR) ;Send mail with results
Q
;
MAIL(PROREAS) ; Send email with results to holders of the ECMGR key
N XMSUB,XMTEXT,XMDUZ,XMY,XMZ,CNT,DIFROM,ECTEXT,NUM,NAME
S XMDUZ="PATCH EC*2.0*156 POST-INSTALL"
D GETXMY("ECMGR",.XMY)
S XMSUB="Inactivation of CHAPLAINS Procedure Reasons"
S XMTEXT="ECTEXT("
S CNT=1
I '$D(PROREAS) D
.S ECTEXT(CNT)="No CHAPLAIN Procedure Reasons were inactivated, as no Active CHAPLAIN Procedure Reasons were found.",CNT=CNT+1
I $D(PROREAS) D
.S NAME=""
.S ECTEXT(CNT)="The following CHAPLAIN Procedure Reasons have been inactivated: ",CNT=CNT+1
.S ECTEXT(CNT)=" ",CNT=CNT+1
.F S NAME=$O(PROREAS(NAME)) Q:NAME="" D
..S ECTEXT(CNT)=NAME,CNT=CNT+1
D ^XMD
Q
GETXMY(KEY,XMY) ;Put holders of the KEY into the XMY array to be recipients of the email
I $G(KEY)'="" M XMY=^XUSEC(KEY)
S:$G(DUZ) XMY(DUZ)="" ;Make sure there's at least one recipient
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC2P156 1994 printed Dec 13, 2024@01:55:33 Page 2
EC2P156 ;ALB/CMD - EC Procedure Reasons Update ;12/22/21 18:59
+1 ;;2.0;EVENT CAPTURE;**156**;8 May 96;Build 28
+2 ;
+3 ; This routine is used as a post-init in a KIDS build
+4 ; to update the EC Procedure Reasons file (#720.4).
+5 ;
+6 ; Reference to ^DIE supported by ICR# 10018
+7 ; Reference to ^XMD supported by ICR #10070
+8 ; Reference to ^TMP($J) supported by SACC 2.3.2.5.1
+9 ; Reference to ^XUSEC(key) supported by ICR #10076
+10 ;
POST ;Post-install activities
+1 ;Update Procedure Reasons to Inactivate CHAPLAIN Procedure Reasons and send mail message with results
+2 ;inactivate all CHAPLAIN procedure reasons
DO INACTPR
+3 QUIT
+4 ;
INACTPR ;Inactivate all CHAPLAIN Procedure Reasons and send mail message with results
+1 NEW ECPRNM,ECPRIEN,ECPR,DA,DIE,DR
+2 SET ECPRNM=""
+3 FOR
SET ECPRNM=$ORDER(^ECR("B",ECPRNM))
if ECPRNM=""
QUIT
IF $EXTRACT(ECPRNM,1,5)="CHAP "
Begin DoDot:1
+4 SET ECPRIEN=$ORDER(^ECR("B",ECPRNM,""))
+5 ;Skip if procedure reason is already inactive
IF '$PIECE(^ECR(ECPRIEN,0),"^",2)
QUIT
+6 ;Inactivate the CHAP Procedure Reason
+7 SET DA=ECPRIEN
SET DR=".02////0"
SET DIE="^ECR("
DO ^DIE
+8 SET ECPR(ECPRNM)=""
End DoDot:1
+9 ;Send mail with results
DO MAIL(.ECPR)
+10 QUIT
+11 ;
MAIL(PROREAS) ; Send email with results to holders of the ECMGR key
+1 NEW XMSUB,XMTEXT,XMDUZ,XMY,XMZ,CNT,DIFROM,ECTEXT,NUM,NAME
+2 SET XMDUZ="PATCH EC*2.0*156 POST-INSTALL"
+3 DO GETXMY("ECMGR",.XMY)
+4 SET XMSUB="Inactivation of CHAPLAINS Procedure Reasons"
+5 SET XMTEXT="ECTEXT("
+6 SET CNT=1
+7 IF '$DATA(PROREAS)
Begin DoDot:1
+8 SET ECTEXT(CNT)="No CHAPLAIN Procedure Reasons were inactivated, as no Active CHAPLAIN Procedure Reasons were found."
SET CNT=CNT+1
End DoDot:1
+9 IF $DATA(PROREAS)
Begin DoDot:1
+10 SET NAME=""
+11 SET ECTEXT(CNT)="The following CHAPLAIN Procedure Reasons have been inactivated: "
SET CNT=CNT+1
+12 SET ECTEXT(CNT)=" "
SET CNT=CNT+1
+13 FOR
SET NAME=$ORDER(PROREAS(NAME))
if NAME=""
QUIT
Begin DoDot:2
+14 SET ECTEXT(CNT)=NAME
SET CNT=CNT+1
End DoDot:2
End DoDot:1
+15 DO ^XMD
+16 QUIT
GETXMY(KEY,XMY) ;Put holders of the KEY into the XMY array to be recipients of the email
+1 IF $GET(KEY)'=""
MERGE XMY=^XUSEC(KEY)
+2 ;Make sure there's at least one recipient
if $GET(DUZ)
SET XMY(DUZ)=""
+3 QUIT
