FBPST35B ;ACAMPUS/DMK-CONVERT FILE 163.99
;;3.5;FEE BASIS;;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;This post-init routine goes through file 163.99 and converts the .01
;field from a pointer to the CPT file(#81) to the external value.
;The .01 field is converted to free text with this install to allow
;for the incorperation of CPT Modifiers to the Fee Schedule.
;
Q:+$G(^DD(163.99,0,"VR"))>3
W !!,"Beginning FBPST35B ....",!!?18,"CONVERSION OF FEE BASIS FEE SCHEDULE FILE (#163.99)"
N FBI,FBX,DA,DIE,DR,X
S FBI=0
F S FBI=$O(^FBAA(163.99,FBI)) Q:'FBI I $D(^(FBI,0)) D
. S DA=FBI Q:'$D(^ICPT(FBI,0)) S FBX=$P(^(0),U)
. S DIE="^FBAA(163.99,",DR=".01////^S X=FBX" D ^DIE
;clean up old PT node in file 81
K ^DD(81,0,"PT",163.99,.01)
W !!,"Completed FBPST35B " D NOW^%DTC W $$DATX^FBAAUTL(%)
Q
VENDOR ;clean up invalid ID entries still in 161.25
S FBI=0 F S FBI=$O(^FBAA(161.25,FBI)) Q:'FBI S FBL=+$P($G(^FBAA(161.25,FBI,0)),U,6) D
.I FBL,(FBI'=FBL) Q
.S FBJ=0 F S FBJ=$O(^FBAA(161.25,"AF",FBI,FBJ)) Q:'FBJ I (FBI'=FBJ) S FBOUT=1 Q
.I $G(FBOUT) K FBOUT Q
.S FBID=$P($G(^FBAAV(FBI,0)),U,2) I FBID']""!($A(FBID)=45)!($L(FBID)>11)!($L(FBID)<9)!(+FBID=0)!(FBID'?9N.2AN) D
..S FB(FBI)=""
..S DIK="^FBAA(161.25,",DA=FBI D ^DIK K DIK,DA
..S DIE="^FBAAV(",DA=FBI,DR="9////^S X=""Y"";13///^S X=""T""" D ^DIE K DIE,DA,DR
I '$D(FB) G END
S PAD=" ",$P(PAD," ",40)="",FBCTR=2,FBTEXT(1,0)="The following vendors with invalid ID's have been placed in delete status:",FBTEXT(2,0)=" "
S FBI=0 F S FBI=$O(FB(FBI)) Q:'FBI S FBCTR=FBCTR+1,FBTEXT((FBCTR),0)=" "_$E($$VNAME^FBNHEXP(FBI),1,30)_$E(PAD,$L($$VNAME^FBNHEXP(FBI))+1,40)_$$VID^FBNHEXP(FBI)
S XMSUB="FEE BASIS VENDOR CORRECTIONS CLEANUP",XMDUZ=.5,XMY("G.FEE")="",XMTEXT="FBTEXT(" D ^XMD K FBTEXT,XMDUZ,XMSUB,XMY,XMTEXT,XMZ,PAD,FBCTR
END K FBI,FBJ,FBL,FBID,FB,X,Y,DIC
Q
XREF ;fix cross-references in 162 and 162.1 on date finalized & cert fields
S ZTRTN="FIX^FBPST35B",ZTIO="",ZTDTH=$H D ^%ZTLOAD
K ZTSK
Q
FIX ;outpatient x-ref fix on field date finalized
S FBV=0 F S FBV=$O(^FBAAC("AP",FBV)) Q:'FBV D
.S FBI=0 F S FBI=$O(^FBAAC("AP",FBV,FBI)) Q:'FBI D
..S DFN=0 F S DFN=$O(^FBAAC("AP",FBV,FBI,DFN)) Q:'DFN D
...S FBSDT=0 F S FBSDT=$O(^FBAAC("AP",FBV,FBI,DFN,FBSDT)) Q:'FBSDT D
....S FBCPT=0 F S FBCPT=$O(^FBAAC("AP",FBV,FBI,DFN,FBSDT,FBCPT)) Q:'FBCPT D
.....I $P($G(^FBAAC(DFN,1,FBV,1,FBSDT,1,FBCPT,0)),"^",6)'=FBI D
......K ^FBAAC("AK",FBI,DFN,FBV,FBSDT,FBCPT),^FBAAC("AP",FBV,FBI,DFN,FBSDT,FBCPT)
......S FBPSA=$P($G(^FBAAC(DFN,1,FBV,1,FBSDT,1,FBCPT,0)),"^",12) I FBPSA K ^FBAAC("AQ",FBPSA,9999999-FBI,DFN,FBV,FBSDT,FBCPT)
FIXRX ;fix Pharmacy Invoice x-ref on field date certified for payment
S FBI=0 F S FBI=$O(^FBAA(162.1,"AA",FBI)) Q:'FBI D
.S DFN=0 F S DFN=$O(^FBAA(162.1,"AA",FBI,DFN)) Q:'DFN D
..S FBIN=0 F S FBIN=$O(^FBAA(162.1,"AA",FBI,DFN,FBIN)) Q:'FBIN D
...S FBRX=0 F S FBRX=$O(^FBAA(162.1,"AA",FBI,DFN,FBIN,FBRX)) Q:'FBRX D
....S FBDT=$P($G(^FBAA(162.1,FBIN,"RX",FBRX,0)),"^",19) D K FBDT
.....Q:FBDT=FBI
.....I FBDT,(FBDT'=FBI) S $P(^FBAA(162.1,FBIN,"RX",FBRX,0),"^",19)=FBI Q
.....K ^FBAA(162.1,"AA",FBI,DFN,FBIN,FBRX)
.....S FBPSA=$P($G(^FBAA(162.1,FBIN,"RX",FBRX,2)),"^",5) I FBPSA K ^FBAA(162.1,"AI",FBPSA,9999999-FBI,FBIN,FBRX)
K FBI,DFN,FBV,FBSDT,FBCPT,FBPSA,FBIN,FBRX,FBDT S ZTREQ="@"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBPST35B 3427 printed Sep 23, 2025@19:35:55 Page 2
FBPST35B ;ACAMPUS/DMK-CONVERT FILE 163.99
+1 ;;3.5;FEE BASIS;;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;This post-init routine goes through file 163.99 and converts the .01
+4 ;field from a pointer to the CPT file(#81) to the external value.
+5 ;The .01 field is converted to free text with this install to allow
+6 ;for the incorperation of CPT Modifiers to the Fee Schedule.
+7 ;
+8 if +$GET(^DD(163.99,0,"VR"))>3
QUIT
+9 WRITE !!,"Beginning FBPST35B ....",!!?18,"CONVERSION OF FEE BASIS FEE SCHEDULE FILE (#163.99)"
+10 NEW FBI,FBX,DA,DIE,DR,X
+11 SET FBI=0
+12 FOR
SET FBI=$ORDER(^FBAA(163.99,FBI))
if 'FBI
QUIT
IF $DATA(^(FBI,0))
Begin DoDot:1
+13 SET DA=FBI
if '$DATA(^ICPT(FBI,0))
QUIT
SET FBX=$PIECE(^(0),U)
+14 SET DIE="^FBAA(163.99,"
SET DR=".01////^S X=FBX"
DO ^DIE
End DoDot:1
+15 ;clean up old PT node in file 81
+16 KILL ^DD(81,0,"PT",163.99,.01)
+17 WRITE !!,"Completed FBPST35B "
DO NOW^%DTC
WRITE $$DATX^FBAAUTL(%)
+18 QUIT
VENDOR ;clean up invalid ID entries still in 161.25
+1 SET FBI=0
FOR
SET FBI=$ORDER(^FBAA(161.25,FBI))
if 'FBI
QUIT
SET FBL=+$PIECE($GET(^FBAA(161.25,FBI,0)),U,6)
Begin DoDot:1
+2 IF FBL
IF (FBI'=FBL)
QUIT
+3 SET FBJ=0
FOR
SET FBJ=$ORDER(^FBAA(161.25,"AF",FBI,FBJ))
if 'FBJ
QUIT
IF (FBI'=FBJ)
SET FBOUT=1
QUIT
+4 IF $GET(FBOUT)
KILL FBOUT
QUIT
+5 SET FBID=$PIECE($GET(^FBAAV(FBI,0)),U,2)
IF FBID']""!($ASCII(FBID)=45)!($LENGTH(FBID)>11)!($LENGTH(FBID)<9)!(+FBID=0)!(FBID'?9N.2AN)
Begin DoDot:2
+6 SET FB(FBI)=""
+7 SET DIK="^FBAA(161.25,"
SET DA=FBI
DO ^DIK
KILL DIK,DA
+8 SET DIE="^FBAAV("
SET DA=FBI
SET DR="9////^S X=""Y"";13///^S X=""T"""
DO ^DIE
KILL DIE,DA,DR
End DoDot:2
End DoDot:1
+9 IF '$DATA(FB)
GOTO END
+10 SET PAD=" "
SET $PIECE(PAD," ",40)=""
SET FBCTR=2
SET FBTEXT(1,0)="The following vendors with invalid ID's have been placed in delete status:"
SET FBTEXT(2,0)=" "
+11 SET FBI=0
FOR
SET FBI=$ORDER(FB(FBI))
if 'FBI
QUIT
SET FBCTR=FBCTR+1
SET FBTEXT((FBCTR),0)=" "_$EXTRACT($$VNAME^FBNHEXP(FBI),1,30)_$EXTRACT(PAD,$LENGTH($$VNAME^FBNHEXP(FBI))+1,40)_$$VID^FBNHEXP(FBI)
+12 SET XMSUB="FEE BASIS VENDOR CORRECTIONS CLEANUP"
SET XMDUZ=.5
SET XMY("G.FEE")=""
SET XMTEXT="FBTEXT("
DO ^XMD
KILL FBTEXT,XMDUZ,XMSUB,XMY,XMTEXT,XMZ,PAD,FBCTR
END KILL FBI,FBJ,FBL,FBID,FB,X,Y,DIC
+1 QUIT
XREF ;fix cross-references in 162 and 162.1 on date finalized & cert fields
+1 SET ZTRTN="FIX^FBPST35B"
SET ZTIO=""
SET ZTDTH=$HOROLOG
DO ^%ZTLOAD
+2 KILL ZTSK
+3 QUIT
FIX ;outpatient x-ref fix on field date finalized
+1 SET FBV=0
FOR
SET FBV=$ORDER(^FBAAC("AP",FBV))
if 'FBV
QUIT
Begin DoDot:1
+2 SET FBI=0
FOR
SET FBI=$ORDER(^FBAAC("AP",FBV,FBI))
if 'FBI
QUIT
Begin DoDot:2
+3 SET DFN=0
FOR
SET DFN=$ORDER(^FBAAC("AP",FBV,FBI,DFN))
if 'DFN
QUIT
Begin DoDot:3
+4 SET FBSDT=0
FOR
SET FBSDT=$ORDER(^FBAAC("AP",FBV,FBI,DFN,FBSDT))
if 'FBSDT
QUIT
Begin DoDot:4
+5 SET FBCPT=0
FOR
SET FBCPT=$ORDER(^FBAAC("AP",FBV,FBI,DFN,FBSDT,FBCPT))
if 'FBCPT
QUIT
Begin DoDot:5
+6 IF $PIECE($GET(^FBAAC(DFN,1,FBV,1,FBSDT,1,FBCPT,0)),"^",6)'=FBI
Begin DoDot:6
+7 KILL ^FBAAC("AK",FBI,DFN,FBV,FBSDT,FBCPT),^FBAAC("AP",FBV,FBI,DFN,FBSDT,FBCPT)
+8 SET FBPSA=$PIECE($GET(^FBAAC(DFN,1,FBV,1,FBSDT,1,FBCPT,0)),"^",12)
IF FBPSA
KILL ^FBAAC("AQ",FBPSA,9999999-FBI,DFN,FBV,FBSDT,FBCPT)
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
FIXRX ;fix Pharmacy Invoice x-ref on field date certified for payment
+1 SET FBI=0
FOR
SET FBI=$ORDER(^FBAA(162.1,"AA",FBI))
if 'FBI
QUIT
Begin DoDot:1
+2 SET DFN=0
FOR
SET DFN=$ORDER(^FBAA(162.1,"AA",FBI,DFN))
if 'DFN
QUIT
Begin DoDot:2
+3 SET FBIN=0
FOR
SET FBIN=$ORDER(^FBAA(162.1,"AA",FBI,DFN,FBIN))
if 'FBIN
QUIT
Begin DoDot:3
+4 SET FBRX=0
FOR
SET FBRX=$ORDER(^FBAA(162.1,"AA",FBI,DFN,FBIN,FBRX))
if 'FBRX
QUIT
Begin DoDot:4
+5 SET FBDT=$PIECE($GET(^FBAA(162.1,FBIN,"RX",FBRX,0)),"^",19)
Begin DoDot:5
+6 if FBDT=FBI
QUIT
+7 IF FBDT
IF (FBDT'=FBI)
SET $PIECE(^FBAA(162.1,FBIN,"RX",FBRX,0),"^",19)=FBI
QUIT
+8 KILL ^FBAA(162.1,"AA",FBI,DFN,FBIN,FBRX)
+9 SET FBPSA=$PIECE($GET(^FBAA(162.1,FBIN,"RX",FBRX,2)),"^",5)
IF FBPSA
KILL ^FBAA(162.1,"AI",FBPSA,9999999-FBI,FBIN,FBRX)
End DoDot:5
KILL FBDT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+10 KILL FBI,DFN,FBV,FBSDT,FBCPT,FBPSA,FBIN,FBRX,FBDT
SET ZTREQ="@"
+11 QUIT
