FBPRICE.m

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 ---FBPRICE   4167     printed  Mar 13, 2025@21:04:40                                                                                                                                                                                                     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