PRCAP266 ;ALB/TXH - CWT Revenue Source Code Update - Post-Init;07/09/12
;;4.5;Accounts Receivable;**266**;Mar 20, 1995;Build 2
;
;** This routine is used as a Post-Init in a KIDS build for patch
;** PRCA*4.5*266 to inactive 1 existing RSC and add 5 RSCs to the
;** REVENUE SOURCE CODE (#347.3) file.
Q
;
EN ; Add/inactivate RSCs
; RCLN is in format: CODE^CODE NAME^INACTIVE
;
D:$P($T(NEW+1),";;",2)'="END" ADD
D:$P($T(OLD+1),";;",2)'="END" INACT
Q
;
ADD ; Add revenue source codes to file 347.3
;
N DA,DD,DIC,DLAYGO,DO,RCA,RCFL,RCI,RCLN,X,RCCNT
;
D BMES^XPDUTL(">>> Adding new Revenue Source Codes to REVENUE SOURCE CODE file (#347.3)...")
D MES^XPDUTL("")
S RCCNT=0,RCFL=0
;
S DIC(0)="L",DLAYGO=347.3,DIC="^RC(347.3,"
F RCI=1:1 K DD,DO,DA S RCLN=$P($T(NEW+RCI),";;",2) Q:RCLN="END" D
. S NCODE=$P(RCLN,U,1)
. ; Validate source code
. I $D(NCODE) I $L(NCODE)>4!($L(NCODE)<1)!'(NCODE'?1P.E) S RCFL=3,RCCNT=0 D SET K NCODE Q
. S DIC("DR")=".01////"_$P(RCLN,U,1)_";.02///"_$P(RCLN,U,2)
. S X=$P(RCLN,U,1)
. I $D(^RC(347.3,"B",$P(RCLN,U,1))) S RCFL=0 D SET Q
. I '$D(^RC(347.3,"B",$P(RCLN,U,1))) D FILE^DICN S RCCNT=RCCNT+1,RCFL=1 D SET Q
;
D BMES^XPDUTL(.RCA)
D BMES^XPDUTL(" *** Total "_RCCNT_" Revenue Source "_$S(RCCNT>1:"Codes",1:"Code")_" added.")
K RCCNT,RCFL,DIC,DLAYGO,RCI,DD,DO,DA,RCLN,NCODE,X,RCA,Y
Q
;
INACT ; Inactivate code
;
N RCI,RCLN,PRCADA,DA,DD,DO,DR,DIE,RCFL,RCCNT,RCA
;
D BMES^XPDUTL(">>> Inactivating Revenue Source Code in REVENUE SOURCE CODE file (#347.3)...")
D MES^XPDUTL("")
S RCCNT=0
;
F RCI=1:1 K DD,DO,DA S RCLN=$P($T(OLD+RCI),";;",2) Q:RCLN="END" D
. I +$P(RCLN,U,3)=1 D
. . S PRCADA=0
. . F S PRCADA=$O(^RC(347.3,"B",$P(RCLN,U,1),PRCADA)) Q:'PRCADA D
. . . I $D(^RC(347.3,PRCADA,0)) D
. . . . I $P($G(^RC(347.3,PRCADA,0)),U,3)=1 S RCFL=0 D SET
. . . . I $P($G(^RC(347.3,PRCADA,0)),U,3)=""!($P($G(^RC(347.3,PRCADA,0)),U,3)=0) D
. . . . . L +^RC(347.3,PRCADA):$S($G(DILOCKTM)>5:DILOCKTM,1:5)
. . . . . S RCCNT=RCCNT+1
. . . . . S DA=PRCADA,DR=".03///^S X=1",DIE="^RC(347.3,"
. . . . . D ^DIE
. . . . . S RCFL=2 D SET
. . . . . L -^RC(347.3,PRCADA)
;
D BMES^XPDUTL(.RCA)
D BMES^XPDUTL(" *** Total "_RCCNT_" Revenue Source "_$S(RCCNT>1:"Codes",1:"Code")_" inactivated.")
D MES^XPDUTL(" ")
K RCCNT,RCI,DD,DO,DA,RCLN,PRCADA,RCFL,DR,DIE,RCA
Q
;
SET ; Set RCA() for display
S RCA(RCI)=" "_$P(RCLN,U,1)_" "_$P(RCLN,U,2)_" "
S RCA(RCI)=RCA(RCI)_$S(RCFL=1:"* Code Added *",RCFL=2:"* Code Inactivated *",RCFL=3:"* Error on Code *",1:"* Duplicate *")
Q
;
NEW ; REVENUE SOURCE CODE (#347.3) - CODE^CODE NAME^INACTIVE
;;8CW1^CWT SHELTERED WORKSHOPS
;;8CW2^CWT/TRANS WORK EXP (VAMC)
;;8CW3^CWT/TWE (FED NOT VAMC)
;;8CW4^CWT/TRANS WORK EXP (NON FEDERAL)
;;8CW5^CWT/VETERANS CONSTRUCTION TEAM
;;END
;
OLD ;
;;8023^^1
;;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAP266 2911 printed Dec 13, 2024@01:40:34 Page 2
PRCAP266 ;ALB/TXH - CWT Revenue Source Code Update - Post-Init;07/09/12
+1 ;;4.5;Accounts Receivable;**266**;Mar 20, 1995;Build 2
+2 ;
+3 ;** This routine is used as a Post-Init in a KIDS build for patch
+4 ;** PRCA*4.5*266 to inactive 1 existing RSC and add 5 RSCs to the
+5 ;** REVENUE SOURCE CODE (#347.3) file.
+6 QUIT
+7 ;
EN ; Add/inactivate RSCs
+1 ; RCLN is in format: CODE^CODE NAME^INACTIVE
+2 ;
+3 if $PIECE($TEXT(NEW+1),";;",2)'="END"
DO ADD
+4 if $PIECE($TEXT(OLD+1),";;",2)'="END"
DO INACT
+5 QUIT
+6 ;
ADD ; Add revenue source codes to file 347.3
+1 ;
+2 NEW DA,DD,DIC,DLAYGO,DO,RCA,RCFL,RCI,RCLN,X,RCCNT
+3 ;
+4 DO BMES^XPDUTL(">>> Adding new Revenue Source Codes to REVENUE SOURCE CODE file (#347.3)...")
+5 DO MES^XPDUTL("")
+6 SET RCCNT=0
SET RCFL=0
+7 ;
+8 SET DIC(0)="L"
SET DLAYGO=347.3
SET DIC="^RC(347.3,"
+9 FOR RCI=1:1
KILL DD,DO,DA
SET RCLN=$PIECE($TEXT(NEW+RCI),";;",2)
if RCLN="END"
QUIT
Begin DoDot:1
+10 SET NCODE=$PIECE(RCLN,U,1)
+11 ; Validate source code
+12 IF $DATA(NCODE)
IF $LENGTH(NCODE)>4!($LENGTH(NCODE)<1)!'(NCODE'?1P.E)
SET RCFL=3
SET RCCNT=0
DO SET
KILL NCODE
QUIT
+13 SET DIC("DR")=".01////"_$PIECE(RCLN,U,1)_";.02///"_$PIECE(RCLN,U,2)
+14 SET X=$PIECE(RCLN,U,1)
+15 IF $DATA(^RC(347.3,"B",$PIECE(RCLN,U,1)))
SET RCFL=0
DO SET
QUIT
+16 IF '$DATA(^RC(347.3,"B",$PIECE(RCLN,U,1)))
DO FILE^DICN
SET RCCNT=RCCNT+1
SET RCFL=1
DO SET
QUIT
End DoDot:1
+17 ;
+18 DO BMES^XPDUTL(.RCA)
+19 DO BMES^XPDUTL(" *** Total "_RCCNT_" Revenue Source "_$SELECT(RCCNT>1:"Codes",1:"Code")_" added.")
+20 KILL RCCNT,RCFL,DIC,DLAYGO,RCI,DD,DO,DA,RCLN,NCODE,X,RCA,Y
+21 QUIT
+22 ;
INACT ; Inactivate code
+1 ;
+2 NEW RCI,RCLN,PRCADA,DA,DD,DO,DR,DIE,RCFL,RCCNT,RCA
+3 ;
+4 DO BMES^XPDUTL(">>> Inactivating Revenue Source Code in REVENUE SOURCE CODE file (#347.3)...")
+5 DO MES^XPDUTL("")
+6 SET RCCNT=0
+7 ;
+8 FOR RCI=1:1
KILL DD,DO,DA
SET RCLN=$PIECE($TEXT(OLD+RCI),";;",2)
if RCLN="END"
QUIT
Begin DoDot:1
+9 IF +$PIECE(RCLN,U,3)=1
Begin DoDot:2
+10 SET PRCADA=0
+11 FOR
SET PRCADA=$ORDER(^RC(347.3,"B",$PIECE(RCLN,U,1),PRCADA))
if 'PRCADA
QUIT
Begin DoDot:3
+12 IF $DATA(^RC(347.3,PRCADA,0))
Begin DoDot:4
+13 IF $PIECE($GET(^RC(347.3,PRCADA,0)),U,3)=1
SET RCFL=0
DO SET
+14 IF $PIECE($GET(^RC(347.3,PRCADA,0)),U,3)=""!($PIECE($GET(^RC(347.3,PRCADA,0)),U,3)=0)
Begin DoDot:5
+15 LOCK +^RC(347.3,PRCADA):$SELECT($GET(DILOCKTM)>5:DILOCKTM,1:5)
+16 SET RCCNT=RCCNT+1
+17 SET DA=PRCADA
SET DR=".03///^S X=1"
SET DIE="^RC(347.3,"
+18 DO ^DIE
+19 SET RCFL=2
DO SET
+20 LOCK -^RC(347.3,PRCADA)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+21 ;
+22 DO BMES^XPDUTL(.RCA)
+23 DO BMES^XPDUTL(" *** Total "_RCCNT_" Revenue Source "_$SELECT(RCCNT>1:"Codes",1:"Code")_" inactivated.")
+24 DO MES^XPDUTL(" ")
+25 KILL RCCNT,RCI,DD,DO,DA,RCLN,PRCADA,RCFL,DR,DIE,RCA
+26 QUIT
+27 ;
SET ; Set RCA() for display
+1 SET RCA(RCI)=" "_$PIECE(RCLN,U,1)_" "_$PIECE(RCLN,U,2)_" "
+2 SET RCA(RCI)=RCA(RCI)_$SELECT(RCFL=1:"* Code Added *",RCFL=2:"* Code Inactivated *",RCFL=3:"* Error on Code *",1:"* Duplicate *")
+3 QUIT
+4 ;
NEW ; REVENUE SOURCE CODE (#347.3) - CODE^CODE NAME^INACTIVE
+1 ;;8CW1^CWT SHELTERED WORKSHOPS
+2 ;;8CW2^CWT/TRANS WORK EXP (VAMC)
+3 ;;8CW3^CWT/TWE (FED NOT VAMC)
+4 ;;8CW4^CWT/TRANS WORK EXP (NON FEDERAL)
+5 ;;8CW5^CWT/VETERANS CONSTRUCTION TEAM
+6 ;;END
+7 ;
OLD ;
+1 ;;8023^^1
+2 ;;END
