PRCAI169 ;WISC/RFJ-post init patch 169 ; 26 Jan 01
;;4.5;Accounts Receivable;**169**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
START ; start post init
;
D BMES^XPDUTL(" >> Queuing the Post-Initialization routine ...")
;
N ZTIO,ZTDTH,ZTRTN,ZTSK
S ZTIO="",ZTDTH=$H,ZTRTN="DQ^PRCAI169"
D ^%ZTLOAD
;
D MES^XPDUTL(" in task "_ZTSK_".")
;
D BMES^XPDUTL(" ")
D MES^XPDUTL(" IMPORTANT IMPORTANT IMPORTANT IMPORTANT IMPORTANT IMPORTANT")
D MES^XPDUTL(" *********************************************************************")
D MES^XPDUTL(" When the Queued Post-Initialization finishes running, a mail")
D MES^XPDUTL(" message will be delivered to the mail groups IRM and PRCA")
D MES^XPDUTL(" ADJUSTMENT TRANS with the subject: AR Patch 169 Installation")
D MES^XPDUTL(" Completed. You should receive this message within 24 hours.")
D MES^XPDUTL(" If you do not receive the message, you will need to restart")
D MES^XPDUTL(" the Post-Initialization by running the routine START^PRCAI169.")
D MES^XPDUTL(" *********************************************************************")
D MES^XPDUTL(" IMPORTANT IMPORTANT IMPORTANT IMPORTANT IMPORTANT IMPORTANT")
Q
;
;
DQ ; queue post initialization
;
; add the post install entry for history
N RCMSPOST
S RCMSPOST=$$START^RCMSPOST("PRCA*4.5*169")
;
; 1. ***** disable type of payment IRS PAYMENT by
; removing the category field entry .06
N %,D,D0,DA,DI,DIC,DIE,DQ,DR,X
S DA=$O(^RC(341.1,"B","IRS PAYMENT",0))
I DA S (DIC,DIE)="^RC(341.1,",DR=".06///@;" D ^DIE
;
;
; 2. ***** delete IRS mail group
; reference to XMB allowed in integration agreement 3359
N %,DA,DIC,DIK,RCMIRSDA,RCDA,X,Y
S RCMIRSDA=+$O(^XMB(3.8,"B","IRS",0))
I RCMIRSDA D
. ; check to see if IRS mail group is a member of another
. ; mail group. If so, delete it from the other mail group.
. S RCDA(1)=0 F S RCDA(1)=$O(^XMB(3.8,"AD",RCMIRSDA,RCDA(1))) Q:'RCDA(1) D
. . S RCDA=0 F S RCDA=$O(^XMB(3.8,"AD",RCMIRSDA,RCDA(1),RCDA)) Q:'RCDA D
. . . S DA(1)=RCDA(1),DA=RCDA,DIK="^XMB(3.8,"_RCDA(1)_",5,"
. . . D ^DIK
. ;
. ; delete the mail group
. S DA=RCMIRSDA,DIK="^XMB(3.8,"
. D ^DIK
;
;
; 3. ***** fix ineligible bills, convert transaction type 24 to 02
N RCBILLDA,RCDATE
S RCDATE=3001000
F S RCDATE=$O(^PRCA(430,"ACTDT",RCDATE)) Q:'RCDATE D
. S RCBILLDA=0 F S RCBILLDA=$O(^PRCA(430,"ACTDT",RCDATE,RCBILLDA)) Q:'RCBILLDA D
. . ; if not an ineligible bill, quit
. . I $P($G(^PRCA(430,RCBILLDA,0)),"^",2)'=1 Q
. . ; if the tranasaction type already equals 02, quit
. . I $P($G(^PRCA(430,RCBILLDA,11)),"^",10)=02 Q
. . S $P(^PRCA(430,RCBILLDA,11),"^",10)="02"
;
;
; 4. ***** fix exemptions where the transaction is not split between
; interest and admin
D START^PRCAI16A
;
;
; 5. ***** fix exemption date problem
; build a list of accounts out of balance at the site
N ACCTDATA,DATA,OUTOFBAL,RCDATE,RCDEBTDA,RCEXDATA,RCEXDATE,RCLINE,RCNEXT,RCPADATA,RCTOTAL1,RCTOTAL2,RCTRANDA,X,Y
K ^TMP("PRCAI169",$J)
;
; build list of accounts out of balance
S RCDEBTDA=0
F S RCDEBTDA=$O(^RCD(340,"AB","DPT(",RCDEBTDA)) Q:'RCDEBTDA D
. S OUTOFBAL=$$EN^PRCAMRKC(RCDEBTDA)
. I OUTOFBAL S ^TMP("PRCAI169",$J,RCDEBTDA)=""
;
; loop all transactions for debtor and look at the exempt charge.
; if the exempt transaction date is not equal to the payment
; transaction date, change the exempt charge date.
S RCDEBTDA=0
F S RCDEBTDA=$O(^TMP("PRCAI169",$J,RCDEBTDA)) Q:'RCDEBTDA D
. ; get the last statement date
. S RCDATE=$P(+$$LST^RCFN01(RCDEBTDA,2),".")
. ;
. ; loop all transactions up to the last statement date + 1 day
. S RCEXDATE=0
. F S RCEXDATE=$O(^PRCA(433,"ATD",RCDEBTDA,RCEXDATE)) Q:'RCEXDATE!(RCEXDATE>(RCDATE+1)) D
. . S RCTRANDA=0
. . F S RCTRANDA=$O(^PRCA(433,"ATD",RCDEBTDA,RCEXDATE,RCTRANDA)) Q:'RCTRANDA D
. . . ; type of transaction is not an exemption
. . . S RCEXDATA=$G(^PRCA(433,RCTRANDA,1))
. . . I $P(RCEXDATA,"^",2)'=14 Q
. . . ;
. . . ; get the next transaction for the bill
. . . S RCNEXT=$O(^PRCA(433,"C",+$P($G(^PRCA(433,+RCTRANDA,0)),"^",2),RCTRANDA))
. . . ; is it a payment?, if no, quit
. . . S RCPADATA=$G(^PRCA(433,+RCNEXT,1))
. . . I $P(RCPADATA,"^",2)'=2,$P(RCPADATA,"^",2)'=34 Q
. . . ;
. . . ; check to see if this is an automatic exemption,
. . . ; if not, then do not change the date
. . . I $G(^PRCA(433,RCTRANDA,7,1,0))'["Auto" Q
. . . ;
. . . ; it is a payment, if the date of the payment is greater
. . . ; than the date of the exemption by more than 1 minute,
. . . ; change the exemption date to be equal to the payment date
. . . I ($P(RCPADATA,"^",9)-$P(RCEXDATA,"^",9))>.0001 S X=$$EDIT433^RCBEUTRA(RCTRANDA,"19////"_$P(RCPADATA,"^",9)_";")
;
; recheck the accounts out of balance
S RCTOTAL1=0 ;used to count accts out of balance prior to install
S RCTOTAL2=0 ;used to count accts fixed by the patch
S RCDEBTDA=0
F S RCDEBTDA=$O(^TMP("PRCAI169",$J,RCDEBTDA)) Q:'RCDEBTDA D
. ; check to see if account has a bill in refund review.
. ; if it does, remove it from the list.
. I $$REFUREVW^RCBEREFU(RCDEBTDA) K ^TMP("PRCAI169",$J,RCDEBTDA) Q
. ; original count of accounts out of balance before patch install
. S RCTOTAL1=RCTOTAL1+1
. ; check to see if account is out of balance. if it is
. ; not out of balance, remove it from the list.
. S OUTOFBAL=$$EN^PRCAMRKC(RCDEBTDA)
. I 'OUTOFBAL S RCTOTAL2=RCTOTAL2+1 K ^TMP("PRCAI169",$J,RCDEBTDA)
;
; build mailman message showing patch installed and accounts still
; out of balance
K ^TMP($J,"RCRJRCORMM")
S ^TMP($J,"RCRJRCORMM",1)="The Post-Initialization routine for patch PRCA*4.5*169 is completed."
S ^TMP($J,"RCRJRCORMM",2)="Patch PRCA*4.5*169 has been completely installed."
S ^TMP($J,"RCRJRCORMM",3)=" "
S ^TMP($J,"RCRJRCORMM",4)="The following accounts are still out of balance after the patch install."
S ^TMP($J,"RCRJRCORMM",5)="This list excludes accounts with bills in refund review."
S ^TMP($J,"RCRJRCORMM",6)=" "
S RCLINE=6
S RCDEBTDA=0
F S RCDEBTDA=$O(^TMP("PRCAI169",$J,RCDEBTDA)) Q:'RCDEBTDA D
. S ACCTDATA=$$ACCNTHDR^RCDPAPLM(RCDEBTDA)
. S DATA=$E($P(ACCTDATA,"^")_" ",1,30)_" "
. S DATA=DATA_$E($P(ACCTDATA,"^",2)_" ",1,12)_" "
. S DATA=DATA_$P(ACCTDATA,"^",3)
. S RCLINE=RCLINE+1,^TMP($J,"RCRJRCORMM",RCLINE)=DATA
;
S RCLINE=RCLINE+1,^TMP($J,"RCRJRCORMM",RCLINE)=" "
S RCLINE=RCLINE+1,^TMP($J,"RCRJRCORMM",RCLINE)=" TOTAL ACCOUNTS OUT OF BALANCE BEFORE PATCH INSTALL: "_$J(RCTOTAL1,8)
S RCLINE=RCLINE+1,^TMP($J,"RCRJRCORMM",RCLINE)=" TOTAL ACCOUNTS FIXED BY PATCH: "_$J(RCTOTAL2,8)
S RCLINE=RCLINE+1,^TMP($J,"RCRJRCORMM",RCLINE)=" "_$J("--------",8)
S RCLINE=RCLINE+1,^TMP($J,"RCRJRCORMM",RCLINE)=" TOTAL ACCOUNTS OUT OF BALANCE AFTER PATCH INSTALL: "_$J((RCTOTAL1-RCTOTAL2),8)
;
; send mail message
; difrom needs to be newed or mailman will not deliver the message
N DIFROM,XMDUN,XMY,XMZ
S XMY("G.IRM")=""
S XMY("G.PRCA ADJUSTMENT TRANS")=""
S XMY(.5)=""
S XMY(DUZ)=""
S XMZ=$$SENDMSG^RCRJRCOR("AR Patch 169 Installation Completed",.XMY)
K ^TMP($J,"RCRJRCORMM")
;
K ^TMP("PRCAI169",$J)
;
; set the end date for the post initialization
D END^RCMSPOST(RCMSPOST)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAI169 7786 printed Apr 09, 2024@20:50:48 Page 2
PRCAI169 ;WISC/RFJ-post init patch 169 ; 26 Jan 01
+1 ;;4.5;Accounts Receivable;**169**;Mar 20, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
START ; start post init
+1 ;
+2 DO BMES^XPDUTL(" >> Queuing the Post-Initialization routine ...")
+3 ;
+4 NEW ZTIO,ZTDTH,ZTRTN,ZTSK
+5 SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTRTN="DQ^PRCAI169"
+6 DO ^%ZTLOAD
+7 ;
+8 DO MES^XPDUTL(" in task "_ZTSK_".")
+9 ;
+10 DO BMES^XPDUTL(" ")
+11 DO MES^XPDUTL(" IMPORTANT IMPORTANT IMPORTANT IMPORTANT IMPORTANT IMPORTANT")
+12 DO MES^XPDUTL(" *********************************************************************")
+13 DO MES^XPDUTL(" When the Queued Post-Initialization finishes running, a mail")
+14 DO MES^XPDUTL(" message will be delivered to the mail groups IRM and PRCA")
+15 DO MES^XPDUTL(" ADJUSTMENT TRANS with the subject: AR Patch 169 Installation")
+16 DO MES^XPDUTL(" Completed. You should receive this message within 24 hours.")
+17 DO MES^XPDUTL(" If you do not receive the message, you will need to restart")
+18 DO MES^XPDUTL(" the Post-Initialization by running the routine START^PRCAI169.")
+19 DO MES^XPDUTL(" *********************************************************************")
+20 DO MES^XPDUTL(" IMPORTANT IMPORTANT IMPORTANT IMPORTANT IMPORTANT IMPORTANT")
+21 QUIT
+22 ;
+23 ;
DQ ; queue post initialization
+1 ;
+2 ; add the post install entry for history
+3 NEW RCMSPOST
+4 SET RCMSPOST=$$START^RCMSPOST("PRCA*4.5*169")
+5 ;
+6 ; 1. ***** disable type of payment IRS PAYMENT by
+7 ; removing the category field entry .06
+8 NEW %,D,D0,DA,DI,DIC,DIE,DQ,DR,X
+9 SET DA=$ORDER(^RC(341.1,"B","IRS PAYMENT",0))
+10 IF DA
SET (DIC,DIE)="^RC(341.1,"
SET DR=".06///@;"
DO ^DIE
+11 ;
+12 ;
+13 ; 2. ***** delete IRS mail group
+14 ; reference to XMB allowed in integration agreement 3359
+15 NEW %,DA,DIC,DIK,RCMIRSDA,RCDA,X,Y
+16 SET RCMIRSDA=+$ORDER(^XMB(3.8,"B","IRS",0))
+17 IF RCMIRSDA
Begin DoDot:1
+18 ; check to see if IRS mail group is a member of another
+19 ; mail group. If so, delete it from the other mail group.
+20 SET RCDA(1)=0
FOR
SET RCDA(1)=$ORDER(^XMB(3.8,"AD",RCMIRSDA,RCDA(1)))
if 'RCDA(1)
QUIT
Begin DoDot:2
+21 SET RCDA=0
FOR
SET RCDA=$ORDER(^XMB(3.8,"AD",RCMIRSDA,RCDA(1),RCDA))
if 'RCDA
QUIT
Begin DoDot:3
+22 SET DA(1)=RCDA(1)
SET DA=RCDA
SET DIK="^XMB(3.8,"_RCDA(1)_",5,"
+23 DO ^DIK
End DoDot:3
End DoDot:2
+24 ;
+25 ; delete the mail group
+26 SET DA=RCMIRSDA
SET DIK="^XMB(3.8,"
+27 DO ^DIK
End DoDot:1
+28 ;
+29 ;
+30 ; 3. ***** fix ineligible bills, convert transaction type 24 to 02
+31 NEW RCBILLDA,RCDATE
+32 SET RCDATE=3001000
+33 FOR
SET RCDATE=$ORDER(^PRCA(430,"ACTDT",RCDATE))
if 'RCDATE
QUIT
Begin DoDot:1
+34 SET RCBILLDA=0
FOR
SET RCBILLDA=$ORDER(^PRCA(430,"ACTDT",RCDATE,RCBILLDA))
if 'RCBILLDA
QUIT
Begin DoDot:2
+35 ; if not an ineligible bill, quit
+36 IF $PIECE($GET(^PRCA(430,RCBILLDA,0)),"^",2)'=1
QUIT
+37 ; if the tranasaction type already equals 02, quit
+38 IF $PIECE($GET(^PRCA(430,RCBILLDA,11)),"^",10)=02
QUIT
+39 SET $PIECE(^PRCA(430,RCBILLDA,11),"^",10)="02"
End DoDot:2
End DoDot:1
+40 ;
+41 ;
+42 ; 4. ***** fix exemptions where the transaction is not split between
+43 ; interest and admin
+44 DO START^PRCAI16A
+45 ;
+46 ;
+47 ; 5. ***** fix exemption date problem
+48 ; build a list of accounts out of balance at the site
+49 NEW ACCTDATA,DATA,OUTOFBAL,RCDATE,RCDEBTDA,RCEXDATA,RCEXDATE,RCLINE,RCNEXT,RCPADATA,RCTOTAL1,RCTOTAL2,RCTRANDA,X,Y
+50 KILL ^TMP("PRCAI169",$JOB)
+51 ;
+52 ; build list of accounts out of balance
+53 SET RCDEBTDA=0
+54 FOR
SET RCDEBTDA=$ORDER(^RCD(340,"AB","DPT(",RCDEBTDA))
if 'RCDEBTDA
QUIT
Begin DoDot:1
+55 SET OUTOFBAL=$$EN^PRCAMRKC(RCDEBTDA)
+56 IF OUTOFBAL
SET ^TMP("PRCAI169",$JOB,RCDEBTDA)=""
End DoDot:1
+57 ;
+58 ; loop all transactions for debtor and look at the exempt charge.
+59 ; if the exempt transaction date is not equal to the payment
+60 ; transaction date, change the exempt charge date.
+61 SET RCDEBTDA=0
+62 FOR
SET RCDEBTDA=$ORDER(^TMP("PRCAI169",$JOB,RCDEBTDA))
if 'RCDEBTDA
QUIT
Begin DoDot:1
+63 ; get the last statement date
+64 SET RCDATE=$PIECE(+$$LST^RCFN01(RCDEBTDA,2),".")
+65 ;
+66 ; loop all transactions up to the last statement date + 1 day
+67 SET RCEXDATE=0
+68 FOR
SET RCEXDATE=$ORDER(^PRCA(433,"ATD",RCDEBTDA,RCEXDATE))
if 'RCEXDATE!(RCEXDATE>(RCDATE+1))
QUIT
Begin DoDot:2
+69 SET RCTRANDA=0
+70 FOR
SET RCTRANDA=$ORDER(^PRCA(433,"ATD",RCDEBTDA,RCEXDATE,RCTRANDA))
if 'RCTRANDA
QUIT
Begin DoDot:3
+71 ; type of transaction is not an exemption
+72 SET RCEXDATA=$GET(^PRCA(433,RCTRANDA,1))
+73 IF $PIECE(RCEXDATA,"^",2)'=14
QUIT
+74 ;
+75 ; get the next transaction for the bill
+76 SET RCNEXT=$ORDER(^PRCA(433,"C",+$PIECE($GET(^PRCA(433,+RCTRANDA,0)),"^",2),RCTRANDA))
+77 ; is it a payment?, if no, quit
+78 SET RCPADATA=$GET(^PRCA(433,+RCNEXT,1))
+79 IF $PIECE(RCPADATA,"^",2)'=2
IF $PIECE(RCPADATA,"^",2)'=34
QUIT
+80 ;
+81 ; check to see if this is an automatic exemption,
+82 ; if not, then do not change the date
+83 IF $GET(^PRCA(433,RCTRANDA,7,1,0))'["Auto"
QUIT
+84 ;
+85 ; it is a payment, if the date of the payment is greater
+86 ; than the date of the exemption by more than 1 minute,
+87 ; change the exemption date to be equal to the payment date
+88 IF ($PIECE(RCPADATA,"^",9)-$PIECE(RCEXDATA,"^",9))>.0001
SET X=$$EDIT433^RCBEUTRA(RCTRANDA,"19////"_$PIECE(RCPADATA,"^",9)_";")
End DoDot:3
End DoDot:2
End DoDot:1
+89 ;
+90 ; recheck the accounts out of balance
+91 ;used to count accts out of balance prior to install
SET RCTOTAL1=0
+92 ;used to count accts fixed by the patch
SET RCTOTAL2=0
+93 SET RCDEBTDA=0
+94 FOR
SET RCDEBTDA=$ORDER(^TMP("PRCAI169",$JOB,RCDEBTDA))
if 'RCDEBTDA
QUIT
Begin DoDot:1
+95 ; check to see if account has a bill in refund review.
+96 ; if it does, remove it from the list.
+97 IF $$REFUREVW^RCBEREFU(RCDEBTDA)
KILL ^TMP("PRCAI169",$JOB,RCDEBTDA)
QUIT
+98 ; original count of accounts out of balance before patch install
+99 SET RCTOTAL1=RCTOTAL1+1
+100 ; check to see if account is out of balance. if it is
+101 ; not out of balance, remove it from the list.
+102 SET OUTOFBAL=$$EN^PRCAMRKC(RCDEBTDA)
+103 IF 'OUTOFBAL
SET RCTOTAL2=RCTOTAL2+1
KILL ^TMP("PRCAI169",$JOB,RCDEBTDA)
End DoDot:1
+104 ;
+105 ; build mailman message showing patch installed and accounts still
+106 ; out of balance
+107 KILL ^TMP($JOB,"RCRJRCORMM")
+108 SET ^TMP($JOB,"RCRJRCORMM",1)="The Post-Initialization routine for patch PRCA*4.5*169 is completed."
+109 SET ^TMP($JOB,"RCRJRCORMM",2)="Patch PRCA*4.5*169 has been completely installed."
+110 SET ^TMP($JOB,"RCRJRCORMM",3)=" "
+111 SET ^TMP($JOB,"RCRJRCORMM",4)="The following accounts are still out of balance after the patch install."
+112 SET ^TMP($JOB,"RCRJRCORMM",5)="This list excludes accounts with bills in refund review."
+113 SET ^TMP($JOB,"RCRJRCORMM",6)=" "
+114 SET RCLINE=6
+115 SET RCDEBTDA=0
+116 FOR
SET RCDEBTDA=$ORDER(^TMP("PRCAI169",$JOB,RCDEBTDA))
if 'RCDEBTDA
QUIT
Begin DoDot:1
+117 SET ACCTDATA=$$ACCNTHDR^RCDPAPLM(RCDEBTDA)
+118 SET DATA=$EXTRACT($PIECE(ACCTDATA,"^")_" ",1,30)_" "
+119 SET DATA=DATA_$EXTRACT($PIECE(ACCTDATA,"^",2)_" ",1,12)_" "
+120 SET DATA=DATA_$PIECE(ACCTDATA,"^",3)
+121 SET RCLINE=RCLINE+1
SET ^TMP($JOB,"RCRJRCORMM",RCLINE)=DATA
End DoDot:1
+122 ;
+123 SET RCLINE=RCLINE+1
SET ^TMP($JOB,"RCRJRCORMM",RCLINE)=" "
+124 SET RCLINE=RCLINE+1
SET ^TMP($JOB,"RCRJRCORMM",RCLINE)=" TOTAL ACCOUNTS OUT OF BALANCE BEFORE PATCH INSTALL: "_$JUSTIFY(RCTOTAL1,8)
+125 SET RCLINE=RCLINE+1
SET ^TMP($JOB,"RCRJRCORMM",RCLINE)=" TOTAL ACCOUNTS FIXED BY PATCH: "_$JUSTIFY(RCTOTAL2,8)
+126 SET RCLINE=RCLINE+1
SET ^TMP($JOB,"RCRJRCORMM",RCLINE)=" "_$JUSTIFY("--------",8)
+127 SET RCLINE=RCLINE+1
SET ^TMP($JOB,"RCRJRCORMM",RCLINE)=" TOTAL ACCOUNTS OUT OF BALANCE AFTER PATCH INSTALL: "_$JUSTIFY((RCTOTAL1-RCTOTAL2),8)
+128 ;
+129 ; send mail message
+130 ; difrom needs to be newed or mailman will not deliver the message
+131 NEW DIFROM,XMDUN,XMY,XMZ
+132 SET XMY("G.IRM")=""
+133 SET XMY("G.PRCA ADJUSTMENT TRANS")=""
+134 SET XMY(.5)=""
+135 SET XMY(DUZ)=""
+136 SET XMZ=$$SENDMSG^RCRJRCOR("AR Patch 169 Installation Completed",.XMY)
+137 KILL ^TMP($JOB,"RCRJRCORMM")
+138 ;
+139 KILL ^TMP("PRCAI169",$JOB)
+140 ;
+141 ; set the end date for the post initialization
+142 DO END^RCMSPOST(RCMSPOST)
+143 QUIT
