FBAAPP ;AISC/GRR - ENTER FEE PHARMACY DETERMINATION ;5/10/2005
;;3.5;FEE BASIS;**61,80,91,123,180**;JAN 30, 1995;Build 2
;;Per VA Directive 6402, this routine should not be modified.
N FBADJ,FBRRMK
D HOME^%ZIS S FBAAOUT=0 K ^TMP($J,"FBWP") D DT^DICRW
I '$D(^FBAA(162.1,"AC",1)) W !!,"There are no Fee Basis prescriptions Pending Pharmacy review" G END
D WAIT^DICD S (CNT,L,M)=0 F S L=$O(^FBAA(162.1,"AC",1,L)) Q:L'>0 I $D(^FBAA(162.1,L,"RX","AC",1)) F S M=$O(^FBAA(162.1,L,"RX","AC",1,M)) Q:M'>0 S CNT=CNT+1
W !!,*7,"There are ",CNT," Fee Prescription(s) Pending Pharmacy review"
ASKRV Q:CNT'>0 W ! S DIR("A")="Want to review some now",DIR("B")="Yes",DIR(0)="Y" D ^DIR K DIR G END:$D(DIRUT)!('Y)
RDIN W ! S FBAAOUT=0,DIC="^FBAA(162.1,",DIC(0)="AEQ",DIC("S")="S ZZ=^(0) I $P(ZZ,U,5)=1&($D(^FBAA(162.1,+ZZ,""RX"",""AC"",1))) K ZZ" D ^DIC K DIC G END:X=""!(X="^"),HELPI^FBAAPP0:X["?" S FBJ=+Y
L +^FBAA(162.1,"AC",1,FBJ):1 G:'$T ALRDY^FBAAPP0 I $D(^FBAA(162.1,FBJ,"RX","AC",1)) S FBK=0 F S FBK=$O(^FBAA(162.1,FBJ,"RX","AC",1,FBK)) Q:FBK'>0!(FBAAOUT) I $D(^FBAA(162.1,FBJ,"RX",FBK,0)) S FBY(0)=^(0) D GOT,CHK:$D(^FBAA(162.1,"AC",1))
L -^FBAA(162.1,"AC",1,FBJ) I '$D(^FBAA(162.1,"AC",1)) W !,*7,"No more prescriptions pending review!" G END
G RDIN
END K DFN,FBJ,FBK,Y,X,FBAAOUT,L,CNT,STAT,DA,DAT,DIC,FBAAGP,FBAAPR,FBDX,FDT,SSN,HY,I,T,VIFN,Z,ZZ,VAL,FBAASC,M,W,FBY,FBASSOC,FB583,FB7078,FBPROG,FBTYPE,FBDMRA,FBAUT,^TMP($J,"FBWP")
K FBNO1,FBNO2,FBDA,FBDRUG,PI,DIRUT,DTOUT,DUOUT
Q
GOT S STAT=2,DFN=$P(FBY(0),"^",5) Q:'$D(^DPT(+DFN,0))
S FBPROG=$P($G(^FBAA(162.1,FBJ,"RX",FBK,2)),"^",7),FBPROG=$S(FBPROG:"I FBI="_FBPROG,1:"")
S HY=Y,PI="" D ^FBAADEM
D FBPH^FBAAUTL2 W ! F X=1:1:IOM-1 W "-"
I $Y+5>IOSL,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR Q:'Y W @IOF
S Y=HY,VIFN=$P(^FBAA(162.1,FBJ,0),"^",4)
W !!,"Vendor: ",$P($G(^FBAAV(+VIFN,0)),"^"),!
I $P(FBY(0),"^",20)="R" W *7,!?20,">> PATIENT REIMBURSEMENT <<",!
S FDT=$P(FBY(0),"^",3) W !,"Prescription #: ",$P(FBY(0),"^")," Drug: ",$P(FBY(0),"^",2),!!,"Fill Date: ",$E(FDT,4,5),"/",$E(FDT,6,7),"/",$E(FDT,2,3)," Strength: ",$P(FBY(0),"^",12)
W " Qty: ",$P(FBY(0),"^",13)
DIR ; DISPLAY FOR PHARMACY EDIT
S (FBAAGP,FBAAPR,FBDA,FBDRUG,FBNO1,FBNO2)="" K FBADJ,FBRRMK
I '$D(IOM) D HOME^%ZIS
DIR1 S DIR("A")="Is Prescription for an Authorized Condition"
S DIR("B")=$S(FBNO1'="":FBNO1,1:"Yes")
S DIR(0)="Y",DIR("?")="A 'No' answer will deny payment."
D ^DIR K DIR Q:$D(DIRUT)
I Y S FBNO1="Yes"
I 'Y S FBNO1="No" D D NO1^FBAAPP0 Q:'$D(FBADJ) G REVIEW
. S (FBAAGP,FBDA,FBDRUG,FBNO2)=""
;
S DIR("A")="Was a Generic Drug issued to patient"
S DIR("B")=$S(FBAAGP'="":FBAAGP,1:"Yes")
S DIR(0)="Y"
S DIR("?")="A 'No' answer alerts FEE to pay the generic equivalent, if one exists."
D ^DIR K DIR Q:$D(DIRUT)
S FBAAGP=$S(Y:"Yes",1:"No")
;
S DIR("A")="Enter VA Generic Drug equivalent"
I FBDRUG'="" S DIR("B")=FBDRUG
S DIR("?")="Match the drug entered by FEE to an entry in the VA Drug file."
S DIR(0)="Pr^50:EM"
D ^DIR K DIR Q:$D(DIRUT)!('Y)
S FBDA=+Y,FBDRUG=$P(Y,"^",2)
;
; FB*3.5*123 - Edit pharmacy IPAC data for Federal Vendors
; Added line to skip the asking of emergency medication
; if the vendor requires an IPAC Agreement
I $$IPACREQD^FBAAMP(VIFN) S FBNO2="N/A (IPAC Payment)" G REVIEW
;
S DIR("A")="Is this an emergency medication"
S DIR("B")=$S(FBNO2'="":FBNO2,1:"Yes")
S DIR("?")="A 'No' answer will DENY payment."
S DIR(0)="Y"
D ^DIR K DIR Q:$D(DIRUT)
I Y S FBNO2="Yes" K FBADJ,FBRRMK
I 'Y S FBNO2="No" D NO1^FBAAPP0 Q:'$D(FBADJ)
;
REVIEW W !
S DIR("A")="Optional Pharmacy Remarks "
S:FBAAPR]"" DIR("B")=FBAAPR
S DIR(0)="162.11,22"
K DA
D ^DIR K DIR Q:$D(DUOUT)!($D(DTOUT))
S FBAAPR=Y
;
W ! F I=1:1:IOM-2 W "-"
W !!?22,">>> PRESCRIPTION REVIEW <<<",!
W !,"Rx for Authorized condition: ",FBNO1
W ?36,"Emergency Medication: ",FBNO2
W !,"Generic Drug Issued: ",FBAAGP
W ?36,"Generic Drug Name: ",$E(FBDRUG,1,25)
I $D(FBADJ) D
. N FBI,FBADJI
. W !!,"Current list of Adjustments: "
. I '$O(FBADJ(0)) W "none"
. S FBI=0 F S FBI=$O(FBADJ(FBI)) Q:'FBI D
. . W ?30,"Code: "
. . W:$P(FBADJ(FBI),U)]"" $P($G(^FB(161.91,$P(FBADJ(FBI),U),0)),U)
. . W ?44,"Group: "
. . W:$P(FBADJ(FBI),U,2)]"" $P($G(^FB(161.92,$P(FBADJ(FBI),U,2),0)),U)
. . W ?56,"Amount: "
. . W "$",$FN($P(FBADJ(FBI),U,3),"",2),!
. W !!,"Current list of Remittance Remarks: "
. I '$O(FBRRMK(0)) W "none"
. S FBADJI=0 F S FBADJI=$O(FBRRMK(FBADJI)) Q:FBADJI="" D ;Include Adjustment Reason, FB*3.5*180
. . S FBI=0 F S FBI=$O(FBRRMK(FBADJI,FBI)) Q:'FBI D ;Include Adjustment Reason, FB*3.5*180
. . . W:$P(FBRRMK(FBADJI,FBI),U)]"" $P($G(^FB(161.93,$P(FBRRMK(FBADJI,FBI),U),0)),U),", " ;Include Adjustment Reason, FB*3.5*180
W !!,"Optional Pharmacy Remarks: ",FBAAPR
;
W !
S DIR("A")="Want to edit prior to release"
S DIR(0)="Y",DIR("B")="No"
D ^DIR K DIR Q:$D(DIRUT) G DIR1:Y
;
I $D(FBADJ) G GOON^FBAAPP0
S $P(FBY(0),"^",10)=FBDA
S $P(FBY(0),"^",11)=1
S $P(FBY(0),"^",14)=DUZ
S $P(FBY(0),"^",15)=DT
S $P(FBY(0),"^",9)=2
G RSET^FBAAPP0
;
CHK S FBAAOUT=0 W ! S DIR("A")="Want to review another Prescription",DIR("B")="Yes",DIR(0)="Y" D ^DIR K DIR S:'Y FBAAOUT=1 K ^TMP($J,"FBWP"),FBDRUG
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAPP 5340 printed Oct 16, 2024@17:57:03 Page 2
FBAAPP ;AISC/GRR - ENTER FEE PHARMACY DETERMINATION ;5/10/2005
+1 ;;3.5;FEE BASIS;**61,80,91,123,180**;JAN 30, 1995;Build 2
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 NEW FBADJ,FBRRMK
+4 DO HOME^%ZIS
SET FBAAOUT=0
KILL ^TMP($JOB,"FBWP")
DO DT^DICRW
+5 IF '$DATA(^FBAA(162.1,"AC",1))
WRITE !!,"There are no Fee Basis prescriptions Pending Pharmacy review"
GOTO END
+6 DO WAIT^DICD
SET (CNT,L,M)=0
FOR
SET L=$ORDER(^FBAA(162.1,"AC",1,L))
if L'>0
QUIT
IF $DATA(^FBAA(162.1,L,"RX","AC",1))
FOR
SET M=$ORDER(^FBAA(162.1,L,"RX","AC",1,M))
if M'>0
QUIT
SET CNT=CNT+1
+7 WRITE !!,*7,"There are ",CNT," Fee Prescription(s) Pending Pharmacy review"
ASKRV if CNT'>0
QUIT
WRITE !
SET DIR("A")="Want to review some now"
SET DIR("B")="Yes"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
if $DATA(DIRUT)!('Y)
GOTO END
RDIN WRITE !
SET FBAAOUT=0
SET DIC="^FBAA(162.1,"
SET DIC(0)="AEQ"
SET DIC("S")="S ZZ=^(0) I $P(ZZ,U,5)=1&($D(^FBAA(162.1,+ZZ,""RX"",""AC"",1))) K ZZ"
DO ^DIC
KILL DIC
if X=""!(X="^")
GOTO END
if X["?"
GOTO HELPI^FBAAPP0
SET FBJ=+Y
+1 LOCK +^FBAA(162.1,"AC",1,FBJ):1
if '$TEST
GOTO ALRDY^FBAAPP0
IF $DATA(^FBAA(162.1,FBJ,"RX","AC",1))
SET FBK=0
FOR
SET FBK=$ORDER(^FBAA(162.1,FBJ,"RX","AC",1,FBK))
if FBK'>0!(FBAAOUT)
QUIT
IF $DATA(^FBAA(162.1,FBJ,"RX",FBK,0))
SET FBY(0)=^(0)
DO GOT
if $DATA(^FBAA(162.1,"AC",1))
DO CHK
+2 LOCK -^FBAA(162.1,"AC",1,FBJ)
IF '$DATA(^FBAA(162.1,"AC",1))
WRITE !,*7,"No more prescriptions pending review!"
GOTO END
+3 GOTO RDIN
END KILL DFN,FBJ,FBK,Y,X,FBAAOUT,L,CNT,STAT,DA,DAT,DIC,FBAAGP,FBAAPR,FBDX,FDT,SSN,HY,I,T,VIFN,Z,ZZ,VAL,FBAASC,M,W,FBY,FBASSOC,FB583,FB7078,FBPROG,FBTYPE,FBDMRA,FBAUT,^TMP($JOB,"FBWP")
+1 KILL FBNO1,FBNO2,FBDA,FBDRUG,PI,DIRUT,DTOUT,DUOUT
+2 QUIT
GOT SET STAT=2
SET DFN=$PIECE(FBY(0),"^",5)
if '$DATA(^DPT(+DFN,0))
QUIT
+1 SET FBPROG=$PIECE($GET(^FBAA(162.1,FBJ,"RX",FBK,2)),"^",7)
SET FBPROG=$SELECT(FBPROG:"I FBI="_FBPROG,1:"")
+2 SET HY=Y
SET PI=""
DO ^FBAADEM
+3 DO FBPH^FBAAUTL2
WRITE !
FOR X=1:1:IOM-1
WRITE "-"
+4 IF $Y+5>IOSL
IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
DO ^DIR
KILL DIR
if 'Y
QUIT
WRITE @IOF
+5 SET Y=HY
SET VIFN=$PIECE(^FBAA(162.1,FBJ,0),"^",4)
+6 WRITE !!,"Vendor: ",$PIECE($GET(^FBAAV(+VIFN,0)),"^"),!
+7 IF $PIECE(FBY(0),"^",20)="R"
WRITE *7,!?20,">> PATIENT REIMBURSEMENT <<",!
+8 SET FDT=$PIECE(FBY(0),"^",3)
WRITE !,"Prescription #: ",$PIECE(FBY(0),"^")," Drug: ",$PIECE(FBY(0),"^",2),!!,"Fill Date: ",$EXTRACT(FDT,4,5),"/",$EXTRACT(FDT,6,7),"/",$EXTRACT(FDT,2,3)," Strength: ",$PIECE(FBY(0),"^",12)
+9 WRITE " Qty: ",$PIECE(FBY(0),"^",13)
DIR ; DISPLAY FOR PHARMACY EDIT
+1 SET (FBAAGP,FBAAPR,FBDA,FBDRUG,FBNO1,FBNO2)=""
KILL FBADJ,FBRRMK
+2 IF '$DATA(IOM)
DO HOME^%ZIS
DIR1 SET DIR("A")="Is Prescription for an Authorized Condition"
+1 SET DIR("B")=$SELECT(FBNO1'="":FBNO1,1:"Yes")
+2 SET DIR(0)="Y"
SET DIR("?")="A 'No' answer will deny payment."
+3 DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+4 IF Y
SET FBNO1="Yes"
+5 IF 'Y
SET FBNO1="No"
Begin DoDot:1
+6 SET (FBAAGP,FBDA,FBDRUG,FBNO2)=""
End DoDot:1
DO NO1^FBAAPP0
if '$DATA(FBADJ)
QUIT
GOTO REVIEW
+7 ;
+8 SET DIR("A")="Was a Generic Drug issued to patient"
+9 SET DIR("B")=$SELECT(FBAAGP'="":FBAAGP,1:"Yes")
+10 SET DIR(0)="Y"
+11 SET DIR("?")="A 'No' answer alerts FEE to pay the generic equivalent, if one exists."
+12 DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+13 SET FBAAGP=$SELECT(Y:"Yes",1:"No")
+14 ;
+15 SET DIR("A")="Enter VA Generic Drug equivalent"
+16 IF FBDRUG'=""
SET DIR("B")=FBDRUG
+17 SET DIR("?")="Match the drug entered by FEE to an entry in the VA Drug file."
+18 SET DIR(0)="Pr^50:EM"
+19 DO ^DIR
KILL DIR
if $DATA(DIRUT)!('Y)
QUIT
+20 SET FBDA=+Y
SET FBDRUG=$PIECE(Y,"^",2)
+21 ;
+22 ; FB*3.5*123 - Edit pharmacy IPAC data for Federal Vendors
+23 ; Added line to skip the asking of emergency medication
+24 ; if the vendor requires an IPAC Agreement
+25 IF $$IPACREQD^FBAAMP(VIFN)
SET FBNO2="N/A (IPAC Payment)"
GOTO REVIEW
+26 ;
+27 SET DIR("A")="Is this an emergency medication"
+28 SET DIR("B")=$SELECT(FBNO2'="":FBNO2,1:"Yes")
+29 SET DIR("?")="A 'No' answer will DENY payment."
+30 SET DIR(0)="Y"
+31 DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+32 IF Y
SET FBNO2="Yes"
KILL FBADJ,FBRRMK
+33 IF 'Y
SET FBNO2="No"
DO NO1^FBAAPP0
if '$DATA(FBADJ)
QUIT
+34 ;
REVIEW WRITE !
+1 SET DIR("A")="Optional Pharmacy Remarks "
+2 if FBAAPR]""
SET DIR("B")=FBAAPR
+3 SET DIR(0)="162.11,22"
+4 KILL DA
+5 DO ^DIR
KILL DIR
if $DATA(DUOUT)!($DATA(DTOUT))
QUIT
+6 SET FBAAPR=Y
+7 ;
+8 WRITE !
FOR I=1:1:IOM-2
WRITE "-"
+9 WRITE !!?22,">>> PRESCRIPTION REVIEW <<<",!
+10 WRITE !,"Rx for Authorized condition: ",FBNO1
+11 WRITE ?36,"Emergency Medication: ",FBNO2
+12 WRITE !,"Generic Drug Issued: ",FBAAGP
+13 WRITE ?36,"Generic Drug Name: ",$EXTRACT(FBDRUG,1,25)
+14 IF $DATA(FBADJ)
Begin DoDot:1
+15 NEW FBI,FBADJI
+16 WRITE !!,"Current list of Adjustments: "
+17 IF '$ORDER(FBADJ(0))
WRITE "none"
+18 SET FBI=0
FOR
SET FBI=$ORDER(FBADJ(FBI))
if 'FBI
QUIT
Begin DoDot:2
+19 WRITE ?30,"Code: "
+20 if $PIECE(FBADJ(FBI),U)]""
WRITE $PIECE($GET(^FB(161.91,$PIECE(FBADJ(FBI),U),0)),U)
+21 WRITE ?44,"Group: "
+22 if $PIECE(FBADJ(FBI),U,2)]""
WRITE $PIECE($GET(^FB(161.92,$PIECE(FBADJ(FBI),U,2),0)),U)
+23 WRITE ?56,"Amount: "
+24 WRITE "$",$FNUMBER($PIECE(FBADJ(FBI),U,3),"",2),!
End DoDot:2
+25 WRITE !!,"Current list of Remittance Remarks: "
+26 IF '$ORDER(FBRRMK(0))
WRITE "none"
+27 ;Include Adjustment Reason, FB*3.5*180
SET FBADJI=0
FOR
SET FBADJI=$ORDER(FBRRMK(FBADJI))
if FBADJI=""
QUIT
Begin DoDot:2
+28 ;Include Adjustment Reason, FB*3.5*180
SET FBI=0
FOR
SET FBI=$ORDER(FBRRMK(FBADJI,FBI))
if 'FBI
QUIT
Begin DoDot:3
+29 ;Include Adjustment Reason, FB*3.5*180
if $PIECE(FBRRMK(FBADJI,FBI),U)]""
WRITE $PIECE($GET(^FB(161.93,$PIECE(FBRRMK(FBADJI,FBI),U),0)),U),", "
End DoDot:3
End DoDot:2
End DoDot:1
+30 WRITE !!,"Optional Pharmacy Remarks: ",FBAAPR
+31 ;
+32 WRITE !
+33 SET DIR("A")="Want to edit prior to release"
+34 SET DIR(0)="Y"
SET DIR("B")="No"
+35 DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
if Y
GOTO DIR1
+36 ;
+37 IF $DATA(FBADJ)
GOTO GOON^FBAAPP0
+38 SET $PIECE(FBY(0),"^",10)=FBDA
+39 SET $PIECE(FBY(0),"^",11)=1
+40 SET $PIECE(FBY(0),"^",14)=DUZ
+41 SET $PIECE(FBY(0),"^",15)=DT
+42 SET $PIECE(FBY(0),"^",9)=2
+43 GOTO RSET^FBAAPP0
+44 ;
CHK SET FBAAOUT=0
WRITE !
SET DIR("A")="Want to review another Prescription"
SET DIR("B")="Yes"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
if 'Y
SET FBAAOUT=1
KILL ^TMP($JOB,"FBWP"),FBDRUG
+1 QUIT
