PRCAP310 ;DRF/Albany - PRCA*4.5*310 POST INSTALL;09/10/15 2:10pm
;;4.5;Accounts Receivable;**310**;Mar 20, 1995;Build 14
;Per VA Directive 6402, this routine should not be modified.
Q
;
POSTINIT ;Post Install for PRCA*4.5*310
D BMES^XPDUTL(" >> Starting the Post-Initialization routine ")
; AR CATEGORIES and REVENUE SOURCE CODES
D ARCAT
D REVSC
D FUND
D APPR
D BMES^XPDUTL(" >> End of the Post-Initialization routine ")
Q
;
;
ARCAT ;AR CATEGORY ENTRIES (430.2)
N DA,DIC,DIE,DIK,DINUM,DLAYGO,DR,RCDATA,RCDINUM,X,Y
D MES^XPDUTL(" -> Adding new AR CATEGORY entries to file 430.2 ...")
S RCDINUM=45,(DIC,DIE)="^PRCA(430.2,",DIC(0)="L",DLAYGO=430.2
; if the entry is in the file, delete it first to add fields uneditable
I $D(^PRCA(430.2,RCDINUM,0)) S DIK="^PRCA(430.2,",DA=RCDINUM D ^DIK
S DINUM=RCDINUM
S X="FEE REIMB INS"
; set the field values
S DA=RCDINUM,DIC("DR")=""
S DIC("DR")=DIC("DR")_"1///FR;"
S DIC("DR")=DIC("DR")_"2///249;"
S DIC("DR")=DIC("DR")_"3///1212;"
S DIC("DR")=DIC("DR")_"4///;"
S DIC("DR")=DIC("DR")_"5///T;"
S DIC("DR")=DIC("DR")_"6///47;"
S DIC("DR")=DIC("DR")_"7///2;"
S DIC("DR")=DIC("DR")_"12///1;"
S DIC("DR")=DIC("DR")_"9///0;"
S DIC("DR")=DIC("DR")_"10///0;"
S DIC("DR")=DIC("DR")_"11///0;"
S DIC("DR")=DIC("DR")_"13///2;"
D FILE^DICN
D MES^XPDUTL(" AR CATEGORY completed.")
Q
;
;
REVSC ;REVENUE SOURCE CODE entries in file #347.3
N I,RSCDATA,DIC,Y,GBL,DA,X,DIE,DR
D MES^XPDUTL(" -> Adding new REVENUE SOURCE CODE entries to file 347.3 ...")
S GBL="^RC(347.3,"
F I=1:1 D Q:RSCDATA="END"
. S RSCDATA=$P($T(NEWRSC+I),";",3,99)
. Q:RSCDATA="END"
. ; do a lookup and continue if exists.
. S DIC=GBL,X=$P(RSCDATA,";") D ^DIC
. I +Y>0 S DIK=GBL,DA=+Y D ^DIK
. ; add entry
. S X=$P(RSCDATA,";")
. S DIC("DR")=".02///"_$P(RSCDATA,";",2)_";"
. S DIC("DR")=DIC("DR")_".03///0;"
. D FILE^DICN
. I +Y=-1 D
. . D MES^XPDUTL(" "_$P(RSCDATA,";")_" failed to add!")
D MES^XPDUTL(" REVENUE SOURCE CODES completed.")
Q
;
;
FUND ;PRCD FUND entry in 420.14
N DA,DIC,DIK,DLAYGO,FUND,X,Y
D MES^XPDUTL(" -> Adding new PRCD FUND entry to file 420.14 ...")
S DIC="^PRCD(420.14,",DIC(0)="L",DLAYGO=420.14,FUND=528713
; if the entry is in the file, delete it first to add fields uneditable
S X=FUND D ^DIC I +Y>0 S DA=+Y,DIK="^PRCD(420.14," D ^DIK
; add entry
S X=FUND
S DIC("DR")="1////MCCF-FEE-COLL FUND-3RD PARTY;"
S DIC("DR")=DIC("DR")_"2///2016;"
S DIC("DR")=DIC("DR")_"3///2016;"
S DIC("DR")=DIC("DR")_"4.7///NET;"
S DIC("DR")=DIC("DR")_"5///A;"
S DIC("DR")=DIC("DR")_"4.5///N;"
D FILE^DICN
D MES^XPDUTL(" PRCD FUND completed.")
Q
;
;
APPR ;PRCD FUND/APPROPRIATION CODE entry in 420.3
N DA,DIC,DIE,DIK,DINUM,DLAYGO,DR,RCDATA,RCDINUM,X,Y
D MES^XPDUTL(" -> Adding new PRCD FUND/APPROPRIATION CODE entry to file 420.3 ...")
; install entries in file 420.3
S FUND=528713,DIC="^PRCD(420.3,",DIC(0)="L",DLAYGO=420.3
; if the entry is in the file, delete it first to add fields uneditable
S X=FUND D ^DIC I +Y>0 S DA=+Y,DIK="^PRCD(420.3," D ^DIK
; add entry
S X=FUND
S DIC("DR")="2////36_5287.13;"
S DIC("DR")=DIC("DR")_"4///36_5287.13;"
S DIC("DR")=DIC("DR")_"6///528713;"
S DIC("DR")=DIC("DR")_"7///Y;"
D FILE^DICN
D MES^XPDUTL(" PRCD FUND/APPROPRIATION CODE completed.")
Q
;
;
;Revenue Source Codes (RSC#)
NEWRSC ;SOURCE CODE;NAME
;;8F1Z;FEE BASIS INPATIENT
;;8F2Z;FEE BASIS OUTPATIENT
;;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAP310 3560 printed Apr 09, 2024@20:50:52 Page 2
PRCAP310 ;DRF/Albany - PRCA*4.5*310 POST INSTALL;09/10/15 2:10pm
+1 ;;4.5;Accounts Receivable;**310**;Mar 20, 1995;Build 14
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
POSTINIT ;Post Install for PRCA*4.5*310
+1 DO BMES^XPDUTL(" >> Starting the Post-Initialization routine ")
+2 ; AR CATEGORIES and REVENUE SOURCE CODES
+3 DO ARCAT
+4 DO REVSC
+5 DO FUND
+6 DO APPR
+7 DO BMES^XPDUTL(" >> End of the Post-Initialization routine ")
+8 QUIT
+9 ;
+10 ;
ARCAT ;AR CATEGORY ENTRIES (430.2)
+1 NEW DA,DIC,DIE,DIK,DINUM,DLAYGO,DR,RCDATA,RCDINUM,X,Y
+2 DO MES^XPDUTL(" -> Adding new AR CATEGORY entries to file 430.2 ...")
+3 SET RCDINUM=45
SET (DIC,DIE)="^PRCA(430.2,"
SET DIC(0)="L"
SET DLAYGO=430.2
+4 ; if the entry is in the file, delete it first to add fields uneditable
+5 IF $DATA(^PRCA(430.2,RCDINUM,0))
SET DIK="^PRCA(430.2,"
SET DA=RCDINUM
DO ^DIK
+6 SET DINUM=RCDINUM
+7 SET X="FEE REIMB INS"
+8 ; set the field values
+9 SET DA=RCDINUM
SET DIC("DR")=""
+10 SET DIC("DR")=DIC("DR")_"1///FR;"
+11 SET DIC("DR")=DIC("DR")_"2///249;"
+12 SET DIC("DR")=DIC("DR")_"3///1212;"
+13 SET DIC("DR")=DIC("DR")_"4///;"
+14 SET DIC("DR")=DIC("DR")_"5///T;"
+15 SET DIC("DR")=DIC("DR")_"6///47;"
+16 SET DIC("DR")=DIC("DR")_"7///2;"
+17 SET DIC("DR")=DIC("DR")_"12///1;"
+18 SET DIC("DR")=DIC("DR")_"9///0;"
+19 SET DIC("DR")=DIC("DR")_"10///0;"
+20 SET DIC("DR")=DIC("DR")_"11///0;"
+21 SET DIC("DR")=DIC("DR")_"13///2;"
+22 DO FILE^DICN
+23 DO MES^XPDUTL(" AR CATEGORY completed.")
+24 QUIT
+25 ;
+26 ;
REVSC ;REVENUE SOURCE CODE entries in file #347.3
+1 NEW I,RSCDATA,DIC,Y,GBL,DA,X,DIE,DR
+2 DO MES^XPDUTL(" -> Adding new REVENUE SOURCE CODE entries to file 347.3 ...")
+3 SET GBL="^RC(347.3,"
+4 FOR I=1:1
Begin DoDot:1
+5 SET RSCDATA=$PIECE($TEXT(NEWRSC+I),";",3,99)
+6 if RSCDATA="END"
QUIT
+7 ; do a lookup and continue if exists.
+8 SET DIC=GBL
SET X=$PIECE(RSCDATA,";")
DO ^DIC
+9 IF +Y>0
SET DIK=GBL
SET DA=+Y
DO ^DIK
+10 ; add entry
+11 SET X=$PIECE(RSCDATA,";")
+12 SET DIC("DR")=".02///"_$PIECE(RSCDATA,";",2)_";"
+13 SET DIC("DR")=DIC("DR")_".03///0;"
+14 DO FILE^DICN
+15 IF +Y=-1
Begin DoDot:2
+16 DO MES^XPDUTL(" "_$PIECE(RSCDATA,";")_" failed to add!")
End DoDot:2
End DoDot:1
if RSCDATA="END"
QUIT
+17 DO MES^XPDUTL(" REVENUE SOURCE CODES completed.")
+18 QUIT
+19 ;
+20 ;
FUND ;PRCD FUND entry in 420.14
+1 NEW DA,DIC,DIK,DLAYGO,FUND,X,Y
+2 DO MES^XPDUTL(" -> Adding new PRCD FUND entry to file 420.14 ...")
+3 SET DIC="^PRCD(420.14,"
SET DIC(0)="L"
SET DLAYGO=420.14
SET FUND=528713
+4 ; if the entry is in the file, delete it first to add fields uneditable
+5 SET X=FUND
DO ^DIC
IF +Y>0
SET DA=+Y
SET DIK="^PRCD(420.14,"
DO ^DIK
+6 ; add entry
+7 SET X=FUND
+8 SET DIC("DR")="1////MCCF-FEE-COLL FUND-3RD PARTY;"
+9 SET DIC("DR")=DIC("DR")_"2///2016;"
+10 SET DIC("DR")=DIC("DR")_"3///2016;"
+11 SET DIC("DR")=DIC("DR")_"4.7///NET;"
+12 SET DIC("DR")=DIC("DR")_"5///A;"
+13 SET DIC("DR")=DIC("DR")_"4.5///N;"
+14 DO FILE^DICN
+15 DO MES^XPDUTL(" PRCD FUND completed.")
+16 QUIT
+17 ;
+18 ;
APPR ;PRCD FUND/APPROPRIATION CODE entry in 420.3
+1 NEW DA,DIC,DIE,DIK,DINUM,DLAYGO,DR,RCDATA,RCDINUM,X,Y
+2 DO MES^XPDUTL(" -> Adding new PRCD FUND/APPROPRIATION CODE entry to file 420.3 ...")
+3 ; install entries in file 420.3
+4 SET FUND=528713
SET DIC="^PRCD(420.3,"
SET DIC(0)="L"
SET DLAYGO=420.3
+5 ; if the entry is in the file, delete it first to add fields uneditable
+6 SET X=FUND
DO ^DIC
IF +Y>0
SET DA=+Y
SET DIK="^PRCD(420.3,"
DO ^DIK
+7 ; add entry
+8 SET X=FUND
+9 SET DIC("DR")="2////36_5287.13;"
+10 SET DIC("DR")=DIC("DR")_"4///36_5287.13;"
+11 SET DIC("DR")=DIC("DR")_"6///528713;"
+12 SET DIC("DR")=DIC("DR")_"7///Y;"
+13 DO FILE^DICN
+14 DO MES^XPDUTL(" PRCD FUND/APPROPRIATION CODE completed.")
+15 QUIT
+16 ;
+17 ;
+18 ;Revenue Source Codes (RSC#)
NEWRSC ;SOURCE CODE;NAME
+1 ;;8F1Z;FEE BASIS INPATIENT
+2 ;;8F2Z;FEE BASIS OUTPATIENT
+3 ;;END
