IB20P240 ;ALB/RLC - Post-Init routine for IB*2.0*240; 8/19/2003
;;2.0;INTEGRATED BILLING;**240**;21-MAR-94
;
; This post-init routine is to change and update all references of
; CHAMPUS to TRICARE in numerous IB files.
;
EN ; entry point for post-init process
S U="^"
D EN1
D EN2
D EN3
D EN4
D EN5
D EN6
Q
;
EN1 ; root name ^IBE - files 350.1, 351.7, 355.1, 355.2, 355.97 and 363
F FN=1:1 S FILENUM=$P($T(FILE1+FN),";;",2,999) Q:FILENUM="" D
. S (CHID,NODE0,FLD01,FLD02,FLD08)=""
. F S CHID=$O(^IBE(FILENUM,"B",CHID)) Q:CHID="" D
. . Q:CHID'["CHAMPUS"
. . S DA=$O(^IBE(FILENUM,"B",CHID,0)) Q:'DA
. . S NODE0=$G(^IBE(FILENUM,DA,0))
. . S FLD01=$P(NODE0,U,1)
. . S STRING=""
. . I FLD01["(Tricare)" F X=1:1 S P(X)=$P(FLD01," ",X) Q:P(X)="" S:P(X)'["(Tricare)" STRING=STRING_P(X)_" "
. . S STRING=$E(STRING,1,$L(STRING)-1)
. . I FLD01'["(Tricare)" S STRING=FLD01
. . I $E(STRING,1,2)="DG" S STRING=$E(STRING,1,3)_$TR($E(STRING,4,10),"CHAMPUS","TRICARE")_$E(STRING,11,$L(STRING))
. . E I $E(STRING,1,2)'="DG" S STRING=$TR($E(STRING,1,7),"CHAMPUS","TRICARE")_$E(STRING,8,$L(STRING))
. . I FILENUM="350.1" D F3501 Q
. . I FILENUM="355.1" D F3551 Q
. . I FILENUM="355.2" D F3552 Q
. . L +^IBE(FILENUM)
. . S DIE="^IBE(FILENUM,",DR=".01////"_STRING D ^DIE
. . K DIE,DA,DR,STRING,FLD01,NODE0
. . L -^IBE(FILENUM)
. Q
K FN,FILENUM,CHID,NODE0,FLD01,FLD02,FLD08
Q
;
F3501 ; for file 350.1 must also update fields .02 and .08, and cross-
; references "D" and "E". Also, need to change external value for
; set of codes in field .11 to Tricare for internal code 7.
S FLD02=$P(NODE0,U,2)
I FLD02["CUS" S FLD02=$TR($E(FLD02,1,3),"CUS","TRI")_$E(FLD02,4,$L(FLD02))
I FLD02["CAN" S FLD02=$E(FLD02,1,4)_$TR($E(FLD02,5),"C","T")_$E(FLD02,6,$L(FLD02))
S FLD08=$P(NODE0,U,8)
S FLD08=$TR($E(FLD08,1,7),"CHAMPUS","TRICARE")_$E(FLD08,8,$L(FLD08))
L +^IBE(350.1)
S DIE="^IBE(350.1,",DR=".01////"_STRING_";.02////"_FLD02_";.08////"_FLD08 D ^DIE
L -^IBE(350.1)
K DIE,DA,DR,FLD02,FLD08,STRING
Q
;
F3551 ; for file 355.1 must also update field .02, and "D" cross-reference
S FLD02=$P(NODE0,U,2)
Q:FLD02'="CPS"&"CS"
S:FLD02="CPS" FLD02=$TR($E(FLD02,1,3),"CPS","TRI")
S:FLD02="CS" FLD02=$TR($E(FLD02,1,2),"CS","TS")
L +^IBE(355.1)
S DIE="^IBE(355.1,",DR=".01////"_STRING_";.02////"_FLD02 D ^DIE
D F35510
K DIE,DA,DR,FLD02,STRING,WP,DA1,X
L -^IBE(355.1)
Q
F35510 ; change references to Champus in description field
Q:'$D(^IBE(FILENUM,DA,10))
S DA1=0,(STRING,WP)=""
F S DA1=$O(^IBE(FILENUM,DA,10,DA1)) Q:'DA1 D
. S WP=$G(^IBE(FILENUM,DA,10,DA1,0))
. Q:WP'["CHAMPUS,"
. F X=1:1 S P(X)=$P(WP," ",X) Q:P(X)="" S:P(X)="CHAMPUS," P(X)="TRICARE," S STRING=STRING_P(X)_" "
. S STRING=$E(STRING,1,$L(STRING)-1)
. S ^IBE(FILENUM,DA,10,DA1,0)=STRING
K DA1,STRING,P,WP
Q
;
F3552 ; must also update field .02 from CHS to TRI and "C" cross-reference
S FLD02=$P(NODE0,U,2)
S FLD02=$TR($E(FLD02,1,3),"CHS","TRI")
L +^IBE(355.2)
S DIE="^IBE(355.2,",DR=".01////"_STRING_";.02////"_FLD02 D ^DIE
L -^IBE(355.2)
K FLD02,DIE,DR,NODE0
Q
;
EN2 ; root name ^IBA - file 355.3 change .03 field, along with "D", "ACCP"
; and "AGNA" cross references. Files 364.5 and 364.7 change references
; from Champus to Tricare in word-processing field
F FN=1:1 S FILENUM=$P($T(FILE2+FN),";;",2,999) Q:FILENUM="" D
. I FILENUM="355.3" D EN21
. I FILENUM="364.5" S CHID="N-OTHER INSURANCE CO TYPES" D EN22
. I FILENUM="364.7" F CHID=805,1005 D EN22
. Q
K FN,FILENUM,CHID
Q
;
EN21 ; update file 355.3
S (CHID,NODE0,FLD03)=""
F S CHID=$O(^IBA(FILENUM,"D",CHID)) Q:CHID="" D
. Q:CHID'["CHAMPUS"
. S DA=0
. F S DA=$O(^IBA(FILENUM,"D",CHID,DA)) Q:'DA D
. . S NODE0=$G(^IBA(FILENUM,DA,0))
. . S FLD03=$P(NODE0,U,3)
. . S FLD03=$TR($E(FLD03,1,7),"CHAMPUS","TRICARE")_$E(FLD03,8,$L(FLD03))
. . L +^IBA(FILENUM)
. . S DIE="^IBA(355.3,",DR=".03////"_FLD03 D ^DIE
. . L -^IBA(FILENUM)
K CHID,DA,NODE0,FLD03,DIE,DR
Q
;
EN22 ; update files 364.5 and 364.7
S DA=$O(^IBA(FILENUM,"B",CHID,0)) Q:'DA
Q:'$D(^IBA(FILENUM,DA,3))
S DA1=0,(STRING,WP)=""
F S DA1=$O(^IBA(FILENUM,DA,3,DA1)) Q:'DA1 D
. S WP=$G(^IBA(FILENUM,DA,3,DA1,0))
. Q:WP'["CHAMPUS"
. S STRING=$TR(WP,"CHAMPUS","TRICARE")
. S ^IBA(FILENUM,DA,3,DA1,0)=STRING
K DA,DA1,WP,STRING
Q
;
EN3 ; root name ^DGCR - files 399.1 and 399.3
S (NODE0,FLD01,FLD02,FLD03,FLD04)=""
F FN=1:1 S FILENUM=$P($T(FILE3+FN),";;",2,999) Q:FILENUM="" D
. S CHID=""
. F S CHID=$O(^DGCR(FILENUM,"B",CHID)) Q:CHID="" D
. . Q:CHID'["CHAMPUS"
. . S DA=$O(^DGCR(FILENUM,"B",CHID,0)) Q:'DA
. . S NODE0=$G(^DGCR(FILENUM,DA,0))
. . S FLD01=$P(NODE0,U,1)
. . S:FILENUM="399.3" FLD02=$P(NODE0,U,2),FLD03=$P(NODE0,U,3),FLD04=$P(NODE0,U,4)
. . S FLD01=$TR($E(FLD01,1,7),"CHAMPUS","TRICARE")_$E(FLD01,8,$L(FLD01))
. . I $D(FLD02) S:FLD02["CHAMPUS" FLD02=$TR($E(FLD02,1,7),"CHAMPUS","TRICARE")_$E(FLD02,8,$L(FLD02))
. . I $D(FLD03) S:FLD03["CHAMPUS" FLD03=$TR($E(FLD03,1,7),"CHAMPUS","TRICARE")_$E(FLD03,8,$L(FLD03))
. . I $D(FLD04) S:FLD04["CHAMPUS" FLD04=$TR($E(FLD04,1,7),"CHAMPUS","TRICARE")_$E(FLD04,8,$L(FLD04))
. . L +^DGCR(FILENUM)
. . S DIE="^DGCR(FILENUM,"
. . I FILENUM="399.3" S DR=".01////"_FLD01_";.02////"_FLD02_";.03////"_FLD03_";.04////"_FLD04 D ^DIE K DIE,DA,DR Q
. . S DR=".01////"_FLD01 D ^DIE
. . K DIE,DA,DR
. . L -^DGCR(FILENUM)
K DIE,DA,DR,FILENUM,FN,FLD01,FLD02,FLD03,FLD04,NODE0,CHID
Q
;
EN4 ; update .01 field in file 36
S (CHID,NODE0,FLD01)=""
F S CHID=$O(^DIC(36,"B",CHID)) Q:CHID="" D
. Q:CHID'["CHAMPUS"
. S DA=$O(^DIC(36,"B",CHID,0)) Q:'DA
. S NODE0=$G(^DIC(36,DA,0))
. S FLD01=$P(NODE0,U,1)
. S FLD01=$TR($E(FLD01,1,7),"CHAMPUS","TRICARE")_$E(FLD01,8,$L(FLD01))
. S DIE="^DIC(36,",DR=".01////"_FLD01 D ^DIE
. K DA,DIE,DR
K CHID,FLD01,NODE0
Q
;
EN5 ; change all occurrences of CHAMPUS to TRICARE for IB Menu option
; text displays.
S NM="",DA=0
F S NM=$O(^DIC(19,"B",NM)) Q:NM="" D
. Q:NM'["IB CHAMP"
. S (FLD01,STRG1,FLD02,STRING,NODE0)="" K P
. S DA=$O(^DIC(19,"B",NM,0)) Q:'DA
. S NODE0=$G(^DIC(19,DA,0))
. S FLD01=$P(NODE0,U,1) ; Option name
. F X=1:1 S P(X)=$P(FLD01," ",X) Q:P(X)="" S:P(X)="CHAMP" P(X)="TRICARE" S STRG1=STRG1_P(X)_" "
. S STRG1=$E(STRG1,1,$L(STRG1)-1)
. S FLD02=$P(^DIC(19,DA,0),U,2) ; Menu text
. F X=1:1 S P(X)=$P(FLD02," ",X) Q:P(X)="" S:P(X)="CHAMPUS" P(X)="TRICARE" S STRING=STRING_P(X)_" "
. S STRING=$E(STRING,1,$L(STRING)-1)
. S DIE="^DIC(19,",DR=".01////"_STRG1_";1////"_STRING D ^DIE
. K DIE,DR
. D DESC
K X,NM,DA,NODE0,FLD01,FLD02,STRG1,STRING,P
D IBJD
Q
;
IBJD ; change text display for menu option
S NM="IBJD FOLLOW-UP CHAMPVA/TRICARE"
S DA="",DA=$O(^DIC(19,"B",NM,"")) Q:DA=""
S STRING="CHAMPVA/TRICARE Follow-Up Report"
S DIE="^DIC(19,",DR="1////"_STRING D ^DIE
D DESC
K DA,DA1,DIE,DR,STRING,NM,WP,P
Q
;
DESC ; change any references from Champus to Tricare in the
; word-processing description multiple field
Q:'$D(^DIC(19,DA,1))
S DA1=0,(STRING,WP)=""
F S DA1=$O(^DIC(19,DA,1,DA1)) Q:'DA1 D
. S WP=^DIC(19,DA,1,DA1,0)
. Q:WP'["CHAMPUS"
. F X=1:1 S P(X)=$P(WP," ",X) Q:P(X)="" S:P(X)="CHAMPUS" P(X)="TRICARE" S:P(X)="(Tricare)" P(X)="" S:P(X)'="" STRING=STRING_P(X)_" "
. S STRING=$E(STRING,1,$L(STRING)-1)
. S ^DIC(19,DA,1,DA1,0)=STRING
Q
;
EN6 ; search for all records in file 355.3 that contain internal code
; CH in field .15 (Electronic Plan Type) and change it to TR.
; The external value for this field has been changed from CHAMPUS
; to TRICARE.
S DA=0,(NODE0,PC)=""
F S DA=$O(^IBA(355.3,DA)) Q:'DA D
. S NODE0=$G(^IBA(355.3,DA,0)),PC=$P(NODE0,U,15)
. Q:PC'="CH"
. S PC="TR"
. S DIE="^IBA(355.3,",DR=".15////"_PC D ^DIE
K DA,DR,DIE,NODE0,PC
Q
;
FILE1 ; file numbers with root name ^IBE that need to be updated
;;350.1
;;351.7
;;355.1
;;355.2
;;355.97
;;363
;
FILE2 ; file numbers with root name ^IBA that need to be updated
;;355.3
;;364.5
;;364.7
;
FILE3 ; file numbers with root name ^DGCR that need to be updated
;;399.1
;;399.3
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P240 8306 printed Apr 09, 2024@21:06:50 Page 2
IB20P240 ;ALB/RLC - Post-Init routine for IB*2.0*240; 8/19/2003
+1 ;;2.0;INTEGRATED BILLING;**240**;21-MAR-94
+2 ;
+3 ; This post-init routine is to change and update all references of
+4 ; CHAMPUS to TRICARE in numerous IB files.
+5 ;
EN ; entry point for post-init process
+1 SET U="^"
+2 DO EN1
+3 DO EN2
+4 DO EN3
+5 DO EN4
+6 DO EN5
+7 DO EN6
+8 QUIT
+9 ;
EN1 ; root name ^IBE - files 350.1, 351.7, 355.1, 355.2, 355.97 and 363
+1 FOR FN=1:1
SET FILENUM=$PIECE($TEXT(FILE1+FN),";;",2,999)
if FILENUM=""
QUIT
Begin DoDot:1
+2 SET (CHID,NODE0,FLD01,FLD02,FLD08)=""
+3 FOR
SET CHID=$ORDER(^IBE(FILENUM,"B",CHID))
if CHID=""
QUIT
Begin DoDot:2
+4 if CHID'["CHAMPUS"
QUIT
+5 SET DA=$ORDER(^IBE(FILENUM,"B",CHID,0))
if 'DA
QUIT
+6 SET NODE0=$GET(^IBE(FILENUM,DA,0))
+7 SET FLD01=$PIECE(NODE0,U,1)
+8 SET STRING=""
+9 IF FLD01["(Tricare)"
FOR X=1:1
SET P(X)=$PIECE(FLD01," ",X)
if P(X)=""
QUIT
if P(X)'["(Tricare)"
SET STRING=STRING_P(X)_" "
+10 SET STRING=$EXTRACT(STRING,1,$LENGTH(STRING)-1)
+11 IF FLD01'["(Tricare)"
SET STRING=FLD01
+12 IF $EXTRACT(STRING,1,2)="DG"
SET STRING=$EXTRACT(STRING,1,3)_$TRANSLATE($EXTRACT(STRING,4,10),"CHAMPUS","TRICARE")_$EXTRACT(STRING,11,$LENGTH(STRING))
+13 IF '$TEST
IF $EXTRACT(STRING,1,2)'="DG"
SET STRING=$TRANSLATE($EXTRACT(STRING,1,7),"CHAMPUS","TRICARE")_$EXTRACT(STRING,8,$LENGTH(STRING))
+14 IF FILENUM="350.1"
DO F3501
QUIT
+15 IF FILENUM="355.1"
DO F3551
QUIT
+16 IF FILENUM="355.2"
DO F3552
QUIT
+17 LOCK +^IBE(FILENUM)
+18 SET DIE="^IBE(FILENUM,"
SET DR=".01////"_STRING
DO ^DIE
+19 KILL DIE,DA,DR,STRING,FLD01,NODE0
+20 LOCK -^IBE(FILENUM)
End DoDot:2
+21 QUIT
End DoDot:1
+22 KILL FN,FILENUM,CHID,NODE0,FLD01,FLD02,FLD08
+23 QUIT
+24 ;
F3501 ; for file 350.1 must also update fields .02 and .08, and cross-
+1 ; references "D" and "E". Also, need to change external value for
+2 ; set of codes in field .11 to Tricare for internal code 7.
+3 SET FLD02=$PIECE(NODE0,U,2)
+4 IF FLD02["CUS"
SET FLD02=$TRANSLATE($EXTRACT(FLD02,1,3),"CUS","TRI")_$EXTRACT(FLD02,4,$LENGTH(FLD02))
+5 IF FLD02["CAN"
SET FLD02=$EXTRACT(FLD02,1,4)_$TRANSLATE($EXTRACT(FLD02,5),"C","T")_$EXTRACT(FLD02,6,$LENGTH(FLD02))
+6 SET FLD08=$PIECE(NODE0,U,8)
+7 SET FLD08=$TRANSLATE($EXTRACT(FLD08,1,7),"CHAMPUS","TRICARE")_$EXTRACT(FLD08,8,$LENGTH(FLD08))
+8 LOCK +^IBE(350.1)
+9 SET DIE="^IBE(350.1,"
SET DR=".01////"_STRING_";.02////"_FLD02_";.08////"_FLD08
DO ^DIE
+10 LOCK -^IBE(350.1)
+11 KILL DIE,DA,DR,FLD02,FLD08,STRING
+12 QUIT
+13 ;
F3551 ; for file 355.1 must also update field .02, and "D" cross-reference
+1 SET FLD02=$PIECE(NODE0,U,2)
+2 if FLD02'="CPS"&"CS"
QUIT
+3 if FLD02="CPS"
SET FLD02=$TRANSLATE($EXTRACT(FLD02,1,3),"CPS","TRI")
+4 if FLD02="CS"
SET FLD02=$TRANSLATE($EXTRACT(FLD02,1,2),"CS","TS")
+5 LOCK +^IBE(355.1)
+6 SET DIE="^IBE(355.1,"
SET DR=".01////"_STRING_";.02////"_FLD02
DO ^DIE
+7 DO F35510
+8 KILL DIE,DA,DR,FLD02,STRING,WP,DA1,X
+9 LOCK -^IBE(355.1)
+10 QUIT
F35510 ; change references to Champus in description field
+1 if '$DATA(^IBE(FILENUM,DA,10))
QUIT
+2 SET DA1=0
SET (STRING,WP)=""
+3 FOR
SET DA1=$ORDER(^IBE(FILENUM,DA,10,DA1))
if 'DA1
QUIT
Begin DoDot:1
+4 SET WP=$GET(^IBE(FILENUM,DA,10,DA1,0))
+5 if WP'["CHAMPUS,"
QUIT
+6 FOR X=1:1
SET P(X)=$PIECE(WP," ",X)
if P(X)=""
QUIT
if P(X)="CHAMPUS,"
SET P(X)="TRICARE,"
SET STRING=STRING_P(X)_" "
+7 SET STRING=$EXTRACT(STRING,1,$LENGTH(STRING)-1)
+8 SET ^IBE(FILENUM,DA,10,DA1,0)=STRING
End DoDot:1
+9 KILL DA1,STRING,P,WP
+10 QUIT
+11 ;
F3552 ; must also update field .02 from CHS to TRI and "C" cross-reference
+1 SET FLD02=$PIECE(NODE0,U,2)
+2 SET FLD02=$TRANSLATE($EXTRACT(FLD02,1,3),"CHS","TRI")
+3 LOCK +^IBE(355.2)
+4 SET DIE="^IBE(355.2,"
SET DR=".01////"_STRING_";.02////"_FLD02
DO ^DIE
+5 LOCK -^IBE(355.2)
+6 KILL FLD02,DIE,DR,NODE0
+7 QUIT
+8 ;
EN2 ; root name ^IBA - file 355.3 change .03 field, along with "D", "ACCP"
+1 ; and "AGNA" cross references. Files 364.5 and 364.7 change references
+2 ; from Champus to Tricare in word-processing field
+3 FOR FN=1:1
SET FILENUM=$PIECE($TEXT(FILE2+FN),";;",2,999)
if FILENUM=""
QUIT
Begin DoDot:1
+4 IF FILENUM="355.3"
DO EN21
+5 IF FILENUM="364.5"
SET CHID="N-OTHER INSURANCE CO TYPES"
DO EN22
+6 IF FILENUM="364.7"
FOR CHID=805,1005
DO EN22
+7 QUIT
End DoDot:1
+8 KILL FN,FILENUM,CHID
+9 QUIT
+10 ;
EN21 ; update file 355.3
+1 SET (CHID,NODE0,FLD03)=""
+2 FOR
SET CHID=$ORDER(^IBA(FILENUM,"D",CHID))
if CHID=""
QUIT
Begin DoDot:1
+3 if CHID'["CHAMPUS"
QUIT
+4 SET DA=0
+5 FOR
SET DA=$ORDER(^IBA(FILENUM,"D",CHID,DA))
if 'DA
QUIT
Begin DoDot:2
+6 SET NODE0=$GET(^IBA(FILENUM,DA,0))
+7 SET FLD03=$PIECE(NODE0,U,3)
+8 SET FLD03=$TRANSLATE($EXTRACT(FLD03,1,7),"CHAMPUS","TRICARE")_$EXTRACT(FLD03,8,$LENGTH(FLD03))
+9 LOCK +^IBA(FILENUM)
+10 SET DIE="^IBA(355.3,"
SET DR=".03////"_FLD03
DO ^DIE
+11 LOCK -^IBA(FILENUM)
End DoDot:2
End DoDot:1
+12 KILL CHID,DA,NODE0,FLD03,DIE,DR
+13 QUIT
+14 ;
EN22 ; update files 364.5 and 364.7
+1 SET DA=$ORDER(^IBA(FILENUM,"B",CHID,0))
if 'DA
QUIT
+2 if '$DATA(^IBA(FILENUM,DA,3))
QUIT
+3 SET DA1=0
SET (STRING,WP)=""
+4 FOR
SET DA1=$ORDER(^IBA(FILENUM,DA,3,DA1))
if 'DA1
QUIT
Begin DoDot:1
+5 SET WP=$GET(^IBA(FILENUM,DA,3,DA1,0))
+6 if WP'["CHAMPUS"
QUIT
+7 SET STRING=$TRANSLATE(WP,"CHAMPUS","TRICARE")
+8 SET ^IBA(FILENUM,DA,3,DA1,0)=STRING
End DoDot:1
+9 KILL DA,DA1,WP,STRING
+10 QUIT
+11 ;
EN3 ; root name ^DGCR - files 399.1 and 399.3
+1 SET (NODE0,FLD01,FLD02,FLD03,FLD04)=""
+2 FOR FN=1:1
SET FILENUM=$PIECE($TEXT(FILE3+FN),";;",2,999)
if FILENUM=""
QUIT
Begin DoDot:1
+3 SET CHID=""
+4 FOR
SET CHID=$ORDER(^DGCR(FILENUM,"B",CHID))
if CHID=""
QUIT
Begin DoDot:2
+5 if CHID'["CHAMPUS"
QUIT
+6 SET DA=$ORDER(^DGCR(FILENUM,"B",CHID,0))
if 'DA
QUIT
+7 SET NODE0=$GET(^DGCR(FILENUM,DA,0))
+8 SET FLD01=$PIECE(NODE0,U,1)
+9 if FILENUM="399.3"
SET FLD02=$PIECE(NODE0,U,2)
SET FLD03=$PIECE(NODE0,U,3)
SET FLD04=$PIECE(NODE0,U,4)
+10 SET FLD01=$TRANSLATE($EXTRACT(FLD01,1,7),"CHAMPUS","TRICARE")_$EXTRACT(FLD01,8,$LENGTH(FLD01))
+11 IF $DATA(FLD02)
if FLD02["CHAMPUS"
SET FLD02=$TRANSLATE($EXTRACT(FLD02,1,7),"CHAMPUS","TRICARE")_$EXTRACT(FLD02,8,$LENGTH(FLD02))
+12 IF $DATA(FLD03)
if FLD03["CHAMPUS"
SET FLD03=$TRANSLATE($EXTRACT(FLD03,1,7),"CHAMPUS","TRICARE")_$EXTRACT(FLD03,8,$LENGTH(FLD03))
+13 IF $DATA(FLD04)
if FLD04["CHAMPUS"
SET FLD04=$TRANSLATE($EXTRACT(FLD04,1,7),"CHAMPUS","TRICARE")_$EXTRACT(FLD04,8,$LENGTH(FLD04))
+14 LOCK +^DGCR(FILENUM)
+15 SET DIE="^DGCR(FILENUM,"
+16 IF FILENUM="399.3"
SET DR=".01////"_FLD01_";.02////"_FLD02_";.03////"_FLD03_";.04////"_FLD04
DO ^DIE
KILL DIE,DA,DR
QUIT
+17 SET DR=".01////"_FLD01
DO ^DIE
+18 KILL DIE,DA,DR
+19 LOCK -^DGCR(FILENUM)
End DoDot:2
End DoDot:1
+20 KILL DIE,DA,DR,FILENUM,FN,FLD01,FLD02,FLD03,FLD04,NODE0,CHID
+21 QUIT
+22 ;
EN4 ; update .01 field in file 36
+1 SET (CHID,NODE0,FLD01)=""
+2 FOR
SET CHID=$ORDER(^DIC(36,"B",CHID))
if CHID=""
QUIT
Begin DoDot:1
+3 if CHID'["CHAMPUS"
QUIT
+4 SET DA=$ORDER(^DIC(36,"B",CHID,0))
if 'DA
QUIT
+5 SET NODE0=$GET(^DIC(36,DA,0))
+6 SET FLD01=$PIECE(NODE0,U,1)
+7 SET FLD01=$TRANSLATE($EXTRACT(FLD01,1,7),"CHAMPUS","TRICARE")_$EXTRACT(FLD01,8,$LENGTH(FLD01))
+8 SET DIE="^DIC(36,"
SET DR=".01////"_FLD01
DO ^DIE
+9 KILL DA,DIE,DR
End DoDot:1
+10 KILL CHID,FLD01,NODE0
+11 QUIT
+12 ;
EN5 ; change all occurrences of CHAMPUS to TRICARE for IB Menu option
+1 ; text displays.
+2 SET NM=""
SET DA=0
+3 FOR
SET NM=$ORDER(^DIC(19,"B",NM))
if NM=""
QUIT
Begin DoDot:1
+4 if NM'["IB CHAMP"
QUIT
+5 SET (FLD01,STRG1,FLD02,STRING,NODE0)=""
KILL P
+6 SET DA=$ORDER(^DIC(19,"B",NM,0))
if 'DA
QUIT
+7 SET NODE0=$GET(^DIC(19,DA,0))
+8 ; Option name
SET FLD01=$PIECE(NODE0,U,1)
+9 FOR X=1:1
SET P(X)=$PIECE(FLD01," ",X)
if P(X)=""
QUIT
if P(X)="CHAMP"
SET P(X)="TRICARE"
SET STRG1=STRG1_P(X)_" "
+10 SET STRG1=$EXTRACT(STRG1,1,$LENGTH(STRG1)-1)
+11 ; Menu text
SET FLD02=$PIECE(^DIC(19,DA,0),U,2)
+12 FOR X=1:1
SET P(X)=$PIECE(FLD02," ",X)
if P(X)=""
QUIT
if P(X)="CHAMPUS"
SET P(X)="TRICARE"
SET STRING=STRING_P(X)_" "
+13 SET STRING=$EXTRACT(STRING,1,$LENGTH(STRING)-1)
+14 SET DIE="^DIC(19,"
SET DR=".01////"_STRG1_";1////"_STRING
DO ^DIE
+15 KILL DIE,DR
+16 DO DESC
End DoDot:1
+17 KILL X,NM,DA,NODE0,FLD01,FLD02,STRG1,STRING,P
+18 DO IBJD
+19 QUIT
+20 ;
IBJD ; change text display for menu option
+1 SET NM="IBJD FOLLOW-UP CHAMPVA/TRICARE"
+2 SET DA=""
SET DA=$ORDER(^DIC(19,"B",NM,""))
if DA=""
QUIT
+3 SET STRING="CHAMPVA/TRICARE Follow-Up Report"
+4 SET DIE="^DIC(19,"
SET DR="1////"_STRING
DO ^DIE
+5 DO DESC
+6 KILL DA,DA1,DIE,DR,STRING,NM,WP,P
+7 QUIT
+8 ;
DESC ; change any references from Champus to Tricare in the
+1 ; word-processing description multiple field
+2 if '$DATA(^DIC(19,DA,1))
QUIT
+3 SET DA1=0
SET (STRING,WP)=""
+4 FOR
SET DA1=$ORDER(^DIC(19,DA,1,DA1))
if 'DA1
QUIT
Begin DoDot:1
+5 SET WP=^DIC(19,DA,1,DA1,0)
+6 if WP'["CHAMPUS"
QUIT
+7 FOR X=1:1
SET P(X)=$PIECE(WP," ",X)
if P(X)=""
QUIT
if P(X)="CHAMPUS"
SET P(X)="TRICARE"
if P(X)="(Tricare)"
SET P(X)=""
if P(X)'=""
SET STRING=STRING_P(X)_" "
+8 SET STRING=$EXTRACT(STRING,1,$LENGTH(STRING)-1)
+9 SET ^DIC(19,DA,1,DA1,0)=STRING
End DoDot:1
+10 QUIT
+11 ;
EN6 ; search for all records in file 355.3 that contain internal code
+1 ; CH in field .15 (Electronic Plan Type) and change it to TR.
+2 ; The external value for this field has been changed from CHAMPUS
+3 ; to TRICARE.
+4 SET DA=0
SET (NODE0,PC)=""
+5 FOR
SET DA=$ORDER(^IBA(355.3,DA))
if 'DA
QUIT
Begin DoDot:1
+6 SET NODE0=$GET(^IBA(355.3,DA,0))
SET PC=$PIECE(NODE0,U,15)
+7 if PC'="CH"
QUIT
+8 SET PC="TR"
+9 SET DIE="^IBA(355.3,"
SET DR=".15////"_PC
DO ^DIE
End DoDot:1
+10 KILL DA,DR,DIE,NODE0,PC
+11 QUIT
+12 ;
FILE1 ; file numbers with root name ^IBE that need to be updated
+1 ;;350.1
+2 ;;351.7
+3 ;;355.1
+4 ;;355.2
+5 ;;355.97
+6 ;;363
+7 ;
FILE2 ; file numbers with root name ^IBA that need to be updated
+1 ;;355.3
+2 ;;364.5
+3 ;;364.7
+4 ;
FILE3 ; file numbers with root name ^DGCR that need to be updated
+1 ;;399.1
+2 ;;399.3
