RC45P252 ;ALB/CLT - PATCH PRCA*4.5*252 POST INIT ROUTINE ;13-JUN-2008
;;4.5;Accounts Receivable;**252**;Mar 20, 1995;Build 63
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; Review all entries in file 344.4 looking for any IDENTITY TYPE QUALIFIER fields
; that contain a zero (0). If the field is equal to 0, change it to NULL
;
Q
;
EN ;
D MESSAGE("Queuing PRCA*4.5*252 POST-INSTALL process")
N %DT,X,Y,ZTDESC,ZTSAVE,ZTIO,ZTDTH,ZTRTN
S X="N",%DT="ST"
D ^%DT
S ZTDTH=Y
S ZTIO=""
S ZTDESC="PRCA*4.5*252 POST INSTALL PROCESS"
S ZTSAVE("DUZ")=""
S ZTRTN="EN1^RC45P252"
D ^%ZTLOAD
Q
;
EN1 ;PRIMARY ENTRY POINT
N RCDPX,RCDPY,RCDPZ1,RCDPZ2,RCDPZ3,RCDPMSG1,RCDPMSG2,RCDPMSG3 ;variables used in the search
S (RCDPX,RCDPZ1,RCDPZ2,RCDPZ3)=0 ;Initial value setup
F S RCDPX=$O(^RCY(344.4,RCDPX)) Q:'+RCDPX S RCDPZ1=RCDPZ1+1 S RCDPY=0 D
. F S RCDPY=$O(^RCY(344.4,RCDPX,1,RCDPY)) Q:'+RCDPY S RCDPZ2=RCDPZ2+1 D:$D(^RCY(344.4,RCDPX,1,RCDPY,3))
. . I $P(^RCY(344.4,RCDPX,1,RCDPY,3),U,3)=0 S $P(^RCY(344.4,RCDPX,1,RCDPY,3),U,3)="" S RCDPZ3=RCDPZ3+1
S RCDPMSG1=RCDPZ1_" ERA records have been reviewed"
S RCDPMSG2=RCDPZ2_" ERA details have been reviewed"
S RCDPMSG3=RCDPZ3_" ERA details have been corrected"
D SNDMAIL("PRCA*4.5*252 installation has been completed",RCDPMSG1,RCDPMSG2,RCDPMSG3)
Q
;
; RCDPMSG - message text
MESSAGE(RCDPMSG) ;
D BMES^XPDUTL(RCDPMSG)
Q
; Send mail to the user
SNDMAIL(RCDPSUBJ,RCDPM1,RCDPM2,RCDPM3) ;
N DIFROM
N RCDPARR,XMDUZ,XMSUB,XMTEXT,XMY,RCDPUSR,XMZ,XMMG
S RCDPARR(1)=""
S RCDPARR(2)=RCDPM1
S RCDPARR(3)=RCDPM2
S RCDPARR(4)=RCDPM3
S RCDPARR(5)=""
S XMSUB=RCDPSUBJ
S XMDUZ="ACCOUNTS RECEIVABLE - PRCA*4.5*252 POST INSTALL"
S XMTEXT="RCDPARR("
S RCDPUSR=$S($G(DUZ)']"":.5,1:DUZ)
S XMY(RCDPUSR)=""
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRC45P252 1854 printed Dec 13, 2024@01:42:16 Page 2
RC45P252 ;ALB/CLT - PATCH PRCA*4.5*252 POST INIT ROUTINE ;13-JUN-2008
+1 ;;4.5;Accounts Receivable;**252**;Mar 20, 1995;Build 63
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; Review all entries in file 344.4 looking for any IDENTITY TYPE QUALIFIER fields
+5 ; that contain a zero (0). If the field is equal to 0, change it to NULL
+6 ;
+7 QUIT
+8 ;
EN ;
+1 DO MESSAGE("Queuing PRCA*4.5*252 POST-INSTALL process")
+2 NEW %DT,X,Y,ZTDESC,ZTSAVE,ZTIO,ZTDTH,ZTRTN
+3 SET X="N"
SET %DT="ST"
+4 DO ^%DT
+5 SET ZTDTH=Y
+6 SET ZTIO=""
+7 SET ZTDESC="PRCA*4.5*252 POST INSTALL PROCESS"
+8 SET ZTSAVE("DUZ")=""
+9 SET ZTRTN="EN1^RC45P252"
+10 DO ^%ZTLOAD
+11 QUIT
+12 ;
EN1 ;PRIMARY ENTRY POINT
+1 ;variables used in the search
NEW RCDPX,RCDPY,RCDPZ1,RCDPZ2,RCDPZ3,RCDPMSG1,RCDPMSG2,RCDPMSG3
+2 ;Initial value setup
SET (RCDPX,RCDPZ1,RCDPZ2,RCDPZ3)=0
+3 FOR
SET RCDPX=$ORDER(^RCY(344.4,RCDPX))
if '+RCDPX
QUIT
SET RCDPZ1=RCDPZ1+1
SET RCDPY=0
Begin DoDot:1
+4 FOR
SET RCDPY=$ORDER(^RCY(344.4,RCDPX,1,RCDPY))
if '+RCDPY
QUIT
SET RCDPZ2=RCDPZ2+1
if $DATA(^RCY(344.4,RCDPX,1,RCDPY,3))
Begin DoDot:2
+5 IF $PIECE(^RCY(344.4,RCDPX,1,RCDPY,3),U,3)=0
SET $PIECE(^RCY(344.4,RCDPX,1,RCDPY,3),U,3)=""
SET RCDPZ3=RCDPZ3+1
End DoDot:2
End DoDot:1
+6 SET RCDPMSG1=RCDPZ1_" ERA records have been reviewed"
+7 SET RCDPMSG2=RCDPZ2_" ERA details have been reviewed"
+8 SET RCDPMSG3=RCDPZ3_" ERA details have been corrected"
+9 DO SNDMAIL("PRCA*4.5*252 installation has been completed",RCDPMSG1,RCDPMSG2,RCDPMSG3)
+10 QUIT
+11 ;
+12 ; RCDPMSG - message text
MESSAGE(RCDPMSG) ;
+1 DO BMES^XPDUTL(RCDPMSG)
+2 QUIT
+3 ; Send mail to the user
SNDMAIL(RCDPSUBJ,RCDPM1,RCDPM2,RCDPM3) ;
+1 NEW DIFROM
+2 NEW RCDPARR,XMDUZ,XMSUB,XMTEXT,XMY,RCDPUSR,XMZ,XMMG
+3 SET RCDPARR(1)=""
+4 SET RCDPARR(2)=RCDPM1
+5 SET RCDPARR(3)=RCDPM2
+6 SET RCDPARR(4)=RCDPM3
+7 SET RCDPARR(5)=""
+8 SET XMSUB=RCDPSUBJ
+9 SET XMDUZ="ACCOUNTS RECEIVABLE - PRCA*4.5*252 POST INSTALL"
+10 SET XMTEXT="RCDPARR("
+11 SET RCDPUSR=$SELECT($GET(DUZ)']"":.5,1:DUZ)
+12 SET XMY(RCDPUSR)=""
+13 DO ^XMD
+14 QUIT
