Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCA45PT

PRCA45PT.m

Go to the documentation of this file. 
  1. PRCA45PT ;W-CIOFO/MAF - FOR IFCAP PURGE ; 09-JULY-97
  1. V ;;4.5;Accounts Receivable;**88**;Mar 20, 1995
  1.  ;
  1.  ;
  1.  ; -- IFCAP archive - need to remove AR pointers to file 442.
  1.  ;    
  1.  ;
  1.  ; -- Delete the data for the PAT REF # in the Fiscal Year multiple
  1.  ;    in files 430 and 433.  They have pointers to file 442.
  1.  ;
  1.  ; -- This will be a one time deletion of data in those fields and
  1.  ;    those fields will be '*' for deletion in 18 months.
  1.  D BMES^XPDUTL("*** Tasking the cleanup of the PAT REF # field of the Fiscal Year multiple")
  1.  D MES^XPDUTL("    and the cross references on the PAT REF # subfield")
  1.  D MES^XPDUTL("    for files 430 ACCOUNTS RECEIVABLE and 433 AR TRANSACTION ***")
  1.  D BMES^XPDUTL("*** You will receive a mail message when this job has run to completion ***")
  1.  D BMES^XPDUTL("*** PLEASE DO NO DELETE ROUTINE PRCA45PT UNTIL YOU RECEIVE A MESSAGE")
  1.  D MES^XPDUTL("     STATING THE POST INIT HAS RUN TO COMPLETION ***")
  1.  N ZTSK,ZTDTH,ZTRTN,ZTDESC,ZTSAVE,ZTIO,PRCATIME
  1.  S ZTDTH=$H
  1.  S ZTRTN="EN^PRCA45PT",ZTDESC="PRCA - CLEANUP OF FILES 430/433 PAT REF #",ZTIO="" D ^%ZTLOAD D HOME^%ZIS
  1.  Q
  1.  ;
  1. EN D XCLN,430,433 ;  delete pat/ref # from accounts receivable and AR transaction files
  1.  N PRCA,XMDUZ,XMY,XMTEXT,XMSUB
  1.  S XMSUB="CLEANUP OF FILES 430/433 of PAT REF # DATA"
  1.  S XMTEXT="PRCA("
  1.  S PRCA(1)="The Accounts Receivable patch PRCA*4.5*88 has run to completion"
  1.  S PRCA(2)="NO ERRORS or PROBLEMS were found."
  1.  S PRCA(3)="  "
  1.  S PRCA(4)="*** YOU MAY NOW DELETE THE ROUTINE PRCA445PT ***"
  1.  S XMY(DUZ)=""
  1.  S XMDUZ=.5
  1.  D ^XMD
  1.  Q
  1. 430 ; delete pat/ref # from accounts receivable file
  1.  ; loop thru file 430
  1.  N PRCATIEN,PRCAPAT,PRCAFY
  1.  S PRCATIEN=0 F  S PRCATIEN=$O(^PRCA(430,PRCATIEN)) Q:'PRCATIEN  I $D(^PRCA(430,PRCATIEN,2,0)) D
  1.  .S PRCAFY=0 F  S PRCAFY=$O(^PRCA(430,PRCATIEN,2,PRCAFY)) Q:'PRCAFY  S PRCAPAT=$P($G(^PRCA(430,PRCATIEN,2,PRCAFY,0)),"^",3) I PRCAPAT]"" D
  1.  ..L +^PRCA(430,PRCATIEN)
  1.  ..S $P(^PRCA(430,PRCATIEN,2,PRCAFY,0),"^",3)=""
  1.  ..K ^PRCA(430,PRCATIEN,2,"C")
  1.  ..L -^PRCA(430,PRCATIEN)
  1.  K ^PRCA(430,"F")
  1.  Q
  1.  ;
  1. 433 ; delete pat/ref # from ar transactions file
  1.  ;Looping thru file 433 to delete pat ref #
  1.  N PRCATIEN,PRCAPAT,PRCAFY
  1.  S PRCATIEN=0 F  S PRCATIEN=$O(^PRCA(433,PRCATIEN)) Q:'PRCATIEN  I $D(^PRCA(433,PRCATIEN,4,0)) D
  1.  .S PRCAFY=0 F  S PRCAFY=$O(^PRCA(433,PRCATIEN,4,PRCAFY)) Q:'PRCAFY  S PRCAPAT=$P($G(^PRCA(433,PRCATIEN,4,PRCAFY,0)),"^",3) I PRCAPAT]"" D
  1.  ..L +^PRCA(433,PRCATIEN)
  1.  ..S $P(^PRCA(433,PRCATIEN,4,PRCAFY,0),"^",3)=""
  1.  ..K ^PRCA(433,PRCATIEN,4,"C")
  1.  ..L -^PRCA(433,PRCATIEN)
  1.  K ^PRCA(433,"D")
  1.  Q
  1. XCLN ; in 430 and 433, delete all xrefs for PAT REF # fields in those files
  1.  N PRCAX,DIK,DA,PRCAXREF,PRCAFIL
  1.  ;
  1.  D BMES^XPDUTL("Post Init cleaning up cross references on the PAT REF # field in files 430/433")
  1.  D BMES^XPDUTL("*** Killing cross references 'F' and 'C' for the PAT REF # subfield of the")
  1.  D MES^XPDUTL("Fiscal Year multiple in file 430")
  1.  D BMES^XPDUTL("*** Killing cross references 'D' and 'C' for the PAT REF # subfield of the")
  1.  D MES^XPDUTL("Fiscal Year multiple in file 433")
  1.  D BMES^XPDUTL(" ")
  1.  ;
  1.  F PRCAFIL=430.01,433.01 D
  1.  .F PRCAXREF=1,2 D
  1.  .. S DIK="^DD("_PRCAFIL_",2,1,",DA(2)=PRCAFIL,DA(1)=2,DA=PRCAXREF
  1.  .. D ^DIK K DIK,DA
  1.  .. S PRCAX="   >> ^PRCA("_PRCAFIL_",2,1,"_PRCAXREF_") cross references deleted." D MES^XPDUTL(PRCAX)
  1.  Q