PRCA192P.m

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 ---PRCA192P   1123     printed  Feb 18, 2025@23:05                                                                                                                                                                                                       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