PRCA192P ;BAY-OI/RLC- PRE-INIT FOR 192 TO UPDATE CHAMPUS TO TRICARE ;03/31/03
;;4.5;Accounts Receivable;**192 **;Mar 20, 1995
;Change references to CHAMPUS to TRICARE
D F4302
D F3473
Q
;
F4302 ; update file 430.2 with new Category name and Abbreviation
; along with the corresponding "B" and "C" cross references
N DA,PRNM,PRNAME,PRAB,PRABB
S (PRNM,PRAB,PRABB,PRNAME)="",U="^"
F S PRNM=$O(^PRCA(430.2,"B",PRNM)) Q:PRNM="" D
. Q:PRNM'["CHAMPUS"
. S PRNAME=$TR($E(PRNM,1,7),"CHAMPUS","TRICARE")_$E(PRNM,8,$L(PRNM))
. S DA=$O(^PRCA(430.2,"B",PRNM,0)) Q:'DA
. S PRAB=$P(^PRCA(430.2,DA,0),U,2)
. S PRABB=$TR($E(PRAB,1),"C","T")_$E(PRAB,2,$L(PRAB))
. S $P(^PRCA(430.2,DA,0),U,1)=PRNAME,$P(^(0),U,2)=PRABB
. S ^PRCA(430.2,"B",PRNAME,DA)="",^PRCA(430.2,"C",PRABB,DA)=""
. K ^PRCA(430.2,"B",PRNM,DA),^PRCA(430.2,"C",PRAB,DA)
K DA,PRNM,PRNAME,PRAB,PRABB
Q
;
F3473 ; Inactivate Champus Revenue Source Codes file 347.3
S INACT=1
F DA=8025,8026,8027 D
. L +^RC(347.3,DA):10
. S DIE="^RC(347.3,",DR=".03///^S X=INACT"
. D ^DIE
. L -^RC(347.3,DA)
K DA,DR,DIE,INACT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCA192P 1123 printed Dec 13, 2024@01:38:37 Page 2
PRCA192P ;BAY-OI/RLC- PRE-INIT FOR 192 TO UPDATE CHAMPUS TO TRICARE ;03/31/03
+1 ;;4.5;Accounts Receivable;**192 **;Mar 20, 1995
+2 ;Change references to CHAMPUS to TRICARE
+3 DO F4302
+4 DO F3473
+5 QUIT
+6 ;
F4302 ; update file 430.2 with new Category name and Abbreviation
+1 ; along with the corresponding "B" and "C" cross references
+2 NEW DA,PRNM,PRNAME,PRAB,PRABB
+3 SET (PRNM,PRAB,PRABB,PRNAME)=""
SET U="^"
+4 FOR
SET PRNM=$ORDER(^PRCA(430.2,"B",PRNM))
if PRNM=""
QUIT
Begin DoDot:1
+5 if PRNM'["CHAMPUS"
QUIT
+6 SET PRNAME=$TRANSLATE($EXTRACT(PRNM,1,7),"CHAMPUS","TRICARE")_$EXTRACT(PRNM,8,$LENGTH(PRNM))
+7 SET DA=$ORDER(^PRCA(430.2,"B",PRNM,0))
if 'DA
QUIT
+8 SET PRAB=$PIECE(^PRCA(430.2,DA,0),U,2)
+9 SET PRABB=$TRANSLATE($EXTRACT(PRAB,1),"C","T")_$EXTRACT(PRAB,2,$LENGTH(PRAB))
+10 SET $PIECE(^PRCA(430.2,DA,0),U,1)=PRNAME
SET $PIECE(^(0),U,2)=PRABB
+11 SET ^PRCA(430.2,"B",PRNAME,DA)=""
SET ^PRCA(430.2,"C",PRABB,DA)=""
+12 KILL ^PRCA(430.2,"B",PRNM,DA),^PRCA(430.2,"C",PRAB,DA)
End DoDot:1
+13 KILL DA,PRNM,PRNAME,PRAB,PRABB
+14 QUIT
+15 ;
F3473 ; Inactivate Champus Revenue Source Codes file 347.3
+1 SET INACT=1
+2 FOR DA=8025,8026,8027
Begin DoDot:1
+3 LOCK +^RC(347.3,DA):10
+4 SET DIE="^RC(347.3,"
SET DR=".03///^S X=INACT"
+5 DO ^DIE
+6 LOCK -^RC(347.3,DA)
End DoDot:1
+7 KILL DA,DR,DIE,INACT
+8 QUIT
