- FBAAPIE1 ;AISC/GRR - ENTER FEE PHARMACY INVOICE ;6/5/2009
- ;;3.5;FEE BASIS;**68,108,124**;JAN 30, 1995;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- LISTLI I '$D(^FBAA(162.1,DA,"RX","AB")) W !,"No prescriptions currently in this invoice.",! Q
- D HOME^%ZIS S FSW=1
- S FBAAOUT=0 F J=0:0 S J=$O(^FBAA(162.1,DA,"RX",J)) Q:J'>0 I $D(^FBAA(162.1,DA,"RX",J,0)) S Y(0)=^(0) D GETIT Q:FBAAOUT
- Q
- Q K DIE,DIC,STAT,IN,VIN,DA,LCNT,AC,TAC,DATEF,DR,X,%DT,INVDATE,CNT,DAT,FBAABDT,FBAAEDT,FBAAIN,FBAAOUT,FBAAPN,FBAAPTC,FBBATCH,FBDRUG,FBDX,FBI,FBINTOT,FBINVN,FBMDF,FBPD,FBPOV,FBPT,FBSITE,FBRBC,FBREIM,PSRX,Y,Z,FBFDC,FBMST,FBTTYPE,FBPOP
- K FBRR,FBT,FBTOV,FBTT,FBTV,FBTYPE,FEEO,FTP,FY,I,J,K,N,NAME,S,SSN,VAL,VAR,VID,VNAM,Z1,Z2,ZZ,D,F,FBAC,FBAP,FBFD,FBPROG,FBRX,FBXX,FSW,PI,POP,PTYPE,T,TA,DFN,D0,FBDEL,FBAUT,FBPSA,A1,A2,CHN,DOB,FBPV,FBQTY,FBSTR,FBSUSP,FID,L,PSA,Q,X1
- K FB7078,FBASSOC,FBD1,FBLOC,FBVEN,DIRUT,FBAR,FBDA,FBJ,FBID,FBPARCD,FBTOUT,FBVINVDT,FBFPPSC
- D GETAUTHK^FBAAUTL1
- Q
- GETIT S FBRX=$P(Y(0),"^"),FBFD=$P(Y(0),"^",3),FBAC=$P(Y(0),"^",4),DFN=+$P(Y(0),"^",5)
- S SSN=$$SSN^FBAAUTL(DFN),VID=+$P($G(^FBAA(162.1,DA,0)),"^",4),VNAM=$P($G(^FBAAV(VID,0)),"^")
- I FSW S FSW=0 D HED
- I $Y+5>IOSL S DIR(0)="E" D ^DIR K DIR S:'Y FBAAOUT=1 Q:FBAAOUT D HED
- W !,SSN,?19,$E(FBFD,4,5),"-",$E(FBFD,6,7),"-",$E(FBFD,2,3),?31,FBRX,?44,FBAC
- Q
- HED W @IOF,"Invoice #: ",DA,?25,"Vendor Name: ",VNAM,!!,"Patient I.D.",?18,"Fill Date",?30," RX #",?40,"Amt Claimed",!
- Q
- CHKK W !!,*7,"There already is a prescription number entered, from this vendor, ",!,"for that fill date. The invoice number is ",$O(^FBAA(162.1,"AL",VIN,PSRX,DATEF,""))_" ."
- G RDD^FBAAPIE
- CALC ;Calculate Invoice Total
- S FBINTOT=0 I $D(^FBAA(162.1,IN,"RX")) F I=0:0 S I=$O(^FBAA(162.1,IN,"RX",I)) Q:I'>0 I $D(^(I,0)) S FBINTOT=FBINTOT+$P(^FBAA(162.1,IN,"RX",I,0),"^",16)
- K I Q
- RDM W ! S DIR("A")="Do you want to continue a previously entered Invoice",DIR("B")="No",DIR(0)="Y" D ^DIR K DIR G Q:$D(DIRUT)!('Y)
- RD2 W !! S DIC="^FBAA(162.1,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,5)'=4" D ^DIC G Q:X="^"!(X=""),RD2:Y<0 S (DA,DA(1),IN)=+Y,VIN=$P(^(0),"^",4)
- S INVDATE=$$GET1^DIQ(162.1,DA_",",12,"I") ;Load Inv Rcvd Date for validity check of Rx fill Date in RDD^FBAAPIE
- D CALC W:FBINTOT>0 !,?30,"Current Total: $ "_$J(FBINTOT,1,2)
- RD3 W ! S DIR("A")="Want to list previously entered line items",DIR("B")="No",DIR(0)="Y" D ^DIR K DIR G Q:$D(DIRUT) D:Y LISTLI
- S LCNT=+$P(^FBAA(162.1,IN,0),"^",9),TAC=+$P(^(0),"^",6),STAT=+$P(^(0),"^",5),STAT(STAT)="",FBFPPSC=$P(^FBAA(162.1,IN,0),"^",13) G RDP^FBAAPIE
- Q
- RX2 W !!,*7,"This prescription number already exsists in this invoice.",!
- W ! S DIR("A")="Do you wish to enter this prescription again",DIR("B")="No",DIR(0)="Y" D ^DIR K DIR G CHK^FBAAPIE:$D(DIRUT),RDRX^FBAAPIE:'Y,RXADD^FBAAPIE
- Q
- PROB W !!,"You do not have access to the Fee Invoice File, contact your IRM Service.",! G Q
- CHK2 ;Checks for duplicate payments on all linked vendors.
- S FBJ=0 F S FBJ=$O(FBAR(FBJ)) Q:$S('FBJ:1,$D(^FBAA(162.1,"AL",FBJ,PSRX,DATEF)):1,1:0)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAPIE1 3088 printed Feb 18, 2025@23:22:31 Page 2
- FBAAPIE1 ;AISC/GRR - ENTER FEE PHARMACY INVOICE ;6/5/2009
- +1 ;;3.5;FEE BASIS;**68,108,124**;JAN 30, 1995;Build 20
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- LISTLI IF '$DATA(^FBAA(162.1,DA,"RX","AB"))
- WRITE !,"No prescriptions currently in this invoice.",!
- QUIT
- +1 DO HOME^%ZIS
- SET FSW=1
- +2 SET FBAAOUT=0
- FOR J=0:0
- SET J=$ORDER(^FBAA(162.1,DA,"RX",J))
- if J'>0
- QUIT
- IF $DATA(^FBAA(162.1,DA,"RX",J,0))
- SET Y(0)=^(0)
- DO GETIT
- if FBAAOUT
- QUIT
- +3 QUIT
- Q KILL DIE,DIC,STAT,IN,VIN,DA,LCNT,AC,TAC,DATEF,DR,X,%DT,INVDATE,CNT,DAT,FBAABDT,FBAAEDT,FBAAIN,FBAAOUT,FBAAPN,FBAAPTC,FBBATCH,FBDRUG,FBDX,FBI,FBINTOT,FBINVN,FBMDF,FBPD,FBPOV,FBPT,FBSITE,FBRBC,FBREIM,PSRX,Y,Z,FBFDC,FBMST,FBTTYPE,FBPOP
- +1 KILL FBRR,FBT,FBTOV,FBTT,FBTV,FBTYPE,FEEO,FTP,FY,I,J,K,N,NAME,S,SSN,VAL,VAR,VID,VNAM,Z1,Z2,ZZ,D,F,FBAC,FBAP,FBFD,FBPROG,FBRX,FBXX,FSW,PI,POP,PTYPE,T,TA,DFN,D0,FBDEL,FBAUT,FBPSA,A1,A2,CHN,DOB,FBPV,FBQTY,FBSTR,FBSUSP,FID,L,PSA,Q,X1
- +2 KILL FB7078,FBASSOC,FBD1,FBLOC,FBVEN,DIRUT,FBAR,FBDA,FBJ,FBID,FBPARCD,FBTOUT,FBVINVDT,FBFPPSC
- +3 DO GETAUTHK^FBAAUTL1
- +4 QUIT
- GETIT SET FBRX=$PIECE(Y(0),"^")
- SET FBFD=$PIECE(Y(0),"^",3)
- SET FBAC=$PIECE(Y(0),"^",4)
- SET DFN=+$PIECE(Y(0),"^",5)
- +1 SET SSN=$$SSN^FBAAUTL(DFN)
- SET VID=+$PIECE($GET(^FBAA(162.1,DA,0)),"^",4)
- SET VNAM=$PIECE($GET(^FBAAV(VID,0)),"^")
- +2 IF FSW
- SET FSW=0
- DO HED
- +3 IF $Y+5>IOSL
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- if 'Y
- SET FBAAOUT=1
- if FBAAOUT
- QUIT
- DO HED
- +4 WRITE !,SSN,?19,$EXTRACT(FBFD,4,5),"-",$EXTRACT(FBFD,6,7),"-",$EXTRACT(FBFD,2,3),?31,FBRX,?44,FBAC
- +5 QUIT
- HED WRITE @IOF,"Invoice #: ",DA,?25,"Vendor Name: ",VNAM,!!,"Patient I.D.",?18,"Fill Date",?30," RX #",?40,"Amt Claimed",!
- +1 QUIT
- CHKK WRITE !!,*7,"There already is a prescription number entered, from this vendor, ",!,"for that fill date. The invoice number is ",$ORDER(^FBAA(162.1,"AL",VIN,PSRX,DATEF,""))_" ."
- +1 GOTO RDD^FBAAPIE
- CALC ;Calculate Invoice Total
- +1 SET FBINTOT=0
- IF $DATA(^FBAA(162.1,IN,"RX"))
- FOR I=0:0
- SET I=$ORDER(^FBAA(162.1,IN,"RX",I))
- if I'>0
- QUIT
- IF $DATA(^(I,0))
- SET FBINTOT=FBINTOT+$PIECE(^FBAA(162.1,IN,"RX",I,0),"^",16)
- +2 KILL I
- QUIT
- RDM WRITE !
- SET DIR("A")="Do you want to continue a previously entered Invoice"
- SET DIR("B")="No"
- SET DIR(0)="Y"
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)!('Y)
- GOTO Q
- RD2 WRITE !!
- SET DIC="^FBAA(162.1,"
- SET DIC(0)="AEQM"
- SET DIC("S")="I $P(^(0),U,5)'=4"
- DO ^DIC
- if X="^"!(X="")
- GOTO Q
- if Y<0
- GOTO RD2
- SET (DA,DA(1),IN)=+Y
- SET VIN=$PIECE(^(0),"^",4)
- +1 ;Load Inv Rcvd Date for validity check of Rx fill Date in RDD^FBAAPIE
- SET INVDATE=$$GET1^DIQ(162.1,DA_",",12,"I")
- +2 DO CALC
- if FBINTOT>0
- WRITE !,?30,"Current Total: $ "_$JUSTIFY(FBINTOT,1,2)
- RD3 WRITE !
- SET DIR("A")="Want to list previously entered line items"
- SET DIR("B")="No"
- SET DIR(0)="Y"
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- GOTO Q
- if Y
- DO LISTLI
- +1 SET LCNT=+$PIECE(^FBAA(162.1,IN,0),"^",9)
- SET TAC=+$PIECE(^(0),"^",6)
- SET STAT=+$PIECE(^(0),"^",5)
- SET STAT(STAT)=""
- SET FBFPPSC=$PIECE(^FBAA(162.1,IN,0),"^",13)
- GOTO RDP^FBAAPIE
- +2 QUIT
- RX2 WRITE !!,*7,"This prescription number already exsists in this invoice.",!
- +1 WRITE !
- SET DIR("A")="Do you wish to enter this prescription again"
- SET DIR("B")="No"
- SET DIR(0)="Y"
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- GOTO CHK^FBAAPIE
- if 'Y
- GOTO RDRX^FBAAPIE
- GOTO RXADD^FBAAPIE
- +2 QUIT
- PROB WRITE !!,"You do not have access to the Fee Invoice File, contact your IRM Service.",!
- GOTO Q
- CHK2 ;Checks for duplicate payments on all linked vendors.
- +1 SET FBJ=0
- FOR
- SET FBJ=$ORDER(FBAR(FBJ))
- if $SELECT('FBJ
- QUIT
- +2 QUIT