FBPRICE ;AISC/DMK - GENERIC PRICER INTERFACE ;6/25/1992
;;3.5;FEE BASIS;**108**;JAN 30, 1995;Build 115
;;Per VHA Directive 2004-038, this routine should not be modified.
;build a transaction to send to the Austin Pricer system
;this data will NOT be stored anywhere. It serves only
;as a tool to determine reimbursement rates.
S PAD=" "
S FB("ERROR")="" D STATION^FBAAUTL G END:FB("ERROR") K FB("ERROR")
S FBAASN=FBAASN_$E(PAD,$L(FBAASN)+1,6)
PAT ;ask patient name [this is not a look-up on file 2]
W ! S DIR("A")="Want to select patient from DHCP Patient File",DIR(0)="Y",DIR("B")="Yes" D ^DIR K DIR Q:$D(DIRUT) I Y D G END:'$D(FBSSN),VEND
.W ! S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC K DIC Q:X="^"!(X="")!(Y<0)
.D PAT^FBAAUTL2 S FBLNAM=$E(FBFLNAM,1,12),FBSSN=$E(FBSSN,10)_$E(FBSSN,1,9)_" "
;
W ! S DIR("A")="Enter LAST NAME",DIR(0)="F^3:20^K:X'?.A X",DIR("?")="Enter last name of patient. Answer must be 3 to 20 characters in length" D ^DIR K DIR Q:$D(DIRUT) S FBLNAM=$E(Y,1,12)_$E(PAD,$L(Y)+1,12)
;
S DIR("A")="Enter FIRST INITIAL",DIR(0)="F^1:1^K:X'?1A X" D ^DIR K DIR Q:$D(DIRUT) S FBFI=Y
;
S DIR("A")="Enter MIDDLE INITIAL",DIR(0)="FO^1:1^K:X'?1A X" D ^DIR K DIR Q:$D(DUOUT)!($D(DTOUT)) S FBMI=$S(Y]"":Y,1:" ")
;
S FBNAME=FBLNAM_FBFI_FBMI
SSN ;ASK SSN
S DIR("A")="Patient ID Number",DIR("?")="Answer must contain 9 numbers. Pseudo-SSN not allowed",DIR(0)="F^9:9^K:X'?9N X" D ^DIR K DIR Q:$D(DIRUT) S FBSSN=" "_Y_" "
;
DOB S DIR(0)="2,.03",DIR("A")="Date of Birth" D ^DIR K DIR Q:$D(DIRUT) S FBDOB=$E(Y,4,7)_($E(Y,1,3)+1700)
;
SEX ;ask sex of patient
S DIR("A")="Sex of Patient",DIR(0)="2,.02" D ^DIR K DIR G END:$D(DIRUT) S FBSEX=Y
VEND ;ask vendor
S DIR("A")="Want to select a vendor from DHCP Fee Basis Vendor file",DIR(0)="Y",DIR("B")="Yes" D ^DIR K DIR Q:$D(DIRUT) I Y D G END:+$G(FBOUT),VEND:'$D(FBVID),CONT
.W ! S DIC="^FBAAV(",DIC(0)="AEQMZ" D ^DIC K DIC S:X=""!(X="^") FBOUT=1 Q:Y<0 S FBSTABR=+$P(Y(0),"^",5),FBSTABR=$P($G(^DIC(5,FBSTABR,0)),"^",2),FBSTABR=$S('$L(FBSTABR):" ",1:FBSTABR)
.S FBVID=$P(Y(0),"^",17) I FBVID="" K FBVID W !!,*7,"Vendor must have a Medicare ID number to send to the pricer.",! Q
W ! S DIR("A")="Select Vendor Name",DIR(0)="F^2:46" D ^DIR K DIR G END:$D(DIRUT) S FBVEN=Y
S DIR("A")="Enter Medicare ID Number",DIR(0)="161.2,22" D ^DIR K DIR G END:$D(DIRUT) S FBVID=Y
S DIR("A")="State of Vendor",DIR(0)="P^5:EQMZ" D ^DIR K DIR G END:$D(DIRUT) S FBSTABR=$S($L($P(Y(0),"^",2)):$P(Y(0),"^",2),1:" ")
;
CONT ;
I $L(FBSTABR)>2 D G VEND
. W !,"Error: Vendor state abbreviation (",FBSTABR,") exceeds 2 characters.",!
;ask admission and treatment type information
W ! S DIR("A")="Admission Date: ",DIR(0)="DA^::EX",DIR("?")="^D HELP^%DTC" D ^DIR K DIR G END:$D(DIRUT) S FBFDT=Y
S DIR("A")="Discharge Date: ",DIR(0)="DA^"_FBFDT_"::EX",DIR("?")="^D HELP^%DTC" D ^DIR K DIR G END:$D(DIRUT) S FBTDT=Y
S X1=FBTDT,X2=FBFDT D ^%DTC S FBLOS=$S(X<1:1,1:X),FBLOS=$E("000",$L(FBLOS)+1,3)_FBLOS
I $L(FBLOS)>3 D G CONT
. W !,"Error: Length of Stay (",FBLOS,") exceeds 999.",!
S FBCSVDT=FBTDT ; code set version date
F I="FBFDT","FBTDT" S @I=$E(@I,4,7)_($E(@I,1,3)+1700)
;
S DIR(0)="P^43.4:EQM",DIR("A")="Admitting Authority" D ^DIR K DIR G END:$D(DIRUT) S Z=+Y
S FBAUTH=$$AUTH^FBAAV6(Z) K Z
;
S DIR("A")="Disposition Code",DIR(0)="P^162.6:QEMZ" D ^DIR K DIR G END:$D(DIRUT) S FBDISP=$E("00",$L($P(Y(0),"^",2))+1,2)_$P(Y(0),"^",2)
;
S DIR("A")="Is this a Patient Reimbursement",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR G END:$D(DIRUT) S FBPAYT=$S(Y:"P",1:"V")
;
S DIR("A")="Payment by Medicare or Other Federal Agency",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR G END:$D(DIRUT) S FBMED=$S(Y:"Y",1:"N")
;
D ^FBPRICE1
;
END K FBSTAN,FBAUTH,FBBILL,FBCLAIM,FBDISP,FBDOB,FBDX,FBFDT,FBFI,FBFLNAM,FBLNAM,FBLOS,FBMED,FBMI,FBNAME,FBOBL,FBPAYT,FBPRC,FBSEX,FBSITE,FB,FBAASN,FBFEE,FBI,FBJ,FBLN,FBNVP,FBOKTX,FBSN,FBXMZ
K FBSSN,FBSTR,FBSTABR,FBTDT,FBVID,PAD,POP,PRC,DUOUT,DTOUT,DIRUT,DIR,FBPART1,FBVEN,FBSDI,VAT,VATERR,VATNAME,Y,FBPOP,FBVAR,FBXMFEE,FBXMNVP,FBPOP
K FBADMTDX,FBCSVDT,FBOUT,FBPOA,FBRESUB,X,X1,X2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBPRICE 4167 printed Nov 22, 2024@17:09:56 Page 2
FBPRICE ;AISC/DMK - GENERIC PRICER INTERFACE ;6/25/1992
+1 ;;3.5;FEE BASIS;**108**;JAN 30, 1995;Build 115
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;build a transaction to send to the Austin Pricer system
+4 ;this data will NOT be stored anywhere. It serves only
+5 ;as a tool to determine reimbursement rates.
+6 SET PAD=" "
+7 SET FB("ERROR")=""
DO STATION^FBAAUTL
if FB("ERROR")
GOTO END
KILL FB("ERROR")
+8 SET FBAASN=FBAASN_$EXTRACT(PAD,$LENGTH(FBAASN)+1,6)
PAT ;ask patient name [this is not a look-up on file 2]
+1 WRITE !
SET DIR("A")="Want to select patient from DHCP Patient File"
SET DIR(0)="Y"
SET DIR("B")="Yes"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
IF Y
Begin DoDot:1
+2 WRITE !
SET DIC="^DPT("
SET DIC(0)="AEQMZ"
DO ^DIC
KILL DIC
if X="^"!(X="")!(Y<0)
QUIT
+3 DO PAT^FBAAUTL2
SET FBLNAM=$EXTRACT(FBFLNAM,1,12)
SET FBSSN=$EXTRACT(FBSSN,10)_$EXTRACT(FBSSN,1,9)_" "
End DoDot:1
if '$DATA(FBSSN)
GOTO END
GOTO VEND
+4 ;
+5 WRITE !
SET DIR("A")="Enter LAST NAME"
SET DIR(0)="F^3:20^K:X'?.A X"
SET DIR("?")="Enter last name of patient. Answer must be 3 to 20 characters in length"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
SET FBLNAM=$EXTRACT(Y,1,12)_$EXTRACT(PAD,$LENGTH(Y)+1,12)
+6 ;
+7 SET DIR("A")="Enter FIRST INITIAL"
SET DIR(0)="F^1:1^K:X'?1A X"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
SET FBFI=Y
+8 ;
+9 SET DIR("A")="Enter MIDDLE INITIAL"
SET DIR(0)="FO^1:1^K:X'?1A X"
DO ^DIR
KILL DIR
if $DATA(DUOUT)!($DATA(DTOUT))
QUIT
SET FBMI=$SELECT(Y]"":Y,1:" ")
+10 ;
+11 SET FBNAME=FBLNAM_FBFI_FBMI
SSN ;ASK SSN
+1 SET DIR("A")="Patient ID Number"
SET DIR("?")="Answer must contain 9 numbers. Pseudo-SSN not allowed"
SET DIR(0)="F^9:9^K:X'?9N X"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
SET FBSSN=" "_Y_" "
+2 ;
DOB SET DIR(0)="2,.03"
SET DIR("A")="Date of Birth"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
SET FBDOB=$EXTRACT(Y,4,7)_($EXTRACT(Y,1,3)+1700)
+1 ;
SEX ;ask sex of patient
+1 SET DIR("A")="Sex of Patient"
SET DIR(0)="2,.02"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
SET FBSEX=Y
VEND ;ask vendor
+1 SET DIR("A")="Want to select a vendor from DHCP Fee Basis Vendor file"
SET DIR(0)="Y"
SET DIR("B")="Yes"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
IF Y
Begin DoDot:1
+2 WRITE !
SET DIC="^FBAAV("
SET DIC(0)="AEQMZ"
DO ^DIC
KILL DIC
if X=""!(X="^")
SET FBOUT=1
if Y<0
QUIT
SET FBSTABR=+$PIECE(Y(0),"^",5)
SET FBSTABR=$PIECE($GET(^DIC(5,FBSTABR,0)),"^",2)
SET FBSTABR=$SELECT('$LENGTH(FBSTABR):" ",1:FBSTABR)
+3 SET FBVID=$PIECE(Y(0),"^",17)
IF FBVID=""
KILL FBVID
WRITE !!,*7,"Vendor must have a Medicare ID number to send to the pricer.",!
QUIT
End DoDot:1
if +$GET(FBOUT)
GOTO END
if '$DATA(FBVID)
GOTO VEND
GOTO CONT
+4 WRITE !
SET DIR("A")="Select Vendor Name"
SET DIR(0)="F^2:46"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
SET FBVEN=Y
+5 SET DIR("A")="Enter Medicare ID Number"
SET DIR(0)="161.2,22"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
SET FBVID=Y
+6 SET DIR("A")="State of Vendor"
SET DIR(0)="P^5:EQMZ"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
SET FBSTABR=$SELECT($LENGTH($PIECE(Y(0),"^",2)):$PIECE(Y(0),"^",2),1:" ")
+7 ;
CONT ;
+1 IF $LENGTH(FBSTABR)>2
Begin DoDot:1
+2 WRITE !,"Error: Vendor state abbreviation (",FBSTABR,") exceeds 2 characters.",!
End DoDot:1
GOTO VEND
+3 ;ask admission and treatment type information
+4 WRITE !
SET DIR("A")="Admission Date: "
SET DIR(0)="DA^::EX"
SET DIR("?")="^D HELP^%DTC"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
SET FBFDT=Y
+5 SET DIR("A")="Discharge Date: "
SET DIR(0)="DA^"_FBFDT_"::EX"
SET DIR("?")="^D HELP^%DTC"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
SET FBTDT=Y
+6 SET X1=FBTDT
SET X2=FBFDT
DO ^%DTC
SET FBLOS=$SELECT(X<1:1,1:X)
SET FBLOS=$EXTRACT("000",$LENGTH(FBLOS)+1,3)_FBLOS
+7 IF $LENGTH(FBLOS)>3
Begin DoDot:1
+8 WRITE !,"Error: Length of Stay (",FBLOS,") exceeds 999.",!
End DoDot:1
GOTO CONT
+9 ; code set version date
SET FBCSVDT=FBTDT
+10 FOR I="FBFDT","FBTDT"
SET @I=$EXTRACT(@I,4,7)_($EXTRACT(@I,1,3)+1700)
+11 ;
+12 SET DIR(0)="P^43.4:EQM"
SET DIR("A")="Admitting Authority"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
SET Z=+Y
+13 SET FBAUTH=$$AUTH^FBAAV6(Z)
KILL Z
+14 ;
+15 SET DIR("A")="Disposition Code"
SET DIR(0)="P^162.6:QEMZ"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
SET FBDISP=$EXTRACT("00",$LENGTH($PIECE(Y(0),"^",2))+1,2)_$PIECE(Y(0),"^",2)
+16 ;
+17 SET DIR("A")="Is this a Patient Reimbursement"
SET DIR(0)="Y"
SET DIR("B")="No"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
SET FBPAYT=$SELECT(Y:"P",1:"V")
+18 ;
+19 SET DIR("A")="Payment by Medicare or Other Federal Agency"
SET DIR(0)="Y"
SET DIR("B")="No"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
SET FBMED=$SELECT(Y:"Y",1:"N")
+20 ;
+21 DO ^FBPRICE1
+22 ;
END KILL FBSTAN,FBAUTH,FBBILL,FBCLAIM,FBDISP,FBDOB,FBDX,FBFDT,FBFI,FBFLNAM,FBLNAM,FBLOS,FBMED,FBMI,FBNAME,FBOBL,FBPAYT,FBPRC,FBSEX,FBSITE,FB,FBAASN,FBFEE,FBI,FBJ,FBLN,FBNVP,FBOKTX,FBSN,FBXMZ
+1 KILL FBSSN,FBSTR,FBSTABR,FBTDT,FBVID,PAD,POP,PRC,DUOUT,DTOUT,DIRUT,DIR,FBPART1,FBVEN,FBSDI,VAT,VATERR,VATNAME,Y,FBPOP,FBVAR,FBXMFEE,FBXMNVP,FBPOP
+2 KILL FBADMTDX,FBCSVDT,FBOUT,FBPOA,FBRESUB,X,X1,X2
+3 QUIT
