Routine: IBARXMQ

IBARXMQ ;LL/ELZ-RX COPAY RPC QUERY ROUTINE (MILL BILL) ;10-OCT-2000

 ;;2.0;INTEGRATED BILLING;**150,156,186,199,563,676**;21-MAR-94;Build 34

 ;;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

 ; 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") D KVAR^VADPT

 ; 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="@"

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,"^")," (",$P(IBPAT,"^",2),")",?IOM-11,$$FMTE^XLFDT(IBDT),!

 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 "-"

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXMQ   3716     printed  Mar 13, 2025@21:12:27                                                                                                                                                                                                     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**;21-MAR-94;Build 34

 +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

 +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        DO DEM^VADPT

           SET IBPAT=VADM(1)_"^"_VA("BID")

           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        WRITE !,"Patient: ",$PIECE(IBPAT,"^")," (",$PIECE(IBPAT,"^",2),")",?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

IBARXMQ.m