FBPHON2 ;AISC/CMR-LIST PAYMENTS CONT. ;4/17/2000
;;3.5;FEE BASIS;**4,21,77**;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
D FULL^VALM1
EN N FBI,FBX,FBAAOUT,Q S Q="-",$P(Q,"-",80)="-",FBAAOUT=0,VALMBCK="R"
D SEL^VALM2 G END:'$O(VALMY(0))
S FBI=0 F S FBI=$O(VALMY(FBI)) Q:'FBI I $D(^TMP("FBPHIDX",$J,FBI)) S FBX=^(FBI) D @FBPR I '$G(FBAAOUT) S DIR(0)="E",DIR("A")="Press 'ENTER' to "_$S($O(VALMY(FBI)):"view next selection",1:"return to list") D ^DIR K DIR Q:'Y
Q
END S VALMBCK="R" Q
BT ;display batch for chosen line item
W @IOF N B
S B=$P(FBX,U,8) I B']"" D ERR Q
I $D(^FBAA(161.7,B,0)) S FBTYPE=$P(^FBAA(161.7,B,0),U,3)
D ENM^FBAACCB:FBTYPE="B3",ENP^FBAACCB:FBTYPE="B5",ENT^FBAACCB0:FBTYPE="B2",PRTC^FBAACCB1:FBTYPE="B9"
Q
INV ;display invoice for chosen line item
W @IOF N FBAAIN,FBAAOUT,FBINTOT,J,DA,FBI
I $P(FBX,U,7)']"" D ERR Q
I $P(FBX,U)="PHAR" S DA=$P(FBX,U,7) D START^FBAAPII Q
I $P(FBX,U)="CH"!($P(FBX,U)="CNH") S FBI=$P(FBX,U,7) D START^FBCHDI2 Q
I $P(FBX,U)="OPT" D D Q^FBAAPIN
.S FBAAIN=$P(FBX,U,7),(FBAAOUT,FBINTOT,J)=0 F S J=$O(^FBAAC("C",FBAAIN,J)) Q:'J!(FBAAOUT) D MMORE^FBAAPIN
D Q^FBAAPIN
Q
BS ;display batch status for chosen line item
W @IOF N DA
I $P(FBX,U,8)']"" D ERR Q
S DA=$P(FBX,U,8) D START^FBAABS
Q
DV ;display vendor demographics for chosen vendor
N DA S VALMBCK="R"
S DA=FBV D CLEAR^VALM1,EN1^FBAAVD
I $D(^XUSEC("FBAA ESTABLISH VENDOR",DUZ)) S DIR(0)="Y",DIR("A")="Want to Edit data",DIR("B")="NO" D ^DIR K DIR Q:$D(DIRUT) D:Y EDITV^FBAAVD
I '$D(^XUSEC("FBAA ESTABLISH VENDOR",DUZ)) S DIR(0)="E" D ^DIR K DIR
D Q^FBAAVD Q
DA ;display patient auth for selected line item
W @IOF N FB1,FBDA,FBTYP
S FBDA=$P(FBX,U,9)
I $P(FBX,U)="OPT" S FB1=$P(^FBAAC(DFN,1,FBV,1,$P(FBDA,",",3),1,$P(FBDA,",",4),0),U,13) D Q
.I FB1']"" S FBPROG=$P(^FBAAC(DFN,1,FBV,1,$P(FBDA,",",3),0),U,4),FBPROG=$S(FBPROG:"I FBI="_FBPROG,1:""),PI="" D ^FBAADEM K FBPROG,FBAUT,PI Q
.I FB1["583" D UNAUTH Q
.I FB1["7078" D INP Q
I $P(FBX,U)="PHAR" S FB1=$P(^FBAA(162.1,+FBDA,"RX",$P(FBDA,",",2),2),U,6) D Q
.I FB1']"" S FBPROG=$P($G(^FBAA(162.1,+FBDA,"RX",$P(FBDA,",",2),2)),U,7),FBPROG=$S(FBPROG:"I FBI="_FBPROG,1:""),PI="" D ^FBAADEM K FBPROG,FBAUT,PI Q
.I FB1["583" D UNAUTH Q
.I FB1["7078" D INP Q
I $P(FBX,U)["C" S FB1=$P(^FBAAI(+FBDA,0),U,5) I FB1["583" D UNAUTH Q
INP N DA,FBDA,DIC,DR S (FBDA,DA)=+FB1,DIC="^FB7078(",DR="0;1" W @IOF D EN^DIQ
I $$DISCH^FBCH780(FBDA)]"" W ?2,"DISCHARGE TYPE: ",$$DISCH^FBCH780(FBDA)
Q
UNAUTH N DA,DIC,DR S DA=+FB1,DIC="^FB583(",DR="0;1" W @IOF D EN^DIQ
Q
EV ;expand view
W @IOF N FBZ S FBZ=$P(FBX,U,9)
I $P(FBX,U)="OPT" S DIC="^FBAAC("_DFN_",1,"_FBV_",1,"_$P(FBZ,",",3)_",1,",DA(3)=DFN,DA(2)=FBV,DA(1)=$P(FBZ,",",3),DA=$P(FBZ,",",4),DR=""
I $P(FBX,U)="PHAR" S DIC="^FBAA(162.1,"_+FBZ_",""RX"",",DA(1)=+FBZ,DA=$P(FBZ,",",2),DR=""
I $P(FBX,U)["C" S DIC="^FBAAI(",DA=FBZ,DR=""
W @IOF D EN^DIQ
K DIC,DA,DR
Q
CP ;change patient
D CLEAR^VALM1
N FBCP S VALMBCK="R"
S DIR(0)="P^161:EMZ",DIR("A")="Payments for veteran" D ^DIR K DIR I $D(DIRUT) Q
S DFN=+Y,FBCP=1 D HDR^FBPHON,START^FBPHON
Q
CV ;change vendor
D CLEAR^VALM1
N FBCP S VALMBCK="R"
S DIR(0)="P^161.2:EMZ" D ^DIR K DIR Q:$D(DIRUT)
S FBV=+Y,FBCP=1 D HDR^FBPHON,START^FBPHON
Q
DC ;display check
W @IOF S FBCN=$P(FBX,U,11) I FBCN']"" W !,*7,"No check found for this line item." Q
D START^FBCKDIS
Q
CD ;display CPT/MOD description
W @IOF
N FBCPT,FBJ,FBMOD,FBMODX
Q:$P(FBX,U)'="OPT"!($P(FBX,U,3)']"")
S FBCPT=$P(FBX,U,3) W !,"Line item #",FBI,!?5,"CPT: ",$P(FBCPT,"-"),?18,$P($$CPT^ICPTCOD($P(FBCPT,"-"),$S(+$P(FBX,U,2)>0:+$P(FBX,U,2),1:""),1),U,3)
I FBCPT["-" F FBJ=1:1 S FBMOD=$P($P(FBCPT,"-",2),",",FBJ) Q:FBMOD="" D
. W !?5,"MOD: ",FBMOD
. S FBMODX=$$MOD^ICPTMOD(FBMOD,"E",$P(FBX,U,2))
. ; if modifier data not obtained then try another API to resolve it
. ; since there can be duplicate modifiers with same external value
. I $P(FBMODX,U)'>0 D
. . N FBY
. . S FBY=$$MODP^ICPTMOD($P(FBCPT,"-"),FBMOD,"E",$P(FBX,U,2))
. . I $P(FBY,U)>0 S FBMODX=$$MOD^ICPTMOD($P(FBY,U),"I",$P(FBX,U,2))
. W ?18,$S($P(FBMODX,U)>0:$P(FBMODX,U,3),1:"")
Q
ERR ;
W !,"No ",$S(FBPR["B":"batch",1:"invoice")," number on file for this entry" Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBPHON2 4318 printed Oct 16, 2024@18:00:32 Page 2
FBPHON2 ;AISC/CMR-LIST PAYMENTS CONT. ;4/17/2000
+1 ;;3.5;FEE BASIS;**4,21,77**;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 DO FULL^VALM1
EN NEW FBI,FBX,FBAAOUT,Q
SET Q="-"
SET $PIECE(Q,"-",80)="-"
SET FBAAOUT=0
SET VALMBCK="R"
+1 DO SEL^VALM2
if '$ORDER(VALMY(0))
GOTO END
+2 SET FBI=0
FOR
SET FBI=$ORDER(VALMY(FBI))
if 'FBI
QUIT
IF $DATA(^TMP("FBPHIDX",$JOB,FBI))
SET FBX=^(FBI)
DO @FBPR
IF '$GET(FBAAOUT)
SET DIR(0)="E"
SET DIR("A")="Press 'ENTER' to "_$SELECT($ORDER(VALMY(FBI)):"view next selection",1:"return to list")
DO ^DIR
KILL DIR
if 'Y
QUIT
+3 QUIT
END SET VALMBCK="R"
QUIT
BT ;display batch for chosen line item
+1 WRITE @IOF
NEW B
+2 SET B=$PIECE(FBX,U,8)
IF B']""
DO ERR
QUIT
+3 IF $DATA(^FBAA(161.7,B,0))
SET FBTYPE=$PIECE(^FBAA(161.7,B,0),U,3)
+4 if FBTYPE="B3"
DO ENM^FBAACCB
if FBTYPE="B5"
DO ENP^FBAACCB
if FBTYPE="B2"
DO ENT^FBAACCB0
if FBTYPE="B9"
DO PRTC^FBAACCB1
+5 QUIT
INV ;display invoice for chosen line item
+1 WRITE @IOF
NEW FBAAIN,FBAAOUT,FBINTOT,J,DA,FBI
+2 IF $PIECE(FBX,U,7)']""
DO ERR
QUIT
+3 IF $PIECE(FBX,U)="PHAR"
SET DA=$PIECE(FBX,U,7)
DO START^FBAAPII
QUIT
+4 IF $PIECE(FBX,U)="CH"!($PIECE(FBX,U)="CNH")
SET FBI=$PIECE(FBX,U,7)
DO START^FBCHDI2
QUIT
+5 IF $PIECE(FBX,U)="OPT"
Begin DoDot:1
+6 SET FBAAIN=$PIECE(FBX,U,7)
SET (FBAAOUT,FBINTOT,J)=0
FOR
SET J=$ORDER(^FBAAC("C",FBAAIN,J))
if 'J!(FBAAOUT)
QUIT
DO MMORE^FBAAPIN
End DoDot:1
DO Q^FBAAPIN
+7 DO Q^FBAAPIN
+8 QUIT
BS ;display batch status for chosen line item
+1 WRITE @IOF
NEW DA
+2 IF $PIECE(FBX,U,8)']""
DO ERR
QUIT
+3 SET DA=$PIECE(FBX,U,8)
DO START^FBAABS
+4 QUIT
DV ;display vendor demographics for chosen vendor
+1 NEW DA
SET VALMBCK="R"
+2 SET DA=FBV
DO CLEAR^VALM1
DO EN1^FBAAVD
+3 IF $DATA(^XUSEC("FBAA ESTABLISH VENDOR",DUZ))
SET DIR(0)="Y"
SET DIR("A")="Want to Edit data"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
if Y
DO EDITV^FBAAVD
+4 IF '$DATA(^XUSEC("FBAA ESTABLISH VENDOR",DUZ))
SET DIR(0)="E"
DO ^DIR
KILL DIR
+5 DO Q^FBAAVD
QUIT
DA ;display patient auth for selected line item
+1 WRITE @IOF
NEW FB1,FBDA,FBTYP
+2 SET FBDA=$PIECE(FBX,U,9)
+3 IF $PIECE(FBX,U)="OPT"
SET FB1=$PIECE(^FBAAC(DFN,1,FBV,1,$PIECE(FBDA,",",3),1,$PIECE(FBDA,",",4),0),U,13)
Begin DoDot:1
+4 IF FB1']""
SET FBPROG=$PIECE(^FBAAC(DFN,1,FBV,1,$PIECE(FBDA,",",3),0),U,4)
SET FBPROG=$SELECT(FBPROG:"I FBI="_FBPROG,1:"")
SET PI=""
DO ^FBAADEM
KILL FBPROG,FBAUT,PI
QUIT
+5 IF FB1["583"
DO UNAUTH
QUIT
+6 IF FB1["7078"
DO INP
QUIT
End DoDot:1
QUIT
+7 IF $PIECE(FBX,U)="PHAR"
SET FB1=$PIECE(^FBAA(162.1,+FBDA,"RX",$PIECE(FBDA,",",2),2),U,6)
Begin DoDot:1
+8 IF FB1']""
SET FBPROG=$PIECE($GET(^FBAA(162.1,+FBDA,"RX",$PIECE(FBDA,",",2),2)),U,7)
SET FBPROG=$SELECT(FBPROG:"I FBI="_FBPROG,1:"")
SET PI=""
DO ^FBAADEM
KILL FBPROG,FBAUT,PI
QUIT
+9 IF FB1["583"
DO UNAUTH
QUIT
+10 IF FB1["7078"
DO INP
QUIT
End DoDot:1
QUIT
+11 IF $PIECE(FBX,U)["C"
SET FB1=$PIECE(^FBAAI(+FBDA,0),U,5)
IF FB1["583"
DO UNAUTH
QUIT
INP NEW DA,FBDA,DIC,DR
SET (FBDA,DA)=+FB1
SET DIC="^FB7078("
SET DR="0;1"
WRITE @IOF
DO EN^DIQ
+1 IF $$DISCH^FBCH780(FBDA)]""
WRITE ?2,"DISCHARGE TYPE: ",$$DISCH^FBCH780(FBDA)
+2 QUIT
UNAUTH NEW DA,DIC,DR
SET DA=+FB1
SET DIC="^FB583("
SET DR="0;1"
WRITE @IOF
DO EN^DIQ
+1 QUIT
EV ;expand view
+1 WRITE @IOF
NEW FBZ
SET FBZ=$PIECE(FBX,U,9)
+2 IF $PIECE(FBX,U)="OPT"
SET DIC="^FBAAC("_DFN_",1,"_FBV_",1,"_$PIECE(FBZ,",",3)_",1,"
SET DA(3)=DFN
SET DA(2)=FBV
SET DA(1)=$PIECE(FBZ,",",3)
SET DA=$PIECE(FBZ,",",4)
SET DR=""
+3 IF $PIECE(FBX,U)="PHAR"
SET DIC="^FBAA(162.1,"_+FBZ_",""RX"","
SET DA(1)=+FBZ
SET DA=$PIECE(FBZ,",",2)
SET DR=""
+4 IF $PIECE(FBX,U)["C"
SET DIC="^FBAAI("
SET DA=FBZ
SET DR=""
+5 WRITE @IOF
DO EN^DIQ
+6 KILL DIC,DA,DR
+7 QUIT
CP ;change patient
+1 DO CLEAR^VALM1
+2 NEW FBCP
SET VALMBCK="R"
+3 SET DIR(0)="P^161:EMZ"
SET DIR("A")="Payments for veteran"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
QUIT
+4 SET DFN=+Y
SET FBCP=1
DO HDR^FBPHON
DO START^FBPHON
+5 QUIT
CV ;change vendor
+1 DO CLEAR^VALM1
+2 NEW FBCP
SET VALMBCK="R"
+3 SET DIR(0)="P^161.2:EMZ"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+4 SET FBV=+Y
SET FBCP=1
DO HDR^FBPHON
DO START^FBPHON
+5 QUIT
DC ;display check
+1 WRITE @IOF
SET FBCN=$PIECE(FBX,U,11)
IF FBCN']""
WRITE !,*7,"No check found for this line item."
QUIT
+2 DO START^FBCKDIS
+3 QUIT
CD ;display CPT/MOD description
+1 WRITE @IOF
+2 NEW FBCPT,FBJ,FBMOD,FBMODX
+3 if $PIECE(FBX,U)'="OPT"!($PIECE(FBX,U,3)']"")
QUIT
+4 SET FBCPT=$PIECE(FBX,U,3)
WRITE !,"Line item #",FBI,!?5,"CPT: ",$PIECE(FBCPT,"-"),?18,$PIECE($$CPT^ICPTCOD($PIECE(FBCPT,"-"),$SELECT(+$PIECE(FBX,U,2)>0:+$PIECE(FBX,U,2),1:""),1),U,3)
+5 IF FBCPT["-"
FOR FBJ=1:1
SET FBMOD=$PIECE($PIECE(FBCPT,"-",2),",",FBJ)
if FBMOD=""
QUIT
Begin DoDot:1
+6 WRITE !?5,"MOD: ",FBMOD
+7 SET FBMODX=$$MOD^ICPTMOD(FBMOD,"E",$PIECE(FBX,U,2))
+8 ; if modifier data not obtained then try another API to resolve it
+9 ; since there can be duplicate modifiers with same external value
+10 IF $PIECE(FBMODX,U)'>0
Begin DoDot:2
+11 NEW FBY
+12 SET FBY=$$MODP^ICPTMOD($PIECE(FBCPT,"-"),FBMOD,"E",$PIECE(FBX,U,2))
+13 IF $PIECE(FBY,U)>0
SET FBMODX=$$MOD^ICPTMOD($PIECE(FBY,U),"I",$PIECE(FBX,U,2))
End DoDot:2
+14 WRITE ?18,$SELECT($PIECE(FBMODX,U)>0:$PIECE(FBMODX,U,3),1:"")
End DoDot:1
+15 QUIT
ERR ;
+1 WRITE !,"No ",$SELECT(FBPR["B":"batch",1:"invoice")," number on file for this entry"
QUIT
