RCY220PT ;ALB/ARH/MAF - POST INIT FILES 347.3 & 430.2 - POST INIT ; 5/1/97
;;4.5;Accounts Receivable;**220**;Mar 20, 1995
;
D EN,EN1
Q
EN ; Add new Revenue Source Codes to file 347.3
D BMES^XPDUTL("Updating file 347.3 REVENUE SOURCE CODE with new codes...")
D MES^XPDUTL(" ")
N DLAYGO,DIC,DIE,DD,DO,DA,DR,X,Y,RCA,RCFL,RCI,RCLN,RCCNT,RCFN,RCINACT S RCCNT=0
;
F RCI=1:1 S RCLN=$P($T(RSC+RCI),";;",2) Q:RCLN="END" D
. ;
. I $D(^RC(347.3,"B",$P(RCLN,U,1))) S RCFL=0 D SET Q
. ;
. S RCCNT=RCCNT+1,RCINACT=" "
. S ^RC(347.3,$P(RCLN,U,1),0)=RCLN
. S ^RC(347.3,"B",$P(RCLN,U,1),$P(RCLN,U,1))=""
. S ^RC(347.3,"C",$E($P(RCLN,U,2),1,30),$P(RCLN,U,1))=""
. S RCFL=1 D SET
D BMES^XPDUTL(" * "_RCCNT_" Revenue Source Codes #347.3 added")
D BSQ
Q
EN1 ; Add new categories to the ACCOUNTS RECEIVABLE CATEGORY file 430.2
D BMES^XPDUTL("Updating file 430.2 ACCOUNTS RECEIVABLE CATEGORY with new categories...")
D MES^XPDUTL(" ")
N DLAYGO,DIC,DIE,DD,DO,DA,DR,X,Y,RCA,RCFL,RCI,RCLN,RCCNT,RCFN,RCINACT S RCCNT=0
;
F RCI=1:1 S RCLN=$P($T(CAT+RCI),";;",2) Q:RCLN="END" D
. ;
. I $D(^PRCA(430.2,"B",$P(RCLN,U,1))) S RCFL=0 D SET Q
. ;
. K DD,DO S DLAYGO=430.2,DIC="^PRCA(430.2,",DIC(0)="L",X=$P(RCLN,U,1) D FILE^DICN K DIC I Y<1 K X,Y Q
. S RCFN=+Y,RCCNT=RCCNT+1,RCINACT=" "
. ;
. S DR="1////"_$P(RCLN,U,2)_";2////"_$P(RCLN,U,3)_";3////"_$P(RCLN,U,4)_";5////"_$P(RCLN,U,6)_";6////"_$P(RCLN,U,7)_";7////"_$P(RCLN,U,8)_";12////"_$P(RCLN,U,9)_";9////"_$P(RCLN,U,10)_";10////"_$P(RCLN,U,11)
. S DR=DR_";11////"_$P(RCLN,U,12)_";13////"_$P(RCLN,U,13)
. S DIE="^PRCA(430.2,",DA=+RCFN D ^DIE K DIE,DA,DR,X,Y
. S RCFL=1 D SET
. Q
D BMES^XPDUTL(" * "_RCCNT_" Accounts Receivable Category #430.2 added")
;
BSQ ;
;S RCA(1)=" * "_RCCNT_" Revenue Source Codes (#347.3)"
D BMES^XPDUTL(.RCA)
Q
;
;
SET ; SET RCA() FOR DISPLAY
S RCA(RCI)=" "_$P(RCLN,U,1)_" "_$P(RCLN,U,2)_" "_$S(RCFL=1:"*** Code Added ***",1:"*** Duplicate ***")
Q
;
;
RSC ; Revenue Source Code (347.3) CODE^CODE NAME^INACTIVE
;;1010^Interest Revenue
;;8038^Economic Act-All Other
;;8083^Enhanced Use Lease
;;9041^Spec Donations
;;9042^Spec Donations
;;9045^General Donations
;;9046^General Donations
;;9057^Rental
;;END
Q
CAT ;New Categories to be entered into file 430.2
;;NURSING HOME PROCEEDS^NH^0^1228^^O^5^2^0^1^1^1^2
;;PARKING FEES^PF^0^1228^^O^6^2^0^1^1^1^2
;;CWT PROCEEDS^CW^0^1228^^O^7^2^0^1^1^1^2
;;COMP & PEN PROCEEDS^CM^0^1228^^O^8^2^0^1^1^1^2
;;ENHANCED USE LEASE PROCEEDS^EP^0^1228^^O^10^2^0^1^1^1^2
;;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCY220PT 2615 printed Dec 13, 2024@01:49:55 Page 2
RCY220PT ;ALB/ARH/MAF - POST INIT FILES 347.3 & 430.2 - POST INIT ; 5/1/97
+1 ;;4.5;Accounts Receivable;**220**;Mar 20, 1995
+2 ;
+3 DO EN
DO EN1
+4 QUIT
EN ; Add new Revenue Source Codes to file 347.3
+1 DO BMES^XPDUTL("Updating file 347.3 REVENUE SOURCE CODE with new codes...")
+2 DO MES^XPDUTL(" ")
+3 NEW DLAYGO,DIC,DIE,DD,DO,DA,DR,X,Y,RCA,RCFL,RCI,RCLN,RCCNT,RCFN,RCINACT
SET RCCNT=0
+4 ;
+5 FOR RCI=1:1
SET RCLN=$PIECE($TEXT(RSC+RCI),";;",2)
if RCLN="END"
QUIT
Begin DoDot:1
+6 ;
+7 IF $DATA(^RC(347.3,"B",$PIECE(RCLN,U,1)))
SET RCFL=0
DO SET
QUIT
+8 ;
+9 SET RCCNT=RCCNT+1
SET RCINACT=" "
+10 SET ^RC(347.3,$PIECE(RCLN,U,1),0)=RCLN
+11 SET ^RC(347.3,"B",$PIECE(RCLN,U,1),$PIECE(RCLN,U,1))=""
+12 SET ^RC(347.3,"C",$EXTRACT($PIECE(RCLN,U,2),1,30),$PIECE(RCLN,U,1))=""
+13 SET RCFL=1
DO SET
End DoDot:1
+14 DO BMES^XPDUTL(" * "_RCCNT_" Revenue Source Codes #347.3 added")
+15 DO BSQ
+16 QUIT
EN1 ; Add new categories to the ACCOUNTS RECEIVABLE CATEGORY file 430.2
+1 DO BMES^XPDUTL("Updating file 430.2 ACCOUNTS RECEIVABLE CATEGORY with new categories...")
+2 DO MES^XPDUTL(" ")
+3 NEW DLAYGO,DIC,DIE,DD,DO,DA,DR,X,Y,RCA,RCFL,RCI,RCLN,RCCNT,RCFN,RCINACT
SET RCCNT=0
+4 ;
+5 FOR RCI=1:1
SET RCLN=$PIECE($TEXT(CAT+RCI),";;",2)
if RCLN="END"
QUIT
Begin DoDot:1
+6 ;
+7 IF $DATA(^PRCA(430.2,"B",$PIECE(RCLN,U,1)))
SET RCFL=0
DO SET
QUIT
+8 ;
+9 KILL DD,DO
SET DLAYGO=430.2
SET DIC="^PRCA(430.2,"
SET DIC(0)="L"
SET X=$PIECE(RCLN,U,1)
DO FILE^DICN
KILL DIC
IF Y<1
KILL X,Y
QUIT
+10 SET RCFN=+Y
SET RCCNT=RCCNT+1
SET RCINACT=" "
+11 ;
+12 SET DR="1////"_$PIECE(RCLN,U,2)_";2////"_$PIECE(RCLN,U,3)_";3////"_$PIECE(RCLN,U,4)_";5////"_$PIECE(RCLN,U,6)_";6////"_$PIECE(RCLN,U,7)_";7////"_$PIECE(RCLN,U,8)_";12////"_$PIECE(RCLN,U,9)_";9////"_$PIECE(RCLN,U,10)_";10////"_$PIECE(RCL
N,U,11)
+13 SET DR=DR_";11////"_$PIECE(RCLN,U,12)_";13////"_$PIECE(RCLN,U,13)
+14 SET DIE="^PRCA(430.2,"
SET DA=+RCFN
DO ^DIE
KILL DIE,DA,DR,X,Y
+15 SET RCFL=1
DO SET
+16 QUIT
End DoDot:1
+17 DO BMES^XPDUTL(" * "_RCCNT_" Accounts Receivable Category #430.2 added")
+18 ;
BSQ ;
+1 ;S RCA(1)=" * "_RCCNT_" Revenue Source Codes (#347.3)"
+2 DO BMES^XPDUTL(.RCA)
+3 QUIT
+4 ;
+5 ;
SET ; SET RCA() FOR DISPLAY
+1 SET RCA(RCI)=" "_$PIECE(RCLN,U,1)_" "_$PIECE(RCLN,U,2)_" "_$SELECT(RCFL=1:"*** Code Added ***",1:"*** Duplicate ***")
+2 QUIT
+3 ;
+4 ;
RSC ; Revenue Source Code (347.3) CODE^CODE NAME^INACTIVE
+1 ;;1010^Interest Revenue
+2 ;;8038^Economic Act-All Other
+3 ;;8083^Enhanced Use Lease
+4 ;;9041^Spec Donations
+5 ;;9042^Spec Donations
+6 ;;9045^General Donations
+7 ;;9046^General Donations
+8 ;;9057^Rental
+9 ;;END
+10 QUIT
CAT ;New Categories to be entered into file 430.2
+1 ;;NURSING HOME PROCEEDS^NH^0^1228^^O^5^2^0^1^1^1^2
+2 ;;PARKING FEES^PF^0^1228^^O^6^2^0^1^1^1^2
+3 ;;CWT PROCEEDS^CW^0^1228^^O^7^2^0^1^1^1^2
+4 ;;COMP & PEN PROCEEDS^CM^0^1228^^O^8^2^0^1^1^1^2
+5 ;;ENHANCED USE LEASE PROCEEDS^EP^0^1228^^O^10^2^0^1^1^1^2
+6 ;;END
