- FBAAPLU ;AISC/DMK-PHARMACY VENDOR LOOK-UP ;27JUL88
- ;;3.5;FEE BASIS;;JAN 30, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- D DT^DICRW
- RDV K FBAANQ W !! S FBAAOUT=0,DIC="^FBAAV(",DIC(0)="AEQM",DIC("A")="Select Pharmacy Vendor: ",DIC("S")="I $P(^(0),""^"",7)=3" D ^DIC K DIC("A"),DIC("S") G Q:X="^"!(X=""),RDV:Y<0 S FDA=+Y,FBVEN=$P(Y,"^",2)
- D DATE^FBAAUTL G:FBPOP RDV S ZZ=9999999,BEG=ZZ-ENDDATE,END=ZZ-BEGDATE
- S VAR="FDA^BEG^END^FBVEN",VAL=FDA_"^"_BEG_"^"_END_"^"_FBVEN,PGM="START^FBAAPLU" D ZIS^FBAAUTL G:FBPOP Q S:IO=IO(0) FBAANQ=1
- ;
- START S Q="",$P(Q,"=",80)="=",HNAM="" U IO W:$E(IOST,1,2)="C-" @IOF D HED
- S (J,K,L)=0
- F I=BEG-1:0 S I=$O(^FBAA(162.1,"AK",FDA,I)) Q:I>END!(I'>0)!(FBAAOUT) F S J=$O(^FBAA(162.1,"AK",FDA,I,J)) Q:J'>0!(FBAAOUT) F S K=$O(^FBAA(162.1,"AK",FDA,I,J,K)) Q:K'>0!(FBAAOUT) D Q:FBAAOUT
- .F S L=$O(^FBAA(162.1,"AK",FDA,I,J,K,L)) Q:L'>0!(FBAAOUT) D Q:FBAAOUT
- ..I K]"" Q:'$D(^FBAA(162.1,K,0))&('$D(^FBAA(162.1,K,"RX",L,0))) S Y(0)=^(0),Y(1)=$G(^FBAA(162.1,K,"RX",L,2))
- ..S FBINVN=$P(^FBAA(162.1,K,0),"^"),N=$P(Y(0),"^",5),FBNM=$S($D(^DPT(N,0)):$P(^DPT(N,0),"^"),1:""),FBSSN=$S(N]"":$TR($$SSN^FBAAUTL(N),"-",""),1:"")
- ..S FBRX=$P(Y(0),"^"),FBDRUG=$P(Y(0),"^",2),FBFD=$P(Y(0),"^",3),FBAC=$P(Y(0),"^",4),FBAP=$P(Y(0),"^",16),FBSUSP=$P(Y(0),"^",8),FBPD=$P(Y(0),"^",19),FBBATCH=$P(Y(0),"^",17) Q:FBBATCH']""
- ..Q:$P(^FBAA(161.7,FBBATCH,0),"^",12)']"" S FBBATCH=$P($G(^FBAA(161.7,FBBATCH,0)),"^")
- ..I FBSUSP]"" S FBSUSP=$P($G(^FBAA(161.27,FBSUSP,0)),"^")
- ..S FBREIM=$S($P(Y(0),"^",20)="R":"*",1:""),FBSTR=$P(Y(0),"^",12),FBQTY=$P(Y(0),"^",13),A1=FBAC+.00001,A2=FBAP+.00001,A1=$P(A1,".",1)_"."_$E($P(A1,".",2),1,2),A2=$P(A2,".",1)_"."_$E($P(A2,".",2),1,2),FBPV=""
- ..I $D(Y(1)) S FBPV=$S($P(Y(1),"^",3)="V":"#",1:"")
- ..D FBCKP^FBAACCB1(K,L)
- ..D WRT
- G:$D(FBAANQ) RDV
- Q K J,K,L,DIC,BEG,BEGDATE,END,ENDDATE,FBNM,FBSSN,FBVEN,FDA,HNAM,I,X,ZZ,FBRX,FBFD,FBAC,FBAP,A1,A2,FBPV,FBSUSP,FBSTR,FBQTY,FBAAOUT,FBBATCH,FBDRUG,FBINVN,FBPD,FBREIM,N,Q,VAL,VAR,PGM,Y
- D CLOSE^FBAAUTL
- Q
- WRT I $E(IOST,1,2)["C-",$Y+4>IOSL S DIR(0)="E" D ^DIR K DIR S:'Y FBAAOUT=1 Q:FBAAOUT W @IOF D HED
- E I $Y+4>IOSL W @IOF D HED
- W:FBNM'=HNAM !,FBNM,?40,FBSSN,!
- W !,FBREIM,FBPV,$S($G(FBCAN)]"":"+",1:""),?3,$$DATX^FBAAUTL(FBFD),!," Rx: "_FBRX,?15,FBDRUG,?45,FBSTR,?63,FBQTY
- W !,?4,$J(A1,4),?12,$J(A2,4),?20,FBSUSP,?24,FBINVN,?35,FBBATCH,?53,$$DATX^FBAAUTL(FBPD),!
- D PMNT^FBAACCB2
- S HNAM=FBNM
- Q
- HED S FBAAOUT=0 W ?20,"** PHARMACY VENDOR LOOK-UP **",!,!,"Vendor: ",FBVEN,?40,"ID #: ",$P(^FBAAV(FDA,0),"^",2),?60,"Chain #: ",$P(^(0),"^",10),!!,?15,"('*' Reimbursement to Patient '+' Cancellation Activity)",!,?15,"('#' Voided Payment)",!
- W ?3,"Patient",?40,"SSN",!,"Fill Date",?15,"Drug Name",?44,"Strength",?60,"Quantity",!,?2,"Claimed",?11," Paid",?19,"Code",?24,"Invoice #",?35,"Batch #",?50,"Date Finalized",!,Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAPLU 2893 printed Jan 18, 2025@02:57:23 Page 2
- FBAAPLU ;AISC/DMK-PHARMACY VENDOR LOOK-UP ;27JUL88
- +1 ;;3.5;FEE BASIS;;JAN 30, 1995
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 DO DT^DICRW
- RDV KILL FBAANQ
- WRITE !!
- SET FBAAOUT=0
- SET DIC="^FBAAV("
- SET DIC(0)="AEQM"
- SET DIC("A")="Select Pharmacy Vendor: "
- SET DIC("S")="I $P(^(0),""^"",7)=3"
- DO ^DIC
- KILL DIC("A"),DIC("S")
- if X="^"!(X="")
- GOTO Q
- if Y<0
- GOTO RDV
- SET FDA=+Y
- SET FBVEN=$PIECE(Y,"^",2)
- +1 DO DATE^FBAAUTL
- if FBPOP
- GOTO RDV
- SET ZZ=9999999
- SET BEG=ZZ-ENDDATE
- SET END=ZZ-BEGDATE
- +2 SET VAR="FDA^BEG^END^FBVEN"
- SET VAL=FDA_"^"_BEG_"^"_END_"^"_FBVEN
- SET PGM="START^FBAAPLU"
- DO ZIS^FBAAUTL
- if FBPOP
- GOTO Q
- if IO=IO(0)
- SET FBAANQ=1
- +3 ;
- START SET Q=""
- SET $PIECE(Q,"=",80)="="
- SET HNAM=""
- USE IO
- if $EXTRACT(IOST,1,2)="C-"
- WRITE @IOF
- DO HED
- +1 SET (J,K,L)=0
- +2 FOR I=BEG-1:0
- SET I=$ORDER(^FBAA(162.1,"AK",FDA,I))
- if I>END!(I'>0)!(FBAAOUT)
- QUIT
- FOR
- SET J=$ORDER(^FBAA(162.1,"AK",FDA,I,J))
- if J'>0!(FBAAOUT)
- QUIT
- FOR
- SET K=$ORDER(^FBAA(162.1,"AK",FDA,I,J,K))
- if K'>0!(FBAAOUT)
- QUIT
- Begin DoDot:1
- +3 FOR
- SET L=$ORDER(^FBAA(162.1,"AK",FDA,I,J,K,L))
- if L'>0!(FBAAOUT)
- QUIT
- Begin DoDot:2
- +4 IF K]""
- if '$DATA(^FBAA(162.1,K,0))&('$DATA(^FBAA(162.1,K,"RX",L,0)))
- QUIT
- SET Y(0)=^(0)
- SET Y(1)=$GET(^FBAA(162.1,K,"RX",L,2))
- +5 SET FBINVN=$PIECE(^FBAA(162.1,K,0),"^")
- SET N=$PIECE(Y(0),"^",5)
- SET FBNM=$SELECT($DATA(^DPT(N,0)):$PIECE(^DPT(N,0),"^"),1:"")
- SET FBSSN=$SELECT(N]"":$TRANSLATE($$SSN^FBAAUTL(N),"-",""),1:"")
- +6 SET FBRX=$PIECE(Y(0),"^")
- SET FBDRUG=$PIECE(Y(0),"^",2)
- SET FBFD=$PIECE(Y(0),"^",3)
- SET FBAC=$PIECE(Y(0),"^",4)
- SET FBAP=$PIECE(Y(0),"^",16)
- SET FBSUSP=$PIECE(Y(0),"^",8)
- SET FBPD=$PIECE(Y(0),"^",19)
- SET FBBATCH=$PIECE(Y(0),"^",17)
- if FBBATCH']""
- QUIT
- +7 if $PIECE(^FBAA(161.7,FBBATCH,0),"^",12)']""
- QUIT
- SET FBBATCH=$PIECE($GET(^FBAA(161.7,FBBATCH,0)),"^")
- +8 IF FBSUSP]""
- SET FBSUSP=$PIECE($GET(^FBAA(161.27,FBSUSP,0)),"^")
- +9 SET FBREIM=$SELECT($PIECE(Y(0),"^",20)="R":"*",1:"")
- SET FBSTR=$PIECE(Y(0),"^",12)
- SET FBQTY=$PIECE(Y(0),"^",13)
- SET A1=FBAC+.00001
- SET A2=FBAP+.00001
- SET A1=$PIECE(A1,".",1)_"."_$EXTRACT($PIECE(A1,".",2),1,2)
- SET A2=$PIECE(A2,".",1)_"."_$EXTRACT($PIECE(A2,".",2),1,2)
- SET FBPV=""
- +10 IF $DATA(Y(1))
- SET FBPV=$SELECT($PIECE(Y(1),"^",3)="V":"#",1:"")
- +11 DO FBCKP^FBAACCB1(K,L)
- +12 DO WRT
- End DoDot:2
- if FBAAOUT
- QUIT
- End DoDot:1
- if FBAAOUT
- QUIT
- +13 if $DATA(FBAANQ)
- GOTO RDV
- Q KILL J,K,L,DIC,BEG,BEGDATE,END,ENDDATE,FBNM,FBSSN,FBVEN,FDA,HNAM,I,X,ZZ,FBRX,FBFD,FBAC,FBAP,A1,A2,FBPV,FBSUSP,FBSTR,FBQTY,FBAAOUT,FBBATCH,FBDRUG,FBINVN,FBPD,FBREIM,N,Q,VAL,VAR,PGM,Y
- +1 DO CLOSE^FBAAUTL
- +2 QUIT
- WRT IF $EXTRACT(IOST,1,2)["C-"
- IF $Y+4>IOSL
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- if 'Y
- SET FBAAOUT=1
- if FBAAOUT
- QUIT
- WRITE @IOF
- DO HED
- +1 IF '$TEST
- IF $Y+4>IOSL
- WRITE @IOF
- DO HED
- +2 if FBNM'=HNAM
- WRITE !,FBNM,?40,FBSSN,!
- +3 WRITE !,FBREIM,FBPV,$SELECT($GET(FBCAN)]"":"+",1:""),?3,$$DATX^FBAAUTL(FBFD),!," Rx: "_FBRX,?15,FBDRUG,?45,FBSTR,?63,FBQTY
- +4 WRITE !,?4,$JUSTIFY(A1,4),?12,$JUSTIFY(A2,4),?20,FBSUSP,?24,FBINVN,?35,FBBATCH,?53,$$DATX^FBAAUTL(FBPD),!
- +5 DO PMNT^FBAACCB2
- +6 SET HNAM=FBNM
- +7 QUIT
- HED SET FBAAOUT=0
- WRITE ?20,"** PHARMACY VENDOR LOOK-UP **",!,!,"Vendor: ",FBVEN,?40,"ID #: ",$PIECE(^FBAAV(FDA,0),"^",2),?60,"Chain #: ",$PIECE(^(0),"^",10),!!,?15,"('*' Reimbursement to Patient '+' Cancellation Activity)",!,?15,"('#' Voided Payment)",!
- +1 WRITE ?3,"Patient",?40,"SSN",!,"Fill Date",?15,"Drug Name",?44,"Strength",?60,"Quantity",!,?2,"Claimed",?11," Paid",?19,"Code",?24,"Invoice #",?35,"Batch #",?50,"Date Finalized",!,Q
- +2 QUIT