IBARXMQ ;LL/ELZ-RX COPAY RPC QUERY ROUTINE (MILL BILL) ;10-OCT-2000
;;2.0;INTEGRATED BILLING;**150,156,186,199,563,676,746**;21-MAR-94;Build 8
;;Per VA Directive 6402, this routine should not be modified.
;
EN ; main entry point for users to request a query of rx bills from all possible facilities
N DIC,X,Y,DFN,IBT,IBTFL,%,%ZIS,ZTSAVE,POP,ZTSK,DIR,IBDT,IBPAT,IBROOT,IBDOB
;
; select patient, and get pt info
N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
S DIC="^DPT(",DIC(0)="AEMNQ" D ^DIC Q:Y<1 S DFN=+Y
D DEM^VADPT S IBPAT=VADM(1)_"^"_VA("BID"),IBDOB=$P(VADM(3),U,2) D KVAR^VADPT ;IB*2.0*746
;
; ask for month / year
S DIR(0)="D^::AEMP",DIR("A")="For What Month/Year" D ^DIR Q:Y<1
S IBDT=Y
;
; scan for patient to see if different facilities could be involved
S IBT=$$TFL^IBARXMU(DFN,.IBTFL,2)
;
; if multiple facilities ask if we should check
I IBT W !,"This patient could have Pharmacy Co-payment bills at other facilities",!,"Do you want to check those other facilities" S %=0 D YN^DICN S:%'=1 IBT=0 Q:%<0
;
; now for a device
S %ZIS="MQ" D ^%ZIS Q:POP
I $D(IO("Q")) D Q
. N ZTDESC,ZTRTN
. S ZTRTN="DQ^IBARXMQ",(ZTSAVE("DFN"),ZTSAVE("IB*"))=""
. S ZTDESC="PHARMACY BILLING SUMMARY"
. D ^%ZTLOAD,HOME^%ZIS K IO("Q") W !,"Task# ",ZTSK
;
DQ ; tasked entry point
;
N IBD,IBER,X,IBX,IBC,IBB,IBU,DIRUT,IBE,IBP,IBAR K ^TMP("IBARXM",$J)
;
; remote stuff, file locally
I IBT S IBX=0 F S IBX=$O(IBTFL(IBX)) Q:IBX<1 D
. W:'$D(ZTQUEUED) !,"Now sending query to ",$P(IBTFL(IBX),"^",2)," ..."
. ;676;BL; Send request to Cerner Separate response message returns transactions
. I $P(IBTFL(IBX),"^",1)["200CRNR" D Q
. . D EN^IBARXCQR(DFN,$E(IBDT,1,5)_"00")
. D QUERY^IBARXMU(DFN,IBDT,+IBTFL(IBX),.IBD)
. I $P(IBD(0),"^")=-1!(-1=+IBD)!($P($G(IBD(1)),"^")=-1) S IBER=1 K IBD Q
. S X=1 F S X=$O(IBD(X)) Q:X<1 S IBD=$$ADD^IBARXMN(DFN,IBD(X))
. K IBD
;
; stuff on local file w/remote stuff, build tmp
S (IBC,IBX)=0 F S IBX=$O(^IBAM(354.71,"AD",DFN,IBDT,IBX)) Q:IBX<1 S IBC=IBC+1,IBD=^IBAM(354.71,IBX,0),IBAR=$P($P($G(^IB(+$P(IBD,"^",4),0)),"^",11),"-",2),^TMP("IBARXM",$J,$P(IBD,"^",3),IBC)=IBD,^(IBC,"AR")=IBAR
;
;
PRINT ;
U IO
;
S (IBP,IBE,IBB,IBU)=0 D HEAD F S IBE=$O(^TMP("IBARXM",$J,IBE)) Q:IBE<1!($D(DIRUT)) S IBX=0 F S IBX=$O(^TMP("IBARXM",$J,IBE,IBX)) Q:IBX<1!($D(DIRUT)) D
. D:$Y+3>IOSL HEAD Q:$D(DIRUT)
. S IBD=^TMP("IBARXM",$J,IBE,IBX)
. W !,$E($P($$FAC^IBARXMU($P(IBD,"^",13)),"^"),1,9),"(",+IBD,")" ;676;BL Changed call to return Cerner name
. W ?17,$G(^TMP("IBARXM",$J,IBE,IBX,"AR"))
. W ?29,$$FMTE^XLFDT(IBE,"2D")
. W ?40,$P(IBD,"^",20)
. W ?44,$P(IBD,"^",9)
. W ?67,$J($P(IBD,"^",11),6,2)
. W ?74,$J($P(IBD,"^",12),6,2)
. S IBB=IBB+$P(IBD,"^",11),IBU=IBU+$P(IBD,"^",12)
I $D(DIRUT) G Q
W !!?67,"-------",?74,"------"
W !?67,$J(IBB,6,2),?75,$J(IBU,5,2)
;
; update totals in the patient's account
X $S($D(IBER):"W !!,""Unable to perform all remote queries, totals will not be updated!""",IBT=0&($D(IBTFL)):"W !!,""No remote queries needed/performed, account not updated.""",1:"D ACCT^IBARXMN(DFN,IBB,IBU,IBDT,1)")
;
I $E(IOST,1,2)="C-",'$D(DIRUT) N DIR,X,Y,DTOUT,DUOUT,DIROUT S DIR(0)="E" D ^DIR
;
Q K ^TMP("IBARXM",$J)
D ^%ZISC
S:$D(ZTQUEUED) ZTREQ="@"
Q
;
HEAD ; prints header info
N DIR,X,Y,DTOUT,DUOUT,DIROUT
I IBP>0,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR Q:$D(DIRUT)
S IBP=IBP+1
W @IOF,!,"Medication Co-Pay Billing Summary",?IOM-10,"Page: ",IBP
W !,"Patient: ",$P(IBPAT,"^")," (",IBDOB,")",?IOM-11,$$FMTE^XLFDT(IBDT),! ;IB*2.0*746
F X=0:1:IOM-1 W "-"
W !,"Station AR Bill Date Tier Brief Description Billed Not B",! F X=0:1:IOM-1 W "-"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXMQ 3761 printed Sep 23, 2025@19:43:52 Page 2
IBARXMQ ;LL/ELZ-RX COPAY RPC QUERY ROUTINE (MILL BILL) ;10-OCT-2000
+1 ;;2.0;INTEGRATED BILLING;**150,156,186,199,563,676,746**;21-MAR-94;Build 8
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; main entry point for users to request a query of rx bills from all possible facilities
+1 NEW DIC,X,Y,DFN,IBT,IBTFL,%,%ZIS,ZTSAVE,POP,ZTSK,DIR,IBDT,IBPAT,IBROOT,IBDOB
+2 ;
+3 ; select patient, and get pt info
+4 ;Suppress PATIENT file fuzzy lookups
NEW DPTNOFZY
SET DPTNOFZY=1
+5 SET DIC="^DPT("
SET DIC(0)="AEMNQ"
DO ^DIC
if Y<1
QUIT
SET DFN=+Y
+6 ;IB*2.0*746
DO DEM^VADPT
SET IBPAT=VADM(1)_"^"_VA("BID")
SET IBDOB=$PIECE(VADM(3),U,2)
DO KVAR^VADPT
+7 ;
+8 ; ask for month / year
+9 SET DIR(0)="D^::AEMP"
SET DIR("A")="For What Month/Year"
DO ^DIR
if Y<1
QUIT
+10 SET IBDT=Y
+11 ;
+12 ; scan for patient to see if different facilities could be involved
+13 SET IBT=$$TFL^IBARXMU(DFN,.IBTFL,2)
+14 ;
+15 ; if multiple facilities ask if we should check
+16 IF IBT
WRITE !,"This patient could have Pharmacy Co-payment bills at other facilities",!,"Do you want to check those other facilities"
SET %=0
DO YN^DICN
if %'=1
SET IBT=0
if %<0
QUIT
+17 ;
+18 ; now for a device
+19 SET %ZIS="MQ"
DO ^%ZIS
if POP
QUIT
+20 IF $DATA(IO("Q"))
Begin DoDot:1
+21 NEW ZTDESC,ZTRTN
+22 SET ZTRTN="DQ^IBARXMQ"
SET (ZTSAVE("DFN"),ZTSAVE("IB*"))=""
+23 SET ZTDESC="PHARMACY BILLING SUMMARY"
+24 DO ^%ZTLOAD
DO HOME^%ZIS
KILL IO("Q")
WRITE !,"Task# ",ZTSK
End DoDot:1
QUIT
+25 ;
DQ ; tasked entry point
+1 ;
+2 NEW IBD,IBER,X,IBX,IBC,IBB,IBU,DIRUT,IBE,IBP,IBAR
KILL ^TMP("IBARXM",$JOB)
+3 ;
+4 ; remote stuff, file locally
+5 IF IBT
SET IBX=0
FOR
SET IBX=$ORDER(IBTFL(IBX))
if IBX<1
QUIT
Begin DoDot:1
+6 if '$DATA(ZTQUEUED)
WRITE !,"Now sending query to ",$PIECE(IBTFL(IBX),"^",2)," ..."
+7 ;676;BL; Send request to Cerner Separate response message returns transactions
+8 IF $PIECE(IBTFL(IBX),"^",1)["200CRNR"
Begin DoDot:2
+9 DO EN^IBARXCQR(DFN,$EXTRACT(IBDT,1,5)_"00")
End DoDot:2
QUIT
+10 DO QUERY^IBARXMU(DFN,IBDT,+IBTFL(IBX),.IBD)
+11 IF $PIECE(IBD(0),"^")=-1!(-1=+IBD)!($PIECE($GET(IBD(1)),"^")=-1)
SET IBER=1
KILL IBD
QUIT
+12 SET X=1
FOR
SET X=$ORDER(IBD(X))
if X<1
QUIT
SET IBD=$$ADD^IBARXMN(DFN,IBD(X))
+13 KILL IBD
End DoDot:1
+14 ;
+15 ; stuff on local file w/remote stuff, build tmp
+16 SET (IBC,IBX)=0
FOR
SET IBX=$ORDER(^IBAM(354.71,"AD",DFN,IBDT,IBX))
if IBX<1
QUIT
SET IBC=IBC+1
SET IBD=^IBAM(354.71,IBX,0)
SET IBAR=$PIECE($PIECE($GET(^IB(+$PIECE(IBD,"^",4),0)),"^",11),"-",2)
SET ^TMP("IBARXM",$JOB,$PIECE(IBD,"^",3),IBC)=IBD
SET ^(IBC,"AR")=IBAR
+17 ;
+18 ;
PRINT ;
+1 USE IO
+2 ;
+3 SET (IBP,IBE,IBB,IBU)=0
DO HEAD
FOR
SET IBE=$ORDER(^TMP("IBARXM",$JOB,IBE))
if IBE<1!($DATA(DIRUT))
QUIT
SET IBX=0
FOR
SET IBX=$ORDER(^TMP("IBARXM",$JOB,IBE,IBX))
if IBX<1!($DATA(DIRUT))
QUIT
Begin DoDot:1
+4 if $Y+3>IOSL
DO HEAD
if $DATA(DIRUT)
QUIT
+5 SET IBD=^TMP("IBARXM",$JOB,IBE,IBX)
+6 ;676;BL Changed call to return Cerner name
WRITE !,$EXTRACT($PIECE($$FAC^IBARXMU($PIECE(IBD,"^",13)),"^"),1,9),"(",+IBD,")"
+7 WRITE ?17,$GET(^TMP("IBARXM",$JOB,IBE,IBX,"AR"))
+8 WRITE ?29,$$FMTE^XLFDT(IBE,"2D")
+9 WRITE ?40,$PIECE(IBD,"^",20)
+10 WRITE ?44,$PIECE(IBD,"^",9)
+11 WRITE ?67,$JUSTIFY($PIECE(IBD,"^",11),6,2)
+12 WRITE ?74,$JUSTIFY($PIECE(IBD,"^",12),6,2)
+13 SET IBB=IBB+$PIECE(IBD,"^",11)
SET IBU=IBU+$PIECE(IBD,"^",12)
End DoDot:1
+14 IF $DATA(DIRUT)
GOTO Q
+15 WRITE !!?67,"-------",?74,"------"
+16 WRITE !?67,$JUSTIFY(IBB,6,2),?75,$JUSTIFY(IBU,5,2)
+17 ;
+18 ; update totals in the patient's account
+19 XECUTE $SELECT($DATA(IBER):"W !!,""Unable to perform all remote queries, totals will not be updated!""",IBT=0&($DATA(IBTFL)):"W !!,""No remote queries needed/performed, account not updated.""",1:"D ACCT^IBARXMN(DFN,IBB,IBU,IBDT,1)")
+20 ;
+21 IF $EXTRACT(IOST,1,2)="C-"
IF '$DATA(DIRUT)
NEW DIR,X,Y,DTOUT,DUOUT,DIROUT
SET DIR(0)="E"
DO ^DIR
+22 ;
Q KILL ^TMP("IBARXM",$JOB)
+1 DO ^%ZISC
+2 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 QUIT
+4 ;
HEAD ; prints header info
+1 NEW DIR,X,Y,DTOUT,DUOUT,DIROUT
+2 IF IBP>0
IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
DO ^DIR
if $DATA(DIRUT)
QUIT
+3 SET IBP=IBP+1
+4 WRITE @IOF,!,"Medication Co-Pay Billing Summary",?IOM-10,"Page: ",IBP
+5 ;IB*2.0*746
WRITE !,"Patient: ",$PIECE(IBPAT,"^")," (",IBDOB,")",?IOM-11,$$FMTE^XLFDT(IBDT),!
+6 FOR X=0:1:IOM-1
WRITE "-"
+7 WRITE !,"Station AR Bill Date Tier Brief Description Billed Not B",!
FOR X=0:1:IOM-1
WRITE "-"
+8 QUIT
