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

PRCAP338.m

Go to the documentation of this file. 
  1. PRCAP338 ;SAB/Albany - PRCA*4.5*338 POST INSTALL;12/11/17 2:10pm
  1.  ;;4.5;Accounts Receivable;**338**;Mar 20, 1995;Build 69
  1.  ;Per VA Directive 6402, this routine should not be modified.
  1.  Q
  1.  ;
  1. POSTINIT ;Post Install for PRCA*4.5*338
  1.  D BMES^XPDUTL(" >>  Starting the Post-Initialization routine for PRCA*4.5*338 ")
  1.  ; Adding AR CATEGORIES and REVENUE SOURCE CODES
  1.  D ARCAT
  1.  D ARCATUPD
  1.  D CHRGUPD
  1.  D FND714
  1.  D APPR714
  1.  D FNDR1
  1.  D APPRR1
  1.  D REVSC
  1.  D BMES^XPDUTL(" >>  End of the Post-Initialization routine for PRCA*4.5*338")
  1.  Q
  1.  ;
  1. ARCAT ;AR CATEGORY ENTRIES (430.2)
  1.  N LOOP,FDA,FDAIEN,DATA,CHK
  1.  ;
  1.  D MES^XPDUTL("     -> Adding new AR CATEGORY entries to file 430.2 ...")
  1.  ; Add new AR categories
  1.  F LOOP=2:1:38 D
  1.  . ;Clear the array
  1.  . K FDA
  1.  . ;Extract the new AR Category to be added.
  1.  . S DATA=$T(ARDATA+LOOP)
  1.  . ;Check to insure that the AR Category doesn't exist already
  1.  . S CHK=""  ; Initialized the check variable
  1.  . S CHK=$O(^PRCA(430.2,"B",$P(DATA,";",3),""))
  1.  . Q:CHK'=""
  1.  . ;Store in array for adding to the file (#430.2).
  1.  . S FDA(430.2,"+1,",.01)=$P(DATA,";",3)   ;AR Category Name
  1.  . S FDA(430.2,"+1,",1)=$P(DATA,";",4)     ;Abbreviation
  1.  . S FDA(430.2,"+1,",2)=$P(DATA,";",5)     ;Segment
  1.  . S FDA(430.2,"+1,",3)=$P(DATA,";",6)     ;GL #
  1.  . S FDA(430.2,"+1,",5)=$P(DATA,";",7)     ;Type
  1.  . S FDA(430.2,"+1,",6)=$P(DATA,";",8)     ;Category Number
  1.  . S FDA(430.2,"+1,",7)=$P(DATA,";",9)     ;Receivable Code
  1.  . S FDA(430.2,"+1,",9)=$P(DATA,";",10)    ;Charge Interest
  1.  . S FDA(430.2,"+1,",10)=$P(DATA,";",11)   ;Charge Admin
  1.  . S FDA(430.2,"+1,",11)=$P(DATA,";",12)   ;Charge Penalty
  1.  . S FDA(430.2,"+1,",12)=$P(DATA,";",13)   ;Accrued
  1.  . S FDA(430.2,"+1,",13)=$P(DATA,";",14)   ;Refund/Reimbursement
  1.  . S FDA(430.2,"+1,",14)=$P(DATA,";",15)   ;Paragraph Codes
  1.  . ;Add to the file.
  1.  . D UPDATE^DIE(,"FDA","FDAIEN")
  1.  . S FDAIEN=FDAIEN(1) K FDAIEN(1)
  1.  D MES^XPDUTL("        New AR CATEGORIES added.")
  1.  Q
  1.  ;
  1. ARDATA ; New AR Category data. (Internal data format)
  1.  ;;Category Name;Abbreviation;AMIS Seg #;GL Number;Type;AR Cat #;Receivable Code;Interest;Admin;Penalty;Accrued;Refund;Paragraph Codes
  1.  ;;CHOICE THIRD PARTY;C1;249;1212;T;50;2;0;0;0;1;2;
  1.  ;;CC THIRD PARTY;C2;249;1212;T;51;2;0;0;0;1;2;
  1.  ;;CCN THIRD PARTY;C3;249;1212;T;52;2;0;0;0;1;2;
  1.  ;;CC MTF THIRD PARTY;C4;249;1212;T;53;2;0;0;0;1;2;
  1.  ;;CHOICE NO-FAULT AUTO;C5;247;1212;T;54;2;0;0;0;1;2;
  1.  ;;CHOICE TORT FEASOR;C6;0;1228;T;55;2;0;0;0;1;2;
  1.  ;;CCN WORKERS' COMP;CD;246;1212;T;56;2;0;0;0;1;2;
  1.  ;;CCN NO-FAULT AUTO;CB;247;1212;T;57;2;0;0;0;1;2;
  1.  ;;CCN TORT FEASOR;CC;0;1228;T;58;2;0;0;0;1;2;
  1.  ;;CC WORKERS' COMP;CA;246;1212;T;59;2;0;0;0;1;2;
  1.  ;;CC NO-FAULT AUTO;C8;247;1212;T;60;2;0;0;0;1;2;
  1.  ;;CC TORT FEASOR;C9;0;1228;T;61;2;0;0;0;1;2;
  1.  ;;CHOICE WORKERS' COMP;C7;246;1212;T;62;2;0;0;0;1;2;
  1.  ;;CHOICE INPT;CF;240;1221;P;63;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
  1.  ;;CHOICE RX CO-PAYMENT;CG;294;1212;P;64;2;1;1;0;1;2;25,40,55,80,85,50,60,65,70
  1.  ;;CC INPT;CJ;240;1221;P;65;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
  1.  ;;CC RX CO-PAYMENT;CK;294;1212;P;66;2;1;1;0;1;2;25,40,55,80,85,50,60,65,70
  1.  ;;CCN INPT;CO;240;1221;P;67;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
  1.  ;;CCN RX CO-PAYMENT;CQ;294;1212;P;68;2;1;1;0;1;2;25,40,55,80,85,50,60,65,70
  1.  ;;CC MTF INPT;CX;240;1221;P;69;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
  1.  ;;CC MTF RX CO-PAYMENT;CY;294;1212;P;70;2;1;1;0;1;2;25,40,55,80,85,50,60,65,70
  1.  ;;CC NURSING HOME CARE - LTC;CL;0;1319;P;71;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
  1.  ;;CC RESPITE CARE;CN;0;1319;P;72;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
  1.  ;;CCN NURSING HOME CARE - LTC;CR;0;1319;P;73;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
  1.  ;;CCN RESPITE CARE;CU;0;1319;P;74;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
  1.  ;;CHOICE NURSING HOME CARE - LTC;CH;0;1319;P;75;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
  1.  ;;CHOICE RESPITE CARE;CI;0;1319;P;76;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
  1.  ;;TRICARE DES;T4;0;1311;T;77;2;0;0;0;0;2
  1.  ;;TRICARE SCI;T5;0;1311;T;78;2;0;0;0;0;2
  1.  ;;TRICARE TBI;T6;0;1311;T;79;2;0;0;0;0;2
  1.  ;;TRICARE BLIND REHABILITATION;T7;0;1311;T;80;2;0;0;0;0;2
  1.  ;;TRICARE DENTAL;T8;0;1311;T;81;2;0;0;0;0;2
  1.  ;;TRICARE PHARMACY;T9;0;1311;T;82;2;0;0;0;0;2
  1.  ;;CHOICE OPT;CZ;240;1221;P;83;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
  1.  ;;CC OPT;D1;240;1221;P;84;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
  1.  ;;CCN OPT;D2;240;1221;P;85;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
  1.  ;;CC MTF OPT;D3;240;1221;P;86;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
  1.  ;;END
  1.  ;
  1. ARCATUPD ; AR CATEGORY ENTRIES (430.2)
  1.  N LOOP,LIEN,PRCAARY,PRCADATA,PRCAARCT
  1.  N PRCADMC,PRCATOP,PRCACS
  1.  N X,Y,DIE,DA,DR,DTOUT,DATA
  1.  ;
  1.  D MES^XPDUTL("     -> Adding data to the new AR CATEGORY (430.2) fields ...")
  1.  ;Clear the array
  1.  K PRCAARY
  1.  ; Grab all of the entries to update
  1.  F LOOP=2:1 S PRCADATA=$T(ARUPDDAT+LOOP) Q:PRCADATA=" ;;END"  D
  1.  . ;Extract the new AR Category to be added.
  1.  . S PRCAARCT=$P(PRCADATA,";",4)
  1.  . ;Store in array for adding to the file (#430.2).
  1.  . S PRCAARY(PRCAARCT)=$P(PRCADATA,";",5,7)
  1.  ;
  1.  ;Loop through all of the entries in the AC xref of the 430.2 file, and update using the built array
  1.  F LOOP=1:1:86 D
  1.  . S DATA=$G(PRCAARY(LOOP))
  1.  . Q:DATA=""    ;go to next entry if Category is not to be updated.
  1.  . S LIEN=$O(^PRCA(430.2,"AC",LOOP,""))
  1.  . Q:LIEN=""
  1.  . S PRCADMC=$P(DATA,";",1)
  1.  . S PRCATOP=$P(DATA,";",2)
  1.  . S PRCACS=$P(DATA,";",3)
  1.  . ;
  1.  . ; File the update
  1.  . S DR="1.01////"_PRCADMC_";"
  1.  . S DR=DR_"1.02////"_PRCATOP_";"
  1.  . S DR=DR_"1.03////"_PRCACS_";"
  1.  . Q:DR=""
  1.  . S DIE="^PRCA(430.2,",DA=LIEN
  1.  . D ^DIE
  1.  . K DR   ;Clear update array before next use
  1.  ;
  1.  S DR=""
  1.  D MES^XPDUTL("        Data added to the new AR CATEGORY (430.2) fields.")
  1.  Q
  1.  ;
  1. ARUPDDAT ; Data for the new AR Category fields. (All categories will be updated)
  1.  ;;Category Name;Category Num;DMC?;TOP?;CS?
  1.  ;;ADULT DAY HEALTH CARE;40;1;2;3
  1.  ;;C (MEANS TEST);24;1;2;3
  1.  ;;CHAMPVA;36;0;0;0
  1.  ;;CHAMPVA SUBSISTENCE;34;0;0;0
  1.  ;;CHAMPVA THIRD PARTY;35;0;0;0
  1.  ;;COMP & PEN PROCEEDS;8;0;0;0
  1.  ;;CRIME OF PER.VIO.;27;0;0;0
  1.  ;;CURRENT EMP.;14;0;1;0
  1.  ;;CWT PROCEEDS;7;0;0;0
  1.  ;;DOMICILIARY;41;1;2;3
  1.  ;;EMERGENCY/HUMANITARIAN;25;0;1;0
  1.  ;;EMERGENCY/HUMANITARIAN REIMB.;48;0;0;0
  1.  ;;ENHANCED USE LEASE PROCEEDS;10;0;1;0
  1.  ;;EX-EMPLOYEE;13;0;1;0
  1.  ;;FEDERAL AGENCIES-REFUND;15;0;0;0
  1.  ;;FEDERAL AGENCIES-REIMB.;16;0;0;0
  1.  ;;FEE REIMB INS;47;0;0;0
  1.  ;;GERIATRIC EVAL-INSTITUTIONAL;44;1;2;3
  1.  ;;GERIATRIC EVAL-NON-INSTITUTION;45;1;2;3
  1.  ;;HOSPITAL CARE (NSC);1;1;2;3
  1.  ;;HOSPITAL CARE PER DIEM;32;1;2;3
  1.  ;;INELIGIBLE HOSP.;20;0;1;0
  1.  ;;INELIGIBLE HOSP. REIMB.;49;0;0;0
  1.  ;;INTERAGENCY;19;0;0;0
  1.  ;;MEDICARE;28;0;0;0
  1.  ;;MILITARY;17;0;0;0
  1.  ;;NO-FAULT AUTO ACC.;26;0;0;0
  1.  ;;NURSING HOME CARE PER DIEM;31;1;2;3
  1.  ;;NURSING HOME CARE(NSC);3;1;2;3
  1.  ;;NURSING HOME CARE-LTC;46;1;2;3
  1.  ;;NURSING HOME PROCEEDS;5;1;2;3
  1.  ;;OUTPATIENT CARE(NSC);2;1;2;3
  1.  ;;PARKING FEES;6;0;1;0
  1.  ;;PREPAYMENT;33;0;0;0
  1.  ;;REIMBURS.HEALTH INS;21;0;0;0
  1.  ;;RESPITE CARE-INSTITUTIONAL;42;1;2;3
  1.  ;;RESPITE CARE-NON-INSTITUTIONAL;43;1;2;3
  1.  ;;RX CO-PAYMENT/NSC VET;30;1;2;3
  1.  ;;RX CO-PAYMENT/SC VET;29;1;2;3
  1.  ;;SHARING AGREEMENTS;18;0;1;0
  1.  ;;TORT FEASOR;22;0;0;0
  1.  ;;TRICARE;37;0;0;0
  1.  ;;TRICARE PATIENT;38;1;2;3
  1.  ;;TRICARE THIRD PARTY;39;0;0;0
  1.  ;;VENDOR;11;0;1;0
  1.  ;;WORKMAN'S COMP.;23;0;0;0
  1.  ;;CHOICE THIRD PARTY;50;0;0;0
  1.  ;;CC THIRD PARTY;51;0;0;0
  1.  ;;CCN THIRD PARTY;52;0;0;0
  1.  ;;CC MTF THIRD PARTY;53;0;0;0
  1.  ;;CHOICE NO-FAULT AUTO;54;0;0;0
  1.  ;;CHOICE TORT FEASOR;55;0;0;0
  1.  ;;CCN WORKERS' COMP;56;0;0;0
  1.  ;;CCN NO-FAULT AUTO;57;0;0;0
  1.  ;;CCN TORT FEASOR;58;0;0;0
  1.  ;;CC WORKERS' COMP;59;0;0;0
  1.  ;;CC NO-FAULT AUTO;60;0;0;0
  1.  ;;CC TORT FEASOR;61;0;0;0
  1.  ;;CHOICE WORKERS' COMP;62;0;0;0
  1.  ;;CHOICE C (MEANS TEST);63;1;2;3
  1.  ;;CHOICE RX CO-PAYMENT;64;1;2;3
  1.  ;;CC C (MEANS TEST);65;1;2;3
  1.  ;;CC RX CO-PAYMENT;66;1;2;3
  1.  ;;CCN C (MEANS TEST);67;1;2;3
  1.  ;;CCN RX CO-PAYMENT;68;1;2;3
  1.  ;;CC MTF C (MEANS TEST);69;1;2;3
  1.  ;;CC MTF RX CO-PAYMENT;70;1;2;3
  1.  ;;CC NURSING HOME CARE - LTC;71;1;2;3
  1.  ;;CC RESPITE CARE;72;1;2;3
  1.  ;;CCN NURSING HOME CARE - LTC;73;1;2;3
  1.  ;;CCN RESPITE CARE;74;1;2;3
  1.  ;;CHOICE NURSING HOME CARE - LTC;75;1;2;3
  1.  ;;CHOICE RESPITE CARE;76;1;2;3
  1.  ;;TRICARE DES;77;0;0;0
  1.  ;;TRICARE SCI;78;0;0;0
  1.  ;;TRICARE TBI;79;0;0;0
  1.  ;;TRICARE BLIND REHABILITATION;80;0;0;0
  1.  ;;TRICARE DENTAL;81;0;0;0
  1.  ;;TRICARE PHARMACY;82;0;0;0
  1.  ;;CHOICE OPT;83;1;2;3
  1.  ;;CC OPT;84;1;2;3
  1.  ;;CCN OPT;85;1;2;3
  1.  ;;CC MTF OPT;86;1;2;3
  1.  ;;END
  1.  ;
  1. CHRGUPD ; Update the charge flags
  1.  N RCLOOP,RCIEN,RCDATA,RCINT,RCADMIN,RCPEN,RCCAT
  1.  N X,Y,DIE,DA,DR,DTOUT
  1.  ;
  1.  D MES^XPDUTL("     -> Updating Charge flags in select AR CATEGORY (430.2) entries ...")
  1.  ;Clear the array
  1.  K PRCAARY
  1.  ; Grab all of the entries to update
  1.  F RCLOOP=1:1 S RCDATA=$T(CUPDDT+RCLOOP) Q:RCDATA=" ;;END"  D
  1.  . S RCCAT=$P(RCDATA,";",4)
  1.  . S RCIEN=$O(^PRCA(430.2,"AC",RCCAT,""))
  1.  . Q:RCIEN=""
  1.  . S RCINT=$P(RCDATA,";",5)
  1.  . S RCADMIN=$P(RCDATA,";",6)
  1.  . S RCPEN=$P(RCDATA,";",7)
  1.  . ;
  1.  . ; File the update
  1.  . S DR="9////"_RCINT_";"
  1.  . S DR=DR_"10////"_RCADMIN_";"
  1.  . S DR=DR_"11////"_RCPEN_";"
  1.  . Q:DR=""
  1.  . S DIE="^PRCA(430.2,",DA=RCIEN
  1.  . D ^DIE
  1.  . K DR   ;Clear update array before next use
  1.  ;
  1.  S DR=""
  1.  D MES^XPDUTL("        Charge Flags in select AR CATEGORY (430.2) entries.")
  1.  Q
  1.  ;
  1. CUPDDT ; Charge flag update data
  1.  ;;ADULT DAY HEALTH CARE;40;1;1;0
  1.  ;;COMP & PEN PROCEEDS;8;0;0;0
  1.  ;;CRIME OF PER.VIO.;27;0;0;0
  1.  ;;CWT PROCEEDS;7;0;0;0
  1.  ;;DOMICILIARY;41;1;1;0
  1.  ;;GERIATRIC EVAL-INSTITUTIONAL;44;1;1;0
  1.  ;;GERIATRIC EVAL-NON-INSTITUTION;45;1;1;0
  1.  ;;NO-FAULT AUTO ACC.;26;0;0;0
  1.  ;;NURSING HOME CARE-LTC;46;1;1;0
  1.  ;;NURSING HOME PROCEEDS;5;0;0;0
  1.  ;;RESPITE CARE-INSTITUTIONAL;42;1;1;0
  1.  ;;RESPITE CARE-NON-INSTITUTIONAL;43;1;1;0
  1.  ;;TORT FEASOR;22;0;0;0
  1.  ;;END
  1. ENV ;environment check
  1.  S XPDABORT=""   ;Package level variable. Don't New
  1.  D DBCHK(.XPDABORT) ;checks for fund existence
  1.  I XPDABORT="" K XPDABORT
  1.  Q
  1.  ;
  1. DBCHK(XPDABORT) ;checks for test/production account
  1.  N RCMISS,RCIEN
  1.  ;
  1.  S RCMISS=0  ; Set the missing flag to False (No Funds missing)
  1.  ;
  1.  ; check to see if 0160R1 is properly defined
  1.  S RCIEN=$O(^PRCD(420.3,"B","0160R1","")) S:'RCIEN RCMISS=1
  1.  S RCIEN=$O(^PRCD(420.14,"B","0160R1","")) S:'RCIEN RCMISS=1
  1.  ;
  1.  ; If not defined properly (RCMISS=1) warn user and abort the installation.
  1.  I RCMISS DO
  1.  . D BMES^XPDUTL("******")
  1.  . D MES^XPDUTL("The new 0160R1 fund has not been fully defined for this facility.")
  1.  . D MES^XPDUTL("This facility is not yet ready for the installation of PRCA*4.5*338.")
  1.  . D MES^XPDUTL("Installation aborted.")
  1.  . D MES^XPDUTL("******")
  1.  . S XPDABORT=2
  1.  Q
  1.  ;
  1. FND714 ;PRCD FUND entry 528714 in 420.14
  1.  N DA,DIC,DIK,DLAYGO,FUND,X,Y
  1.  D MES^XPDUTL("     -> Adding new PRCD FUND entry 528714 to file 420.14 ...")
  1.  S DIC="^PRCD(420.14,",DIC(0)="L",DLAYGO=420.14,FUND=528714
  1.  ; if the entry is in the file, delete it first to add fields uneditable
  1.  S X=FUND D ^DIC I +Y>0 S DA=+Y,DIK="^PRCD(420.14," D ^DIK
  1.  ; add entry
  1.  S X=FUND
  1.  S DIC("DR")="1////MCCF-FEE-COLL FUND-1ST PARTY;"
  1.  S DIC("DR")=DIC("DR")_"2///2018;"
  1.  S DIC("DR")=DIC("DR")_"3///2018;"
  1.  S DIC("DR")=DIC("DR")_"4.7///NET;"
  1.  S DIC("DR")=DIC("DR")_"5///A;"
  1.  S DIC("DR")=DIC("DR")_"4.5///N;"
  1.  D FILE^DICN
  1.  D MES^XPDUTL("        PRCD FUND completed.")
  1.  Q
  1.  ;
  1. APPR714 ;PRCD FUND/APPROPRIATION CODE entry 528714 in 420.3
  1.  N DA,DIC,DIE,DIK,DINUM,DLAYGO,DR,RCDATA,RCDINUM,X,Y
  1.  D MES^XPDUTL("     -> Adding new PRCD FUND/APPROPRIATION CODE entry 528714 to file 420.3 ...")
  1.  ;  install entries in file 420.3
  1.  S FUND=528714,DIC="^PRCD(420.3,",DIC(0)="L",DLAYGO=420.3
  1.  ;  if the entry is in the file, delete it first to add fields uneditable
  1.  S X=FUND D ^DIC I +Y>0 S DA=+Y,DIK="^PRCD(420.3," D ^DIK
  1.  ;  add entry
  1.  S X=FUND
  1.  S DIC("DR")="2////36_5287.14;"
  1.  S DIC("DR")=DIC("DR")_"4///36_5287.14;"
  1.  S DIC("DR")=DIC("DR")_"6///528714;"
  1.  S DIC("DR")=DIC("DR")_"7///Y;"
  1.  D FILE^DICN
  1.  D MES^XPDUTL("        PRCD FUND/APPROPRIATION CODE completed.")
  1.  Q
  1.  ;
  1. FNDR1 ;PRCD FUND entry 0160R1 into 420.14
  1.  N DA,DIC,DIK,DLAYGO,FUND,X,Y
  1.  D MES^XPDUTL("     -> Adding new PRCD FUND entry 0160R1 to file 420.14 ...")
  1.  S DIC="^PRCD(420.14,",DIC(0)="L",DLAYGO=420.14,FUND="0160R1"
  1.  ; if the entry is in the file, delete it first to add fields uneditable
  1.  S X=FUND D ^DIC I +Y>0 S DA=+Y,DIK="^PRCD(420.14," D ^DIK
  1.  ; add entry
  1.  S X=FUND
  1.  S DIC("DR")="1////MEDICAL SERVICE - LIM1;"
  1.  S DIC("DR")=DIC("DR")_"2///2018;"
  1.  S DIC("DR")=DIC("DR")_"3///2018;"
  1.  S DIC("DR")=DIC("DR")_"4.7///NET;"
  1.  S DIC("DR")=DIC("DR")_"5///A;"
  1.  S DIC("DR")=DIC("DR")_"4.5///Y;"
  1.  D FILE^DICN
  1.  D MES^XPDUTL("        PRCD FUND completed.")
  1.  Q
  1.  ;
  1. APPRR1 ;PRCD FUND/APPROPRIATION CODE entry 0160R1 into 420.3
  1.  N DA,DIC,DIE,DIK,DINUM,DLAYGO,DR,RCDATA,RCDINUM,X,Y
  1.  D MES^XPDUTL("     -> Adding new PRCD FUND/APPROPRIATION CODE entry 0160R1 to file 420.3 ...")
  1.  ;  install entries in file 420.3
  1.  S FUND="0160R1",DIC="^PRCD(420.3,",DIC(0)="L",DLAYGO=420.3
  1.  ;  if the entry is in the file, delete it first to add fields uneditable
  1.  S X=FUND D ^DIC I +Y>0 S DA=+Y,DIK="^PRCD(420.3," D ^DIK
  1.  ;  add entry
  1.  S X=FUND
  1.  S DIC("DR")="2////36_0160;"
  1.  S DIC("DR")=DIC("DR")_"4///36 0160;"
  1.  S DIC("DR")=DIC("DR")_"6///0160R1;"
  1.  D FILE^DICN
  1.  D MES^XPDUTL("        PRCD FUND/APPROPRIATION CODE completed.")
  1.  Q
  1.  ;
  1. REVSC ;REVENUE SOURCE CODE entries in file #347.3
  1.  N RCLOOP,RSCDATA,DIC,Y,GBL,DA,X,DIE,DR
  1.  D MES^XPDUTL("     -> Adding new REVENUE SOURCE CODE entries to file 347.3 ...")
  1.  S GBL="^RC(347.3,"
  1.  F RCLOOP=1:1 D  Q:RSCDATA="END"
  1.  . S RSCDATA=$P($T(NEWRSC+RCLOOP),";",3,99)
  1.  . Q:RSCDATA="END"
  1.  . ; do a lookup and continue if exists.
  1.  . S DIC=GBL,X=$P(RSCDATA,";",2) D ^DIC
  1.  . I +Y>0 S DIK=GBL,DA=+Y D ^DIK
  1.  . ; add entry
  1.  . S X=$P(RSCDATA,";",2)
  1.  . S DIC("DR")=".02///"_$P(RSCDATA,";")_";"
  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("        REVENUE SOURCE CODES completed.")
  1.  ;
  1. NEWRSC ;New Revenue Source Codes (RSC#)
  1.  ;;DOD DISABILITY EVALUATION SYSTEM (DES);8085
  1.  ;;DOD SPINAL CORD INPATIENT;8086
  1.  ;;DOD SPINAL CORD OUTPATIENT;8087
  1.  ;;DOD SPINAL CORD OTHER;8088
  1.  ;;DOD TRAUMATIC BRAIN INJURY INPATIENT;8089
  1.  ;;TRAUMATIC BRAIN INJURY OUTPATIENT;8090
  1.  ;;TRAUMATIC BRAIN INJURY OTHER;8091
  1.  ;;BLIND REHABILITATION INPATIENT;8092
  1.  ;;BLIND REHABILITATION OUTPATIENT;8093
  1.  ;;BLIND REHABILITATION OTHER;8094
  1.  ;;TRICARE PHARMACY;8095
  1.  ;;TRICARE ACTIVE DUTY DENTAL;8096
  1.  ;;END