- 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 Feb 18, 2025@23:26:15 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