RC45P252.m

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 ---RC45P252   1854     printed  Mar 13, 2025@20:46:57                                                                                                                                                                                                    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