FBXIP19 ;WCIOFO/SAB-PATCH INSTALL ROUTINE ;10/25/2000
;;3.5;FEE BASIS;**19**;JAN 30, 1995
; This routine invokes IA #3228
Q
;
PR ; pre-install entry point
; create KIDS checkpoints with call backs
N FBX,Y
F FBX="DXREF" D
. S Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP19")
. I 'Y D BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")
Q
;
PS ; post-install entry point
;
; only perform during 1st install
I $$PATCH^XPDUTL("FB*3.5*19") D BMES^XPDUTL(" Skipping post install since patch was previously installed.") Q
;
; create KIDS checkpoints with call backs
N FBX,Y
F FBX="MERGED" D
. S Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP19")
. I 'Y D BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")
Q
;
DXREF ; Delete cross-references (Pre Install)
;
; Delete trigger x-ref because new logic has fewer nodes in DD
D DELIX^DDMOD(162.11,.01,2) ; trigger x-ref
;
; This section deletes existing traditional style cross reference logic
; whose functionality is being replaced by new style cross references
; included in this patch.
D DELIX^DDMOD(162.11,7,1) ; AG x-ref
D DELIX^DDMOD(162.11,13,2) ; AJ x-ref
D DELIX^DDMOD(162.11,13,3) ; AK x-ref
D DELIX^DDMOD(162.11,15,1) ; AA x-ref
D DELIX^DDMOD(162.2,14,1) ; AI x-ref
D DELIX^DDMOD(162.3,3,1) ; AD x-ref
D DELIX^DDMOD(162.5,1,1) ; AI1 x-ref
D DELIX^DDMOD(162.5,10,1) ; AI x-ref
D DELIX^DDMOD(162.5,5,1) ; AA x-ref
D DELIX^DDMOD(162.5,20,2) ; AE x-ref
Q
;
MERGED ; Check previously merged patients and fix FEE as needed (post install)
N FBAUTCHG,FBDA,FBFR,FBTO,FBX
K ^TMP($J)
; loop through MERGE IMAGES file (IA #3228)
S FBDA=0 F S FBDA=$O(^XDRM(FBDA)) Q:'FBDA D
. S FBX=$G(^XDRM(FBDA,0))
. Q:$P($P(FBX,U),";",2)'="DPT(" ; from is not PATIENT file
. Q:$P($P(FBX,U,2),";",2)'="DPT(" ; to is not PATIENT file
. S FBFR=$P($P(FBX,U),";") ; From IEN of patient
. S FBTO=$P($P(FBX,U,2),";") ; To IEN of patient
. ;
. D LOADBI^FBXIP19A(1) ; load FEE before images for FBFR into ^TMP
. D LOADBI^FBXIP19A(2) ; load FEE before images for FBTO into ^TMP
. ;
. ; process FEE BASIS PATIENT file authorization multiple (161.01)
. D FB16101^FBXIP19A
. ;I $D(FBAUTCHG) W ! ZW FBAUTCHG
. ;
. ; process FEE BASIS PAYMENT file service provided multiple (162.03)
. D FB16203^FBXIP19A
. ;
. ; process FEE BASIS PAYMENT file travel payment multiple (162.04)
. D FB16204^FBXIP19A
. ;
. ; process changed pointers
. D PCHG
. ;
; report any problems via mail message
I $D(^TMP($J,"PROB")) D
. N DIFROM,FBFILE,FBFR,FBIENS,FBL,FBTO,FBTXT,XMDUZ,XMSUB,XMTEXT,XMY
. ; build message text
. S ^TMP($J,"MSG",1)="The patch FB*3.5*19 post install was not able to automatically"
. S ^TMP($J,"MSG",2)="process some of the previously merged fee data."
. S ^TMP($J,"MSG",3)="This mail message has been sent to a developer for review."
. S FBL=3 ; last line used for message text
. ;loop thru problems and load appropriate text into message
. S FBFR=0 F S FBFR=$O(^TMP($J,"PROB",FBFR)) Q:'FBFR D
. . S FBTO=$P($G(^TMP($J,"PROB",FBFR)),U)
. . S FBL=FBL+1 S ^TMP($J,"MSG",FBL)=" "
. . S FBL=FBL+1 S ^TMP($J,"MSG",FBL)="ISSUES FOR PATIENT MERGED FROM "_FBFR_" INTO "_FBTO
. . S FBFILE=""
. . F S FBFILE=$O(^TMP($J,"PROB",FBFR,FBFILE)) Q:FBFILE="" D
. . . S FBIENS=""
. . . F S FBIENS=$O(^TMP($J,"PROB",FBFR,FBFILE,FBIENS)) Q:FBIENS="" D
. . . . S FBTXT=$G(^TMP($J,"PROB",FBFR,FBFILE,FBIENS))
. . . . S FBL=FBL+1,^TMP($J,"MSG",FBL)=" FILE: "_FBFILE_" IENS: "_FBIENS
. . . . S FBL=FBL+1,^TMP($J,"MSG",FBL)=" "_FBTXT
. S XMSUB="POST INSTALL FB*3.5*19"
. S XMDUZ=.5
. S XMTEXT="^TMP($J,""MSG"","
. S XMY("BAUMANN,SCOTT@DOMAIN.EXT")="",XMY(DUZ)=""
. D ^XMD
;
; cleanup
K ^TMP($J)
Q
;
PCHG ; Process Pointers Changed multiple in MERGE IMAGES file
; before this patch, nine x-refs depended on the patient but were
; not updated if the patient pointer was changed.
; check/update those x-refs for patients merged prior to this patch
; also update 'free-text' authorization pointers when necessary
; input
; FBDA - entry in MERGE IMAGES file
; FBAUTCHG(old ien,new ien) - array of changed authorization iens
; output
; update cross-reference values in various FEE files
; update 'free-text' authorization pointers in various FEE files
;
N FBDA1,FBFILE,FBFLD,FBIENS,FBOVAL,FBPC
;
; loop thru "B" x-ref of POINTERS CHANGED multiple in MERGE IMAGES
S FBPC="161 "
F S FBPC=$O(^XDRM(FBDA,3,"B",FBPC)) Q:FBPC=""!(FBPC]"164 ") D
. S FBDA1=0 F S FBDA1=$O(^XDRM(FBDA,3,"B",FBPC,FBDA1)) Q:'FBDA1 D
. . S FBFILE=$P($P(FBPC,U),";")
. . S FBIENS=$P($P(FBPC,U),";",2)
. . S FBFLD=$P($P(FBPC,U),";",3)
. . S FBOVAL=$P($G(^XDRM(FBDA,3,FBDA1,1)),U)
. . Q:FBOVAL=""
. . ;W !,"POINTER CHANGED for FILE: "_FBFILE_" FIELD: "_FBFLD_" OLD VAL "_FBOVAL_" IENS: "_FBIENS
. . ;Q ; *** temp quit for testing
. . I FBFILE=161.26,FBFLD=.01 D F16126
. . I FBFILE=162.11,FBFLD=4 D F16211
. . I FBFILE=162.2,FBFLD=3 D F1622
. . I FBFILE=162.3,FBFLD=1 D F1623
. . I FBFILE=162.5,FBFLD=3 D F1625
. . I FBFILE=162.7,FBFLD=2 D F1627
Q
;
F16126 ; file 161.26 field .01 check/fix 'free-text' pointer
N DA,DIE,DR,FBFTPC,FBFTPN,FBY
D DA^DILF(FBIENS,.DA)
Q:'DA
S FBY=$G(^FBAA(161.26,DA,0))
;
; update 'free-text' authorization pointer if it changed
S FBFTPC=$P(FBY,U,3) ; current
S FBFTPN=$S(FBFTPC:$O(FBAUTCHG(FBFTPC,0)),1:"") ; new (if different)
I FBFTPN,FBFTPN'=FBFTPC D
. S DIE="^FBAA(161.26,"
. S DR="2////^S X=FBFTPN"
. D ^DIE
Q
;
F16211 ; file 162.11 field 4 check/fix x-refs & 'free-text' pointer
N DA,DIE,DIK,DR,FBFTPC,FBFTPN,FBRXY,FBY
D DA^DILF(FBIENS,.DA)
Q:'DA(1)
Q:'DA
S FBY=$G(^FBAA(162.1,DA(1),0))
S FBRXY=$G(^FBAA(162.1,DA(1),"RX",DA,0))
;
; delete "AG" x-ref for old value
I $P(FBY,U,4)]"",$P(FBY,U,8)]"",$P(FBRXY,U,8)]"" K ^FBAA(162.1,"AG",$P(FBY,U,4),$P(FBY,U,8),FBOVAL,$P(FBRXY,U,8),DA(1),DA)
; delete "AJ" x-ref for old value
I $P(FBRXY,U,17)]"" K ^FBAA(162.1,"AJ",$P(FBRXY,U,17),FBOVAL,DA(1),DA)
; delete "AK" x-ref for old value
I $P(FBY,U,4)]"",$P(FBRXY,U,3)]"" K ^FBAA(162.1,"AK",$P(FBY,U,4),9999999-$P(FBRXY,U,3),FBOVAL,DA(1),DA)
; delete "AA" x-ref for old value
I $P(FBRXY,U,19)]"" K ^FBAA(162.1,"AA",$P(FBRXY,U,19),FBOVAL,DA(1),DA)
; re-index "AG","AJ","AK","AA" x-refs for entry
S DIK="^FBAA(162.1,"_DA(1)_",""RX"","
S DIK(1)="4^AA^AG^AJ^AK"
D EN1^DIK
;
; update 'free-text' authorization pointer if it changed
S FBFTPC=$P($G(^FBAA(162.1,DA(1),"RX",DA,2)),U,7) ; current
S FBFTPN=$S(FBFTPC:$O(FBAUTCHG(FBFTPC,0)),1:"") ; new (if different)
I FBFTPN,FBFTPN'=FBFTPC D
. S DIE="^FBAA(162.1,"_DA(1)_",""RX"","
. S DR="27////^S X=FBFTPN"
. D ^DIE
Q
;
F1622 ; file 162.2 field 3 check/fix x-ref
N DA,DIK,FBY
D DA^DILF(FBIENS,.DA)
Q:'DA
S FBY=$G(^FBAA(162.2,DA,0))
;
; delete "AI" x-ref for old value
I $P(FBY,U,2)]"",$P(FBY,U,13)]"",$P(FBY,U,16)]"" K ^FBAA(162.2,"AI",$P(FBY,U,2),$P(FBY,U,13),FBOVAL,$P(FBY,U,16),DA)
; re-index "AI" x-ref for entry
S DIK="^FBAA(162.2,"
S DIK(1)="3^AI"
D EN1^DIK
Q
;
F1623 ; file 162.3 field 1 check/fix x-ref and 'free-text' pointer
N DA,DIE,DIK,DR,FBFTPC,FBFTPN,FBY
D DA^DILF(FBIENS,.DA)
Q:'DA
S FBY=$G(^FBAACNH(DA,0))
;
; delete "AD" x-ref for old value
I $P(FBY,U,4)]"" K ^FBAACNH("AD",FBOVAL,DA)
; re-index "AD" x-ref for entry
S DIK="^FBAACNH("
S DIK(1)="1^AD"
D EN1^DIK
;
; update 'free-text' authorization pointer if it changed
S FBFTPC=$P(FBY,U,10) ; current
S FBFTPN=$S(FBFTPC:$O(FBAUTCHG(FBFTPC,0)),1:"") ; new (if different)
I FBFTPN,FBFTPN'=FBFTPC D
. S DIE="^FBAACNH("
. S DR="9////^S X=FBFTPN"
. D ^DIE
Q
;
F1625 ; file 162.5 field 3 check/fix x-refs
N DA,DIK,FBY
D DA^DILF(FBIENS,.DA)
Q:'DA
S FBY=$G(^FBAAI(DA,0))
;
; delete "AI" x-ref for old value
I $P(FBY,U,3)]"",$P(FBY,U,2)]"",$P(FBY,U,11)]"" K ^FBAAI("AI",$P(FBY,U,3),$P(FBY,U,2),FBOVAL,$P(FBY,U,11),DA)
; delete "AA" x-ref for old value
I $P(FBY,U,3)]"",$P(FBY,U,6)]"" K ^FBAAI("AA",$P(FBY,U,3),FBOVAL,$E($P($P(FBY,U,6),"."),1,5),DA)
; delete "AE" x-ref for old value
I $P(FBY,U,17)]"" K ^FBAAI("AE",$P(FBY,U,17),FBOVAL,DA)
; re-index "AI","AA","AE" x-refs for entry
S DIK="^FBAAI("
S DIK(1)="3^AI^AA^AE"
D EN1^DIK K DIK
Q
;
F1627 ; file 162.7 field 2 check/fix 'free-text' pointer
N DA,DIE,DR,FBFTPC,FBFTPN,FBY
D DA^DILF(FBIENS,.DA)
Q:'DA
S FBY=$G(^FB583(DA,0))
;
; update 'free-text' authorization pointer if it changed
S FBFTPC=$P(FBY,U,27) ; current
S FBFTPN=$S(FBFTPC:$O(FBAUTCHG(FBFTPC,0)),1:"") ; new (if different)
I FBFTPN,FBFTPN'=FBFTPC D
. S DIE="^FB583("
. S DR="30////^S X=FBFTPN"
. D ^DIE
Q
;
;FBXIP19
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBXIP19 8793 printed Apr 09, 2024@21:04:52 Page 2
FBXIP19 ;WCIOFO/SAB-PATCH INSTALL ROUTINE ;10/25/2000
+1 ;;3.5;FEE BASIS;**19**;JAN 30, 1995
+2 ; This routine invokes IA #3228
+3 QUIT
+4 ;
PR ; pre-install entry point
+1 ; create KIDS checkpoints with call backs
+2 NEW FBX,Y
+3 FOR FBX="DXREF"
Begin DoDot:1
+4 SET Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP19")
+5 IF 'Y
DO BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")
End DoDot:1
+6 QUIT
+7 ;
PS ; post-install entry point
+1 ;
+2 ; only perform during 1st install
+3 IF $$PATCH^XPDUTL("FB*3.5*19")
DO BMES^XPDUTL(" Skipping post install since patch was previously installed.")
QUIT
+4 ;
+5 ; create KIDS checkpoints with call backs
+6 NEW FBX,Y
+7 FOR FBX="MERGED"
Begin DoDot:1
+8 SET Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP19")
+9 IF 'Y
DO BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")
End DoDot:1
+10 QUIT
+11 ;
DXREF ; Delete cross-references (Pre Install)
+1 ;
+2 ; Delete trigger x-ref because new logic has fewer nodes in DD
+3 ; trigger x-ref
DO DELIX^DDMOD(162.11,.01,2)
+4 ;
+5 ; This section deletes existing traditional style cross reference logic
+6 ; whose functionality is being replaced by new style cross references
+7 ; included in this patch.
+8 ; AG x-ref
DO DELIX^DDMOD(162.11,7,1)
+9 ; AJ x-ref
DO DELIX^DDMOD(162.11,13,2)
+10 ; AK x-ref
DO DELIX^DDMOD(162.11,13,3)
+11 ; AA x-ref
DO DELIX^DDMOD(162.11,15,1)
+12 ; AI x-ref
DO DELIX^DDMOD(162.2,14,1)
+13 ; AD x-ref
DO DELIX^DDMOD(162.3,3,1)
+14 ; AI1 x-ref
DO DELIX^DDMOD(162.5,1,1)
+15 ; AI x-ref
DO DELIX^DDMOD(162.5,10,1)
+16 ; AA x-ref
DO DELIX^DDMOD(162.5,5,1)
+17 ; AE x-ref
DO DELIX^DDMOD(162.5,20,2)
+18 QUIT
+19 ;
MERGED ; Check previously merged patients and fix FEE as needed (post install)
+1 NEW FBAUTCHG,FBDA,FBFR,FBTO,FBX
+2 KILL ^TMP($JOB)
+3 ; loop through MERGE IMAGES file (IA #3228)
+4 SET FBDA=0
FOR
SET FBDA=$ORDER(^XDRM(FBDA))
if 'FBDA
QUIT
Begin DoDot:1
+5 SET FBX=$GET(^XDRM(FBDA,0))
+6 ; from is not PATIENT file
if $PIECE($PIECE(FBX,U),";",2)'="DPT("
QUIT
+7 ; to is not PATIENT file
if $PIECE($PIECE(FBX,U,2),";",2)'="DPT("
QUIT
+8 ; From IEN of patient
SET FBFR=$PIECE($PIECE(FBX,U),";")
+9 ; To IEN of patient
SET FBTO=$PIECE($PIECE(FBX,U,2),";")
+10 ;
+11 ; load FEE before images for FBFR into ^TMP
DO LOADBI^FBXIP19A(1)
+12 ; load FEE before images for FBTO into ^TMP
DO LOADBI^FBXIP19A(2)
+13 ;
+14 ; process FEE BASIS PATIENT file authorization multiple (161.01)
+15 DO FB16101^FBXIP19A
+16 ;I $D(FBAUTCHG) W ! ZW FBAUTCHG
+17 ;
+18 ; process FEE BASIS PAYMENT file service provided multiple (162.03)
+19 DO FB16203^FBXIP19A
+20 ;
+21 ; process FEE BASIS PAYMENT file travel payment multiple (162.04)
+22 DO FB16204^FBXIP19A
+23 ;
+24 ; process changed pointers
+25 DO PCHG
+26 ;
End DoDot:1
+27 ; report any problems via mail message
+28 IF $DATA(^TMP($JOB,"PROB"))
Begin DoDot:1
+29 NEW DIFROM,FBFILE,FBFR,FBIENS,FBL,FBTO,FBTXT,XMDUZ,XMSUB,XMTEXT,XMY
+30 ; build message text
+31 SET ^TMP($JOB,"MSG",1)="The patch FB*3.5*19 post install was not able to automatically"
+32 SET ^TMP($JOB,"MSG",2)="process some of the previously merged fee data."
+33 SET ^TMP($JOB,"MSG",3)="This mail message has been sent to a developer for review."
+34 ; last line used for message text
SET FBL=3
+35 ;loop thru problems and load appropriate text into message
+36 SET FBFR=0
FOR
SET FBFR=$ORDER(^TMP($JOB,"PROB",FBFR))
if 'FBFR
QUIT
Begin DoDot:2
+37 SET FBTO=$PIECE($GET(^TMP($JOB,"PROB",FBFR)),U)
+38 SET FBL=FBL+1
SET ^TMP($JOB,"MSG",FBL)=" "
+39 SET FBL=FBL+1
SET ^TMP($JOB,"MSG",FBL)="ISSUES FOR PATIENT MERGED FROM "_FBFR_" INTO "_FBTO
+40 SET FBFILE=""
+41 FOR
SET FBFILE=$ORDER(^TMP($JOB,"PROB",FBFR,FBFILE))
if FBFILE=""
QUIT
Begin DoDot:3
+42 SET FBIENS=""
+43 FOR
SET FBIENS=$ORDER(^TMP($JOB,"PROB",FBFR,FBFILE,FBIENS))
if FBIENS=""
QUIT
Begin DoDot:4
+44 SET FBTXT=$GET(^TMP($JOB,"PROB",FBFR,FBFILE,FBIENS))
+45 SET FBL=FBL+1
SET ^TMP($JOB,"MSG",FBL)=" FILE: "_FBFILE_" IENS: "_FBIENS
+46 SET FBL=FBL+1
SET ^TMP($JOB,"MSG",FBL)=" "_FBTXT
End DoDot:4
End DoDot:3
End DoDot:2
+47 SET XMSUB="POST INSTALL FB*3.5*19"
+48 SET XMDUZ=.5
+49 SET XMTEXT="^TMP($J,""MSG"","
+50 SET XMY("BAUMANN,SCOTT@DOMAIN.EXT")=""
SET XMY(DUZ)=""
+51 DO ^XMD
End DoDot:1
+52 ;
+53 ; cleanup
+54 KILL ^TMP($JOB)
+55 QUIT
+56 ;
PCHG ; Process Pointers Changed multiple in MERGE IMAGES file
+1 ; before this patch, nine x-refs depended on the patient but were
+2 ; not updated if the patient pointer was changed.
+3 ; check/update those x-refs for patients merged prior to this patch
+4 ; also update 'free-text' authorization pointers when necessary
+5 ; input
+6 ; FBDA - entry in MERGE IMAGES file
+7 ; FBAUTCHG(old ien,new ien) - array of changed authorization iens
+8 ; output
+9 ; update cross-reference values in various FEE files
+10 ; update 'free-text' authorization pointers in various FEE files
+11 ;
+12 NEW FBDA1,FBFILE,FBFLD,FBIENS,FBOVAL,FBPC
+13 ;
+14 ; loop thru "B" x-ref of POINTERS CHANGED multiple in MERGE IMAGES
+15 SET FBPC="161 "
+16 FOR
SET FBPC=$ORDER(^XDRM(FBDA,3,"B",FBPC))
if FBPC=""!(FBPC]"164 ")
QUIT
Begin DoDot:1
+17 SET FBDA1=0
FOR
SET FBDA1=$ORDER(^XDRM(FBDA,3,"B",FBPC,FBDA1))
if 'FBDA1
QUIT
Begin DoDot:2
+18 SET FBFILE=$PIECE($PIECE(FBPC,U),";")
+19 SET FBIENS=$PIECE($PIECE(FBPC,U),";",2)
+20 SET FBFLD=$PIECE($PIECE(FBPC,U),";",3)
+21 SET FBOVAL=$PIECE($GET(^XDRM(FBDA,3,FBDA1,1)),U)
+22 if FBOVAL=""
QUIT
+23 ;W !,"POINTER CHANGED for FILE: "_FBFILE_" FIELD: "_FBFLD_" OLD VAL "_FBOVAL_" IENS: "_FBIENS
+24 ;Q ; *** temp quit for testing
+25 IF FBFILE=161.26
IF FBFLD=.01
DO F16126
+26 IF FBFILE=162.11
IF FBFLD=4
DO F16211
+27 IF FBFILE=162.2
IF FBFLD=3
DO F1622
+28 IF FBFILE=162.3
IF FBFLD=1
DO F1623
+29 IF FBFILE=162.5
IF FBFLD=3
DO F1625
+30 IF FBFILE=162.7
IF FBFLD=2
DO F1627
End DoDot:2
End DoDot:1
+31 QUIT
+32 ;
F16126 ; file 161.26 field .01 check/fix 'free-text' pointer
+1 NEW DA,DIE,DR,FBFTPC,FBFTPN,FBY
+2 DO DA^DILF(FBIENS,.DA)
+3 if 'DA
QUIT
+4 SET FBY=$GET(^FBAA(161.26,DA,0))
+5 ;
+6 ; update 'free-text' authorization pointer if it changed
+7 ; current
SET FBFTPC=$PIECE(FBY,U,3)
+8 ; new (if different)
SET FBFTPN=$SELECT(FBFTPC:$ORDER(FBAUTCHG(FBFTPC,0)),1:"")
+9 IF FBFTPN
IF FBFTPN'=FBFTPC
Begin DoDot:1
+10 SET DIE="^FBAA(161.26,"
+11 SET DR="2////^S X=FBFTPN"
+12 DO ^DIE
End DoDot:1
+13 QUIT
+14 ;
F16211 ; file 162.11 field 4 check/fix x-refs & 'free-text' pointer
+1 NEW DA,DIE,DIK,DR,FBFTPC,FBFTPN,FBRXY,FBY
+2 DO DA^DILF(FBIENS,.DA)
+3 if 'DA(1)
QUIT
+4 if 'DA
QUIT
+5 SET FBY=$GET(^FBAA(162.1,DA(1),0))
+6 SET FBRXY=$GET(^FBAA(162.1,DA(1),"RX",DA,0))
+7 ;
+8 ; delete "AG" x-ref for old value
+9 IF $PIECE(FBY,U,4)]""
IF $PIECE(FBY,U,8)]""
IF $PIECE(FBRXY,U,8)]""
KILL ^FBAA(162.1,"AG",$PIECE(FBY,U,4),$PIECE(FBY,U,8),FBOVAL,$PIECE(FBRXY,U,8),DA(1),DA)
+10 ; delete "AJ" x-ref for old value
+11 IF $PIECE(FBRXY,U,17)]""
KILL ^FBAA(162.1,"AJ",$PIECE(FBRXY,U,17),FBOVAL,DA(1),DA)
+12 ; delete "AK" x-ref for old value
+13 IF $PIECE(FBY,U,4)]""
IF $PIECE(FBRXY,U,3)]""
KILL ^FBAA(162.1,"AK",$PIECE(FBY,U,4),9999999-$PIECE(FBRXY,U,3),FBOVAL,DA(1),DA)
+14 ; delete "AA" x-ref for old value
+15 IF $PIECE(FBRXY,U,19)]""
KILL ^FBAA(162.1,"AA",$PIECE(FBRXY,U,19),FBOVAL,DA(1),DA)
+16 ; re-index "AG","AJ","AK","AA" x-refs for entry
+17 SET DIK="^FBAA(162.1,"_DA(1)_",""RX"","
+18 SET DIK(1)="4^AA^AG^AJ^AK"
+19 DO EN1^DIK
+20 ;
+21 ; update 'free-text' authorization pointer if it changed
+22 ; current
SET FBFTPC=$PIECE($GET(^FBAA(162.1,DA(1),"RX",DA,2)),U,7)
+23 ; new (if different)
SET FBFTPN=$SELECT(FBFTPC:$ORDER(FBAUTCHG(FBFTPC,0)),1:"")
+24 IF FBFTPN
IF FBFTPN'=FBFTPC
Begin DoDot:1
+25 SET DIE="^FBAA(162.1,"_DA(1)_",""RX"","
+26 SET DR="27////^S X=FBFTPN"
+27 DO ^DIE
End DoDot:1
+28 QUIT
+29 ;
F1622 ; file 162.2 field 3 check/fix x-ref
+1 NEW DA,DIK,FBY
+2 DO DA^DILF(FBIENS,.DA)
+3 if 'DA
QUIT
+4 SET FBY=$GET(^FBAA(162.2,DA,0))
+5 ;
+6 ; delete "AI" x-ref for old value
+7 IF $PIECE(FBY,U,2)]""
IF $PIECE(FBY,U,13)]""
IF $PIECE(FBY,U,16)]""
KILL ^FBAA(162.2,"AI",$PIECE(FBY,U,2),$PIECE(FBY,U,13),FBOVAL,$PIECE(FBY,U,16),DA)
+8 ; re-index "AI" x-ref for entry
+9 SET DIK="^FBAA(162.2,"
+10 SET DIK(1)="3^AI"
+11 DO EN1^DIK
+12 QUIT
+13 ;
F1623 ; file 162.3 field 1 check/fix x-ref and 'free-text' pointer
+1 NEW DA,DIE,DIK,DR,FBFTPC,FBFTPN,FBY
+2 DO DA^DILF(FBIENS,.DA)
+3 if 'DA
QUIT
+4 SET FBY=$GET(^FBAACNH(DA,0))
+5 ;
+6 ; delete "AD" x-ref for old value
+7 IF $PIECE(FBY,U,4)]""
KILL ^FBAACNH("AD",FBOVAL,DA)
+8 ; re-index "AD" x-ref for entry
+9 SET DIK="^FBAACNH("
+10 SET DIK(1)="1^AD"
+11 DO EN1^DIK
+12 ;
+13 ; update 'free-text' authorization pointer if it changed
+14 ; current
SET FBFTPC=$PIECE(FBY,U,10)
+15 ; new (if different)
SET FBFTPN=$SELECT(FBFTPC:$ORDER(FBAUTCHG(FBFTPC,0)),1:"")
+16 IF FBFTPN
IF FBFTPN'=FBFTPC
Begin DoDot:1
+17 SET DIE="^FBAACNH("
+18 SET DR="9////^S X=FBFTPN"
+19 DO ^DIE
End DoDot:1
+20 QUIT
+21 ;
F1625 ; file 162.5 field 3 check/fix x-refs
+1 NEW DA,DIK,FBY
+2 DO DA^DILF(FBIENS,.DA)
+3 if 'DA
QUIT
+4 SET FBY=$GET(^FBAAI(DA,0))
+5 ;
+6 ; delete "AI" x-ref for old value
+7 IF $PIECE(FBY,U,3)]""
IF $PIECE(FBY,U,2)]""
IF $PIECE(FBY,U,11)]""
KILL ^FBAAI("AI",$PIECE(FBY,U,3),$PIECE(FBY,U,2),FBOVAL,$PIECE(FBY,U,11),DA)
+8 ; delete "AA" x-ref for old value
+9 IF $PIECE(FBY,U,3)]""
IF $PIECE(FBY,U,6)]""
KILL ^FBAAI("AA",$PIECE(FBY,U,3),FBOVAL,$EXTRACT($PIECE($PIECE(FBY,U,6),"."),1,5),DA)
+10 ; delete "AE" x-ref for old value
+11 IF $PIECE(FBY,U,17)]""
KILL ^FBAAI("AE",$PIECE(FBY,U,17),FBOVAL,DA)
+12 ; re-index "AI","AA","AE" x-refs for entry
+13 SET DIK="^FBAAI("
+14 SET DIK(1)="3^AI^AA^AE"
+15 DO EN1^DIK
KILL DIK
+16 QUIT
+17 ;
F1627 ; file 162.7 field 2 check/fix 'free-text' pointer
+1 NEW DA,DIE,DR,FBFTPC,FBFTPN,FBY
+2 DO DA^DILF(FBIENS,.DA)
+3 if 'DA
QUIT
+4 SET FBY=$GET(^FB583(DA,0))
+5 ;
+6 ; update 'free-text' authorization pointer if it changed
+7 ; current
SET FBFTPC=$PIECE(FBY,U,27)
+8 ; new (if different)
SET FBFTPN=$SELECT(FBFTPC:$ORDER(FBAUTCHG(FBFTPC,0)),1:"")
+9 IF FBFTPN
IF FBFTPN'=FBFTPC
Begin DoDot:1
+10 SET DIE="^FB583("
+11 SET DR="30////^S X=FBFTPN"
+12 DO ^DIE
End DoDot:1
+13 QUIT
+14 ;
+15 ;FBXIP19
