RCY208PO ;ALB/TMK - PRCA*4.5*208 POST-INSTALL ;08-JAN-2004
;;4.5;Accounts Receivable;**208**;Mar 20, 1995
;
POST ;Set up check points for post-init
N %
S %=$$NEWCP^XPDUTL("REV","REVIEW^RCY208PO")
S %=$$NEWCP^XPDUTL("INDX","INDEX^RCY208PO")
S %=$$NEWCP^XPDUTL("CLEAN","CLEANUP^RCY208PO")
S %=$$NEWCP^XPDUTL("END","END^RCY208PO") ; Leave as last update
Q
;
REVIEW N %,RCB,RCZ,RCZ0,RCY,RC,RCWP,DD,DO,DA,X,Y,DLAYGO,DIC,DIK,DIU
D BMES^XPDUTL("Moving review comments into new fields")
S RCZ=+$$PARCP^XPDUTL("REV") ; Get the last entry processed on a previous install of this patch
D BMES^XPDUTL("Starting at entry # "_(RCZ+1))
F S RCZ=$O(^RCY(344.49,RCZ)) Q:'RCZ S RCZ0=0 F S RCZ0=$O(^RCY(344.49,RCZ,1,RCZ0)) Q:'RCZ0 I $D(^RCY(344.49,RCZ,1,RCZ0,3,0)) D
. I $O(^RCY(344.49,RCZ,1,RCZ0,3,0)) D ; If any review data, create new entry for review
.. S DA(2)=RCZ,DA(1)=RCZ0,DIC(0)="L",DLAYGO=344.4914,DIC="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",4,",X=$$NOW^XLFDT(),DIC("DR")=".02////.5" K DO,DD D FILE^DICN K DO,DD,DLAYGO,DIC ; Add the multiple
.. S RCY=+Y
.. ;Add comment line to indicate post-install moved text and then move the rest of the existing text after it.
.. K RCWP
.. S RCWP(1)="REVIEW COPIED HERE BY POST-INSTALL FOR e-PAYMENTS ENHANCEMENTS PATCH"
.. S RC=1,RCB=0 F S RCB=$O(^RCY(344.49,RCZ,1,RCZ0,3,RCB)) Q:'RCB S RC=RC+1,RCWP(RC)=$G(^(RCB,0))
.. D WP^DIE(344.4914,RCY_","_RCZ0_","_RCZ_",",.03,"","RCWP")
. I $D(^RCY(344.49,RCZ,1,RCZ0,3)) D WP^DIE(344.491,RCZ0_","_RCZ_",",3,"","@")
. S %=$$UPCP^XPDUTL("REV",RCZ) ; Store the last record processed in the file
; Now delete the DD entry completely from the system
D BMES^XPDUTL("Deleting the old REVIEW NOTES field definition")
S DIU(0)="S",DIU=344.4913 D EN^DIU2
D COMPLETE
Q
;
INDEX ; Re-index the FILE DATE/TIME field (.07) in file 344.4
D BMES^XPDUTL("Creating new 'AFD' cross ref for field FILE DATE/TIME (#.07) in the ELECTRONIC REMITTANCE ADVICE file (#344.4)")
I '$D(^RCY(344.4,"AFD")) S DIK="^RCY(344.4,",DIK(1)=.07 D ENALL^DIK
D COMPLETE
Q
CLEANUP ; Cleans up the EFTs matched to paper EOBs being unmatched
N Z,Z0,Z1,Z2,DIE,DA,DR,RCCT
D BMES^XPDUTL("Cleaning up EFTs matched to paper EOBs")
S Z=0 F S Z=$O(^RCY(344.31,Z)) Q:'Z S Z0=$G(^(Z,0)) D
. S Z1=$O(^RCY(344,"AEFT",Z,0))
. Q:'Z1 ; No receipt exists for the EFT detail
. I '$P(Z0,U,8) D Q ; Marked as not matched for EFT detail
.. S Z2=$G(^RCY(344,Z1,0)),DIE="^RCY(344,",DA=Z,DR=".08////"_$S($P(Z2,U,18):1,1:2) D ^DIE ; Update the match status of EFT detail
. I $P(Z0,U,8)["1",$P(Z0,U,10) D ; EFT is matched with an ERA
.. S Z2=$G(^RCY(344.4,+$P(Z0,U,10),0))
.. I $P(Z2,U,8)'=Z1 D ; EFT detail receipt is not the ERA's receipt
... S DA=Z,DR=".1///@;.08////2",DIE="^RCY(344.31," D ^DIE
.. ; Now if no receipt on ERA, change it to matched to paper EOB
.. I '$P(Z2,U,8) S DA=+$P(Z0,U,10),DIE="^RCY(344.4,",DR=".09////4;.14////3;20.03////1" D ^DIE
D COMPLETE
D BMES^XPDUTL("Cleaning up 0-payment ERAs matched to paper check")
S RCCT="NO"
S Z=0 F S Z=$O(^RCY(344.4,Z)) Q:'Z S Z0=$G(^(Z,0)) I $P(Z0,U,15)="CHK",'$P(Z0,U,5),$P(Z0,U,9)=2 S DIE="^RCY(344.4,",DR=".09////3;.14////3",DA=Z D ^DIE S RCCT=RCCT+1
D BMES^XPDUTL(RCCT_" ERAs marked as 'MATCH - 0 PAYMENT'")
D COMPLETE
Q
;
COMPLETE ;
D BMES^XPDUTL("Step complete.")
Q
;
END ;
D BMES^XPDUTL("Post install complete.")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCY208PO 3423 printed Apr 09, 2024@20:51:11 Page 2
RCY208PO ;ALB/TMK - PRCA*4.5*208 POST-INSTALL ;08-JAN-2004
+1 ;;4.5;Accounts Receivable;**208**;Mar 20, 1995
+2 ;
POST ;Set up check points for post-init
+1 NEW %
+2 SET %=$$NEWCP^XPDUTL("REV","REVIEW^RCY208PO")
+3 SET %=$$NEWCP^XPDUTL("INDX","INDEX^RCY208PO")
+4 SET %=$$NEWCP^XPDUTL("CLEAN","CLEANUP^RCY208PO")
+5 ; Leave as last update
SET %=$$NEWCP^XPDUTL("END","END^RCY208PO")
+6 QUIT
+7 ;
REVIEW NEW %,RCB,RCZ,RCZ0,RCY,RC,RCWP,DD,DO,DA,X,Y,DLAYGO,DIC,DIK,DIU
+1 DO BMES^XPDUTL("Moving review comments into new fields")
+2 ; Get the last entry processed on a previous install of this patch
SET RCZ=+$$PARCP^XPDUTL("REV")
+3 DO BMES^XPDUTL("Starting at entry # "_(RCZ+1))
+4 FOR
SET RCZ=$ORDER(^RCY(344.49,RCZ))
if 'RCZ
QUIT
SET RCZ0=0
FOR
SET RCZ0=$ORDER(^RCY(344.49,RCZ,1,RCZ0))
if 'RCZ0
QUIT
IF $DATA(^RCY(344.49,RCZ,1,RCZ0,3,0))
Begin DoDot:1
+5 ; If any review data, create new entry for review
IF $ORDER(^RCY(344.49,RCZ,1,RCZ0,3,0))
Begin DoDot:2
+6 ; Add the multiple
SET DA(2)=RCZ
SET DA(1)=RCZ0
SET DIC(0)="L"
SET DLAYGO=344.4914
SET DIC="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",4,"
SET X=$$NOW^XLFDT()
SET DIC("DR")=".02////.5"
KILL DO,DD
DO FILE^DICN
KILL DO,DD,DLAYGO,DIC
+7 SET RCY=+Y
+8 ;Add comment line to indicate post-install moved text and then move the rest of the existing text after it.
+9 KILL RCWP
+10 SET RCWP(1)="REVIEW COPIED HERE BY POST-INSTALL FOR e-PAYMENTS ENHANCEMENTS PATCH"
+11 SET RC=1
SET RCB=0
FOR
SET RCB=$ORDER(^RCY(344.49,RCZ,1,RCZ0,3,RCB))
if 'RCB
QUIT
SET RC=RC+1
SET RCWP(RC)=$GET(^(RCB,0))
+12 DO WP^DIE(344.4914,RCY_","_RCZ0_","_RCZ_",",.03,"","RCWP")
End DoDot:2
+13 IF $DATA(^RCY(344.49,RCZ,1,RCZ0,3))
DO WP^DIE(344.491,RCZ0_","_RCZ_",",3,"","@")
+14 ; Store the last record processed in the file
SET %=$$UPCP^XPDUTL("REV",RCZ)
End DoDot:1
+15 ; Now delete the DD entry completely from the system
+16 DO BMES^XPDUTL("Deleting the old REVIEW NOTES field definition")
+17 SET DIU(0)="S"
SET DIU=344.4913
DO EN^DIU2
+18 DO COMPLETE
+19 QUIT
+20 ;
INDEX ; Re-index the FILE DATE/TIME field (.07) in file 344.4
+1 DO BMES^XPDUTL("Creating new 'AFD' cross ref for field FILE DATE/TIME (#.07) in the ELECTRONIC REMITTANCE ADVICE file (#344.4)")
+2 IF '$DATA(^RCY(344.4,"AFD"))
SET DIK="^RCY(344.4,"
SET DIK(1)=.07
DO ENALL^DIK
+3 DO COMPLETE
+4 QUIT
CLEANUP ; Cleans up the EFTs matched to paper EOBs being unmatched
+1 NEW Z,Z0,Z1,Z2,DIE,DA,DR,RCCT
+2 DO BMES^XPDUTL("Cleaning up EFTs matched to paper EOBs")
+3 SET Z=0
FOR
SET Z=$ORDER(^RCY(344.31,Z))
if 'Z
QUIT
SET Z0=$GET(^(Z,0))
Begin DoDot:1
+4 SET Z1=$ORDER(^RCY(344,"AEFT",Z,0))
+5 ; No receipt exists for the EFT detail
if 'Z1
QUIT
+6 ; Marked as not matched for EFT detail
IF '$PIECE(Z0,U,8)
Begin DoDot:2
+7 ; Update the match status of EFT detail
SET Z2=$GET(^RCY(344,Z1,0))
SET DIE="^RCY(344,"
SET DA=Z
SET DR=".08////"_$SELECT($PIECE(Z2,U,18):1,1:2)
DO ^DIE
End DoDot:2
QUIT
+8 ; EFT is matched with an ERA
IF $PIECE(Z0,U,8)["1"
IF $PIECE(Z0,U,10)
Begin DoDot:2
+9 SET Z2=$GET(^RCY(344.4,+$PIECE(Z0,U,10),0))
+10 ; EFT detail receipt is not the ERA's receipt
IF $PIECE(Z2,U,8)'=Z1
Begin DoDot:3
+11 SET DA=Z
SET DR=".1///@;.08////2"
SET DIE="^RCY(344.31,"
DO ^DIE
End DoDot:3
+12 ; Now if no receipt on ERA, change it to matched to paper EOB
+13 IF '$PIECE(Z2,U,8)
SET DA=+$PIECE(Z0,U,10)
SET DIE="^RCY(344.4,"
SET DR=".09////4;.14////3;20.03////1"
DO ^DIE
End DoDot:2
End DoDot:1
+14 DO COMPLETE
+15 DO BMES^XPDUTL("Cleaning up 0-payment ERAs matched to paper check")
+16 SET RCCT="NO"
+17 SET Z=0
FOR
SET Z=$ORDER(^RCY(344.4,Z))
if 'Z
QUIT
SET Z0=$GET(^(Z,0))
IF $PIECE(Z0,U,15)="CHK"
IF '$PIECE(Z0,U,5)
IF $PIECE(Z0,U,9)=2
SET DIE="^RCY(344.4,"
SET DR=".09////3;.14////3"
SET DA=Z
DO ^DIE
SET RCCT=RCCT+1
+18 DO BMES^XPDUTL(RCCT_" ERAs marked as 'MATCH - 0 PAYMENT'")
+19 DO COMPLETE
+20 QUIT
+21 ;
COMPLETE ;
+1 DO BMES^XPDUTL("Step complete.")
+2 QUIT
+3 ;
END ;
+1 DO BMES^XPDUTL("Post install complete.")
+2 QUIT
+3 ;
