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

PRCA315P.m

Go to the documentation of this file. 
  1. PRCA315P ;SLT/BAA-PRCA*4.5*315 POST INSTALL ;1 Mar 97
  1.  ;;4.5;Accounts Receivable;**315**;Mar 20, 1995;Build 67
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1. POSTINIT ;
  1.  ;
  1.  D BMES^XPDUTL(" >>  Starting the Post-Initialization routine ...")
  1.  D MES^XPDUTL(" ")
  1.  ; AR CATEGORIES
  1.  D ARCAT
  1.  D REVSC
  1.  D DELOPT
  1.  D CRSSVC
  1.  D CSJOB
  1.  D MES^XPDUTL(" >>  End of the Post-Initialization routine ...")
  1.  Q
  1.  ;
  1.  ;
  1. ARCAT ;AR CATEGORY ENTRIES (430.2)
  1.  N %,ARNAME,D,D0,DA,DI,DIC,DIE,DIK,DINUM,DLAYGO,DQ,DR,RCDATA,RCDINUM,X,Y,FLG,RCS
  1.  D MES^XPDUTL("     -> Adding new ACCOUNTS RECEIVABLE CATEGORY file (#430.2) entries ...")
  1.  ;
  1.  ;  install entries in file 430.2
  1.  S FLG=0
  1.  F RCDINUM=46,47 D
  1.  . S RCS="CT"_RCDINUM
  1.  . S RCDATA=$P($T(@RCS),";",3,99)
  1.  . S (DIC,DIE)="^PRCA(430.2,",DIC(0)="L",DLAYGO=430.2
  1.  . ;
  1.  . S ARNAME=$P(RCDATA,";")
  1.  . ;
  1.  . I $D(^PRCA(430.2,RCDINUM,0)) S DIK="^PRCA(430.2,",DA=RCDINUM D ^DIK
  1.  . ;
  1.  . S (DIC,DIE)="^PRCA(430.2,",DIC(0)="L",DLAYGO=430.2
  1.  . ;
  1.  . ;  set the fields
  1.  . S (DINUM,DA)=RCDINUM,X=ARNAME
  1.  . S DIC("DR")="1///"_$P(RCDATA,";",2)_";2///"_$P(RCDATA,";",3)_";3///"_$P(RCDATA,";",6)_";5///"_$P(RCDATA,";",5)_";6///"_$P(RCDATA,";",4)
  1.  . S DIC("DR")=DIC("DR")_";7///2;9///0;10///0;11///0;12///"_$P(RCDATA,";",7)_";13///2;"
  1.  . ;  add entry
  1.  . S X=ARNAME D FILE^DICN K DIC I Y<1 K X,Y Q
  1.  . D MES^XPDUTL("        New Category "_ARNAME_" added") S FLG=1
  1.  ;
  1.  I FLG D MES^XPDUTL("        New ACCOUNTS RECEIVABLE CATEGORY file (#430.2) entries added")
  1.  D MES^XPDUTL("  ")
  1.  Q
  1.  ;
  1.  ;
  1. REVSC ;REVENUE SOURCE CODE entries in file #347.3
  1.  N I,RSCDATA,DIC,Y,GBL,DA,X,DIE,DR
  1.  D MES^XPDUTL("     -> Adding new REVENUE SOURCE CODE file (#347.3) entries ...")
  1.  S GBL="^RC(347.3,"
  1.  F I=1:1 D  Q:RSCDATA="END"
  1.  . S RSCDATA=$P($T(NEWRSC+I),";",3,99)
  1.  . Q:RSCDATA="END"
  1.  . ; do a lookup and continue if exists.
  1.  . S DIC=GBL,X=$P(RSCDATA,";") D ^DIC
  1.  . I +Y>0 S DIK=GBL,DA=+Y D ^DIK
  1.  . ; add entry
  1.  . S X=$P(RSCDATA,";")
  1.  . S DIC("DR")=".02///"_$P(RSCDATA,";",2)_";",DIC(0)="L"
  1.  . S DIC("DR")=DIC("DR")_".03///0;"
  1.  . D FILE^DICN
  1.  . I +Y=-1 D
  1.  . . D MES^XPDUTL("        "_$P(RSCDATA,";")_" failed to add!")
  1.  D MES^XPDUTL("        New REVENUE SOURCE CODE file (#347.3) entries added")
  1.  Q
  1.  ;
  1.  ;
  1. DELOPT ; remove PRCAC SET REPAYMENT option
  1.  N DA,DIK,MEN,OPT,RET
  1.  ; RET - value returned from
  1.  S MEN="PRCAC REPAYMENT MENU"
  1.  S DA(1)=+$$LKOPT^XPDMENU(MEN)
  1.  S OPT="PRCAC SET REPAYMENT"
  1.  D BMES^XPDUTL("     -> Updating ["_MEN_"]")
  1.  S RET=$$DELETE^XPDMENU(MEN,OPT)  ; delete option from menu
  1.  S DA=+$$LKOPT^XPDMENU(OPT)  ; get option IEN
  1.  I DA>0 S DIK="^DIC(19," D ^DIK  ; code can be re-run if already deleted
  1.  D MES^XPDUTL("        Menu update "_$S(RET:"completed.",1:"not needed."))
  1.  S OPT="PRCAC ENTER EDIT REPAYMENT"
  1.  S DA=+$$LKOPT^XPDMENU(OPT)  ; get option IEN
  1.  I $D(^DIC(19,DA(1),10,"B",DA)) Q  ; Option already added
  1.  D ADD^XPDMENU(MEN,OPT,"",1) ; Set Enter/Edit Repayment as the first item in Repayment Menu
  1.  Q
  1.  ;
  1. CRSSVC ;Cross-servicing - Replace (renamed) menu options - RCTCSP RECONCILIATION WORKLIST, RCTCSP RECONCIL REPORT options to menu - Cross-Servicing Menu [RCTCSP MENU]
  1.  N DA,DIK,MEN,OPT,RET
  1.  ; RET - value returned from
  1.  S MEN="RCTCSP MENU"
  1.  S DA(1)=+$$LKOPT^XPDMENU(MEN)
  1.  D BMES^XPDUTL("     -> Updating ["_MEN_"]")
  1.  F OPT="RCTCSP RECONCILIATION WORKLIST","RCTCSP RECONCIL REPORT" D
  1.  . K RET S RET=$$DELETE^XPDMENU(MEN,OPT)  ; delete option from menu
  1.  . S DA=+$$LKOPT^XPDMENU(OPT)  ; get option IEN
  1.  . D MES^XPDUTL("        Menu update to option:  "_OPT_"  "_$S(RET:"completed.",1:"not needed."))
  1.  . I $D(^DIC(19,DA(1),10,"B",DA)) Q  ; Option already added
  1.  . D ADD^XPDMENU(MEN,OPT,"")
  1.  Q
  1.  ;
  1. CSJOB ;Job the process to build the new Cross-Servicing data fields.
  1.  N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSK
  1.  ;
  1.  D BMES^XPDUTL("     -> Queuing background job to do the following:")
  1.  D MES^XPDUTL("        1. Populate Cross-Servicing indices in ACCOUNTS RECEIVABLE file (#430)")
  1.  D MES^XPDUTL("        2. Searching ACCOUNTS RECEIVABLE file (#430) for CS Stops placed")
  1.  D MES^XPDUTL("           prior to this patch in field STOP TCSP REFERRAL FLAG (#157).")
  1.  D MES^XPDUTL("        3. Populate new field ORIGINAL DATE REFERRED TO TCSP (#156) in ACCOUNTS")
  1.  D MES^XPDUTL("           RECEIVABLE file (#430).")
  1.  D MES^XPDUTL(" ")
  1.  ;
  1.  ; Setup required variables
  1.  S ZTRTN="CSJOB1^PRCA315P",ZTIO="",ZTDTH=$H
  1.  S ZTDESC="Background job to build CS indices for PRCA*4.5*315"
  1.  ;
  1.  ; Task the job
  1.  D ^%ZTLOAD
  1.  ;
  1.  ; Check if task was created
  1.  I $D(ZTSK) D MES^XPDUTL("        Task #"_ZTSK_" queued.")
  1.  I '$D(ZTSK) D MES^XPDUTL("        Task not queued.  Please create a support ticket.")
  1.  D MES^XPDUTL("  ")
  1.  Q
  1.  ;
  1. CSJOB1 ;Populate new indices in #430
  1.  K ^TMP($J)
  1.  S DIK="^PRCA(430,",DIK(1)="172" D ENALL^DIK
  1.  S ^TMP($J,"PRCA315P",1)="FILE #430 FIELD #172 INDEX POPULATED"
  1.  S DIK="^PRCA(430,",DIK(1)="301" D ENALL^DIK
  1.  S ^TMP($J,"PRCA315P",2)="FILE #430 FIELD #301 INDEX POPULATED"
  1.  ;
  1. CSSTOP ;determine CS stops placed in 430 prior to Patch 315
  1.  N RCIEN,DEBTOR,BILL,CSDATE,LIST,MSG,GLO
  1.  N DIFROM,XMDUN,XMY,XMZ ;  need to be newed or mailman will not deliver the message
  1.  S GLO=$NA(^TMP($J,"RCRJRCORMM"))
  1.  ;
  1.  S @GLO@(1)="Bills currently flagged to stop TCSP referral activity prior"
  1.  S @GLO@(2)="to PRCA*4.5*315. These bills will not show on the new report:"
  1.  S @GLO@(3)="'Cross-Servicing Stop Reactivate Report'."
  1.  S @GLO@(4)="  "
  1.  S RCIEN=0 F  S RCIEN=$O(^PRCA(430,RCIEN)) Q:'RCIEN  D
  1.  . K LIST
  1.  . I $P($G(^PRCA(430,RCIEN,15)),U,7) D
  1.  .. D GETS^DIQ(430,RCIEN_",",".01;9;158","IE","LIST","MSG")
  1.  .. S BILL=$G(LIST(430,RCIEN_",",.01,"E")),DEBTOR=$G(LIST(430,RCIEN_",",9,"E")),CSDATE=$G(LIST(430,RCIEN_",",158,"E"))
  1.  .. S @GLO@(RCIEN)=BILL_U_DEBTOR_U_CSDATE
  1.  . ;Load date into field #156, ORIGINAL DATE REFERRED TO TCSP
  1.  . I $G(^PRCA(439,RCIEN,21)) Q
  1.  . D GETS^DIQ(430,RCIEN_",","151;153;158","I","LIST","MSG")
  1.  . F I=151,153,158 I LIST(430,RCIEN_",",I,"I")?7N S ^PRCA(430,RCIEN,21)=LIST(430,RCIEN_",",I,"I") Q
  1.  S ^TMP($J,"PRCA315P",3)="BILLS CURRENTLY FLAGGED TO STOP TCSP REPORT CREATED"
  1.  S ^TMP($J,"PRCA315P",4)="FILE #430 FIELD #156 VALUES POPULATED"
  1.  S XMDUZ=.5,XMY(.5)="",XMY(DUZ)="",XMY("G.TCSP")=""
  1.  S XMZ=$$SENDMSG^RCRJRCOR("STOP TCSP REFERRAL's existing before PRCA*4.5*315",.XMY)
  1.  K ^TMP($J,"RCRJRCORMM")
  1.  S ^TMP($J,"PRCA315P",5)="BILLS CURRENTLY FLAGGED TO STOP TCSP REPORT MAIL SENT"
  1.  ;
  1.  N CNT,MSG,XMY,XMDUZ,DIFROM,XMSUB,XMTEXT
  1.  S XMY(DUZ)=""
  1.  S XMSUB="PRCA*4.5*315 Post install routine has completed",XMDUZ="Patch PRCA*4.5*315"
  1.  S XMTEXT="^TMP($J,""PRCA315P"","
  1.  D ^XMD
  1.  Q
  1.  ;
  1.  ;Revenue Source Codes (RSC#)//
  1. NEWRSC ;SOURCE CODE;NAME
  1.  ;;8VZZ;HUMAN 3RD-PRTY OUTPATIENT
  1.  ;;8UZZ;HUMAN 3RD-PRTY INPATIENT
  1.  ;;841Z;INELI 3RD-PARTY INPATIENT
  1.  ;;842Z;INELI 3RD-PARTY OUTPATIENT 
  1.  ;;END
  1.  ;
  1.  ;
  1.  ;;ACCOUNTS RECEIVABLE CATEGORY FILE (#430.2)
  1.  ;;.01 CATEGORY;1 ABBREVIATION;6 CATEGORY NUMBER;7 ACCRUED
  1. CT46 ;;EMERGENCY/HUMANITARIAN REIMB.;HR;252;48;T;1213;1
  1. CT47 ;;INELIGIBLE HOSP. REIMB.;IR;251;49;T;1213;0