IBOMTLTC ;OAKOIFO/ELZ-MT/LTC COPAY REMOTE QUERY ;20-AUG-2002
;;2.0;INTEGRATED BILLING;**188**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
QUERY ; main entry point for user to request a query of mt and ltc copay info
;
N IBBDT,IBEDT,DIC,DFN,X,Y,IBT,DIR,DTOUT,DUOUT,DIRUT,DIROUT,IBICN,IBTFL,%ZIS,ZTDESC,ZTREQ,ZTRTN,ZTSAVE,POP
;
S DIC="^DPT(",DIC(0)="AEMNQ" D ^DIC Q:Y<1 S DFN=+Y
;
D DATE^IBOUTL Q:IBEDT<1
;
S IBT=$$TFL^IBARXMU(DFN,.IBTFL)
S IBICN=$$ICN^IBARXMU(DFN) I 'IBICN,IBT W !,"There is no ICN for this patient." K IBTFL S IBT=0
;
I IBT W !,"This patient has remote facilities." S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do you want to perform remote queries" D ^DIR Q:$D(DIRUT) I 'Y S IBT=0
;
I 'IBT W !!,"Performing query locally only" W:$D(IBTFL)>9 "." I $D(IBTFL)<10 W ", the patient has no remote facilities."
;
S %ZIS="MQ" D ^%ZIS Q:POP
I $D(IO("Q")) D Q
. S ZTRTN="DQ^IBOMTLTC",ZTDESC="MT/LTC COPAY REMOTE QUERY"
. S (ZTSAVE("DFN"),ZTSAVE("IB*"))="" D ^%ZTLOAD,HOME^%ZIS K IO("Q")
;
DQ ; tasked entry point
N IBS,IBX,IBH,IBQ,IBC,IBP,IBHERE
K ^TMP("IBOMTLTC",$J)
;
; data will be gathered in ^tmp("ibomtltc",$j,site,n) nodes in final
; output format. (where site is the internal value from file 4 locally)
;
S IBS=+$$SITE^VASITE ; store the internal value for file 4
D DEM^VADPT
;
; send off queries (if needed)
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)," ..."
. D EN1^XWB2HL7(.IBH,+IBTFL(IBX),"IBO MT LTC COPAY QUERY","",IBICN,"",IBBDT,IBEDT)
. I $G(IBH(0))="" S IBR="-1^No handle returned from RPC" Q
. S $P(IBTFL(IBX),"^",3)=IBH(0) ; save handle for later.
;
; now while waiting for remote stuff, let's do local stuff.
D RETURN($NA(^TMP("IBOMTLTC",$J,IBS)),"",DFN,IBBDT,IBEDT)
;
; now lets look for the remote data
I IBT S IBX=0 F S IBX=$O(IBTFL(IBX)) Q:IBX<1 D
. ;
. F IBC=1:1:10 D RPCCHK^XWB2HL7(.IBR,$P(IBTFL(IBX),"^",3)) Q:$G(IBR(0))["Done" H 2
. ; if done get data.
. I $G(IBR(0))["Done" D
.. K IBR,IBHERE
.. D RTNDATA^XWBDRPC(.IBHERE,$P(IBTFL(IBX),"^",3))
.. I $D(IBHERE)>10 M ^TMP("IBOMTLTC",$J,+$$LKUP^XUAF4(+IBTFL(IBX)))=IBHERE
.. E M ^TMP("IBOMTLTC",$J,+$$LKUP^XUAF4(+IBTFL(IBX)))=^TMP($J,"XWB") K ^TMP($J,"XWB")
.. D CLEAR^XWBDRPC(.IBZ,$P(IBTFL(IBX),"^",3))
. E S ^TMP("IBOMTLTC",$J,+$$LKUP^XUAF4(+IBTFL(IBX)),0)="Unable to get remote information from this site."
;
; now that I have the info, time to print
;
U IO S (IBQ,IBP)=0
S IBS=0 F S IBS=$O(^TMP("IBOMTLTC",$J,IBS)) Q:IBS<1!(IBQ) D
. S IBS(0)=$$NNT^XUAF4(IBS)
. D PAUSE(1)
. S IBX=-1 F S IBX=$O(^TMP("IBOMTLTC",$J,IBS,IBX)) Q:IBX=""!(IBQ) W !,^(IBX) D PAUSE()
;
I 'IBQ,$E(IOST,1,2)="C-" K DIR S DIR(0)="E" D ^DIR
;
D ^%ZISC
;
K ^TMP("IBOMTLTC",$J) D KVAR^VADPT
S:$D(ZTQUEUED) ZTREQ="@"
;
Q
;
PAUSE(IBNEW) ;
; IBNEW = optional variable, it is a flag for new site
;
N DIR,DIRUT,DIROUT,DTOUT,X,Y
I IBQ Q
I $Y+6<IOSL,IBP,'$D(IBNEW) Q
I IBP,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR I $D(DIRUT) S IBQ=1 Q
S IBP=IBP+1
W @IOF,!,"MT and LTC Copay Information ",$$FMTE^XLFDT(IBBDT)," to ",$$FMTE^XLFDT(IBEDT),?IOM-15,"Page: ",IBP
W !,"Patient: ",VADM(1)," (",$P(VADM(2),"-",3),") For Site: ",$P(IBS(0),"^")," (",$P(IBS(0),"^",2),")",!
F X=1:1:IOM W "-"
Q
;
RETURN(IBR,IBICN,DFN,IBBDT,IBEDT) ;
; this is called from the main query for local data and from the remote
; procedure IBO MT LTC COPAY QUERY for remote data. The return is
; in a global array.
; if DFN then that will be used to identify the patient
; if no DFN, then the ICN (ibicn) needs to be there to identify patient
;
N IBA,IBX,IBT,IBZ,IBL,IBS,IBF,IBFRDT,Y,Y1,IBD,IBSTAT,IBTYP,IBAX,IBCHG
;
I '$D(IBR) S IBR=$NA(^TMP("IBOMTLTC",$J))
;
S IBL=0
I '$G(DFN) S DFN=+$$DFN^IBARXMU($G(IBICN)) I 'DFN S @IBR@(1)="-1^Patient not found" Q
;
; look for MT clocks and get info
S IBX=0 F S IBX=$O(^IBE(351,"C",DFN,IBX)) Q:'IBX D
. S IBZ=^IBE(351,IBX,0)
. I '$P(IBZ,"^",10) S $P(IBZ,"^",10)=$$FMADD^XLFDT($P(IBZ,"^",3),364)
. I $P(IBZ,"^",3)>IBEDT!($P(IBZ,"^",10)<IBBDT) Q
. D GETS^DIQ(351,IBX,".03:.1","ENR","IBT")
;
; look for LTC clocks and get info
S IBX=0 F S IBX=$O(^IBA(351.81,"C",DFN,IBX)) Q:'IBX D
. S IBZ=^IBA(351.81,IBX,0)
. I $P(IBZ,"^",3)>IBEDT,$P(IBZ,"^",4)>IBBDT Q
. D GETS^DIQ(351.81,IBX,".03:.06","ENR","IBT")
. ; get the free days (store in date order with a "[" flag)
. S IBF=0 F S IBF=$O(^IBA(351.81,IBX,1,IBF)) Q:IBF<1 S IBFRDT=$P(^IBA(351.81,IBX,1,IBF,0),"^",2),IBT(351.81,IBX_",","["_IBFRDT_"EXEMPT DATE","E")=$$FMTE^XLFDT(IBFRDT)
;
; move the data to return area
F IBF=351,351.81,351.811 S IBX="" F S IBX=$O(IBT(IBF,IBX)) Q:IBX="" D SPACE($S(IBF=351:"MT",1:"LTC")_" Billing Clock") S IBA="" F S IBA=$O(IBT(IBF,IBX,IBA)) Q:IBA="" D
. I $L(@IBR@(IBL))>40!($L(IBA_": "_IBT(IBF,IBX,IBA,"E"))>40) S IBL=IBL+1,@IBR@(IBL)=$S($E(IBA)="[":$E(IBA,9,99),1:IBA)_": "_IBT(IBF,IBX,IBA,"E") Q
. S IBS="",$P(IBS," ",40-$L(@IBR@(IBL)))="",@IBR@(IBL)=@IBR@(IBL)_IBS_$S($E(IBA)="[":$E(IBA,9,99),1:IBA)_": "_IBT(IBF,IBX,IBA,"E")
;
; get billing info from 350
; first find the charges and sort
K ^TMP("IBECEA",$J)
S Y="" F S Y=$O(^IB("AFDT",DFN,Y)) Q:'Y I -Y'>IBEDT S Y1=0 F S Y1=$O(^IB("AFDT",DFN,Y,Y1)) Q:'Y1 D
. S IBX=0 F S IBX=$O(^IB("AF",Y1,IBX)) Q:'IBX D
.. Q:'$D(^IB(IBX,0)) S IBZ=^(0)
.. Q:$P(IBZ,"^",8)["ADMISSION"
.. I $P(IBZ,"^",15)<IBBDT!($P(IBZ,"^",14)>IBEDT) Q
.. S ^TMP("IBECEA",$J,+$P(IBZ,"^",14),IBX)=""
;
S Y=0 F S Y=$O(^IB("ACVA",DFN,Y)) Q:'Y I Y'>IBEDT S Y1=0 F S Y1=$O(^IB("ACVA",DFN,Y,Y1)) Q:'Y1 D
. S IBX=0 F S IBX=$O(^IB("AD",Y1,IBX)) Q:'IBX D
.. Q:'$D(^IB(IBX,0)) S IBZ=^(0)
.. I $P(IBZ,"^",15)<IBBDT!($P(IBZ,"^",14)>IBEDT) Q
.. S ^TMP("IBECEA",$J,Y,IBX)=""
;
; now store for return
D SPACE("Patient Charges")
I $D(^TMP("IBECEA",$J)) S IBL=IBL+1,@IBR@(IBL)="Bill From Bill To Charge Type Stop Bill # Status Charge"
S IBD="" F S IBD=$O(^TMP("IBECEA",$J,IBD)) Q:'IBD D
. S IBX="" F S IBX=$O(^TMP("IBECEA",$J,IBD,IBX)) Q:'IBX D
.. S IBZ=^IB(IBX,0) Q:$P(IBZ,"^",7)=""
.. S IBL=IBL+1
.. S IBSTAT=$$EXTERNAL^DILFD(350,.05,"",$P(IBZ,"^",5))
.. S IBATYP=$P($G(^IBE(350.1,+$P(IBZ,"^",3),0)),"^")
.. S:$E(IBATYP,1,2)="DG" IBATYP=$E(IBATYP,4,99)
.. ; if ouptatient charge and clinic stop, show it
.. I $E(IBATYP,1,3)="OPT",$P(IBZ,"^",20) S IBATYP=$E(IBATYP_" ",1,21)_" "_$P($G(^IBE(352.5,+$P(IBZ,"^",20),0)),"^")
.. S IBCHG=$S(IBATYP["CANCEL":"(",1:" ")_"$"_$P(IBZ,"^",7)_$S(IBATYP["CANCEL":")",1:"")
.. S IBAX=$$SETSTR^VALM1($$DAT1^IBOUTL(IBD),"",1,9)
.. S IBAX=$$SETSTR^VALM1($$DAT1^IBOUTL($S($P(IBZ,"^",8)["RX COPAY":IBD,1:$P(IBZ,"^",15))),IBAX,12,8)
.. S IBAX=$$SETSTR^VALM1(IBATYP,IBAX,22,26)
.. S IBAX=$$SETSTR^VALM1($P($P(IBZ,"^",11),"-",2),IBAX,49,8)
.. S IBAX=$$SETSTR^VALM1(IBSTAT,IBAX,58,12)
.. S IBAX=$$SETSTR^VALM1(IBCHG,IBAX,71,9)
.. S @IBR@(IBL)=IBAX
I '$D(IBAX) S @IBR@(IBL+1)=" ",@IBR@(IBL+2)="No charges meet criteria"
K ^TMP("IBECEA",$J)
;
Q
;
SPACE(IBTEXT) ; spaces out return info (sub-header info)
S IBL=IBL+1,@IBR@(IBL)="",IBL=IBL+1,$P(@IBR@(IBL),"-",80)=""
S IBL=IBL+1,$P(@IBR@(IBL)," ",80-$L(IBTEXT)/2)=IBTEXT
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOMTLTC 7387 printed Apr 09, 2024@21:26:05 Page 2
IBOMTLTC ;OAKOIFO/ELZ-MT/LTC COPAY REMOTE QUERY ;20-AUG-2002
+1 ;;2.0;INTEGRATED BILLING;**188**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
QUERY ; main entry point for user to request a query of mt and ltc copay info
+1 ;
+2 NEW IBBDT,IBEDT,DIC,DFN,X,Y,IBT,DIR,DTOUT,DUOUT,DIRUT,DIROUT,IBICN,IBTFL,%ZIS,ZTDESC,ZTREQ,ZTRTN,ZTSAVE,POP
+3 ;
+4 SET DIC="^DPT("
SET DIC(0)="AEMNQ"
DO ^DIC
if Y<1
QUIT
SET DFN=+Y
+5 ;
+6 DO DATE^IBOUTL
if IBEDT<1
QUIT
+7 ;
+8 SET IBT=$$TFL^IBARXMU(DFN,.IBTFL)
+9 SET IBICN=$$ICN^IBARXMU(DFN)
IF 'IBICN
IF IBT
WRITE !,"There is no ICN for this patient."
KILL IBTFL
SET IBT=0
+10 ;
+11 IF IBT
WRITE !,"This patient has remote facilities."
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Do you want to perform remote queries"
DO ^DIR
if $DATA(DIRUT)
QUIT
IF 'Y
SET IBT=0
+12 ;
+13 IF 'IBT
WRITE !!,"Performing query locally only"
if $DATA(IBTFL)>9
WRITE "."
IF $DATA(IBTFL)<10
WRITE ", the patient has no remote facilities."
+14 ;
+15 SET %ZIS="MQ"
DO ^%ZIS
if POP
QUIT
+16 IF $DATA(IO("Q"))
Begin DoDot:1
+17 SET ZTRTN="DQ^IBOMTLTC"
SET ZTDESC="MT/LTC COPAY REMOTE QUERY"
+18 SET (ZTSAVE("DFN"),ZTSAVE("IB*"))=""
DO ^%ZTLOAD
DO HOME^%ZIS
KILL IO("Q")
End DoDot:1
QUIT
+19 ;
DQ ; tasked entry point
+1 NEW IBS,IBX,IBH,IBQ,IBC,IBP,IBHERE
+2 KILL ^TMP("IBOMTLTC",$JOB)
+3 ;
+4 ; data will be gathered in ^tmp("ibomtltc",$j,site,n) nodes in final
+5 ; output format. (where site is the internal value from file 4 locally)
+6 ;
+7 ; store the internal value for file 4
SET IBS=+$$SITE^VASITE
+8 DO DEM^VADPT
+9 ;
+10 ; send off queries (if needed)
+11 IF IBT
SET IBX=0
FOR
SET IBX=$ORDER(IBTFL(IBX))
if IBX<1
QUIT
Begin DoDot:1
+12 ;
+13 if '$DATA(ZTQUEUED)
WRITE !,"Now sending query to ",$PIECE(IBTFL(IBX),"^",2)," ..."
+14 DO EN1^XWB2HL7(.IBH,+IBTFL(IBX),"IBO MT LTC COPAY QUERY","",IBICN,"",IBBDT,IBEDT)
+15 IF $GET(IBH(0))=""
SET IBR="-1^No handle returned from RPC"
QUIT
+16 ; save handle for later.
SET $PIECE(IBTFL(IBX),"^",3)=IBH(0)
End DoDot:1
+17 ;
+18 ; now while waiting for remote stuff, let's do local stuff.
+19 DO RETURN($NAME(^TMP("IBOMTLTC",$JOB,IBS)),"",DFN,IBBDT,IBEDT)
+20 ;
+21 ; now lets look for the remote data
+22 IF IBT
SET IBX=0
FOR
SET IBX=$ORDER(IBTFL(IBX))
if IBX<1
QUIT
Begin DoDot:1
+23 ;
+24 FOR IBC=1:1:10
DO RPCCHK^XWB2HL7(.IBR,$PIECE(IBTFL(IBX),"^",3))
if $GET(IBR(0))["Done"
QUIT
HANG 2
+25 ; if done get data.
+26 IF $GET(IBR(0))["Done"
Begin DoDot:2
+27 KILL IBR,IBHERE
+28 DO RTNDATA^XWBDRPC(.IBHERE,$PIECE(IBTFL(IBX),"^",3))
+29 IF $DATA(IBHERE)>10
MERGE ^TMP("IBOMTLTC",$JOB,+$$LKUP^XUAF4(+IBTFL(IBX)))=IBHERE
+30 IF '$TEST
MERGE ^TMP("IBOMTLTC",$JOB,+$$LKUP^XUAF4(+IBTFL(IBX)))=^TMP($JOB,"XWB")
KILL ^TMP($JOB,"XWB")
+31 DO CLEAR^XWBDRPC(.IBZ,$PIECE(IBTFL(IBX),"^",3))
End DoDot:2
+32 IF '$TEST
SET ^TMP("IBOMTLTC",$JOB,+$$LKUP^XUAF4(+IBTFL(IBX)),0)="Unable to get remote information from this site."
End DoDot:1
+33 ;
+34 ; now that I have the info, time to print
+35 ;
+36 USE IO
SET (IBQ,IBP)=0
+37 SET IBS=0
FOR
SET IBS=$ORDER(^TMP("IBOMTLTC",$JOB,IBS))
if IBS<1!(IBQ)
QUIT
Begin DoDot:1
+38 SET IBS(0)=$$NNT^XUAF4(IBS)
+39 DO PAUSE(1)
+40 SET IBX=-1
FOR
SET IBX=$ORDER(^TMP("IBOMTLTC",$JOB,IBS,IBX))
if IBX=""!(IBQ)
QUIT
WRITE !,^(IBX)
DO PAUSE()
End DoDot:1
+41 ;
+42 IF 'IBQ
IF $EXTRACT(IOST,1,2)="C-"
KILL DIR
SET DIR(0)="E"
DO ^DIR
+43 ;
+44 DO ^%ZISC
+45 ;
+46 KILL ^TMP("IBOMTLTC",$JOB)
DO KVAR^VADPT
+47 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+48 ;
+49 QUIT
+50 ;
PAUSE(IBNEW) ;
+1 ; IBNEW = optional variable, it is a flag for new site
+2 ;
+3 NEW DIR,DIRUT,DIROUT,DTOUT,X,Y
+4 IF IBQ
QUIT
+5 IF $Y+6<IOSL
IF IBP
IF '$DATA(IBNEW)
QUIT
+6 IF IBP
IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
DO ^DIR
IF $DATA(DIRUT)
SET IBQ=1
QUIT
+7 SET IBP=IBP+1
+8 WRITE @IOF,!,"MT and LTC Copay Information ",$$FMTE^XLFDT(IBBDT)," to ",$$FMTE^XLFDT(IBEDT),?IOM-15,"Page: ",IBP
+9 WRITE !,"Patient: ",VADM(1)," (",$PIECE(VADM(2),"-",3),") For Site: ",$PIECE(IBS(0),"^")," (",$PIECE(IBS(0),"^",2),")",!
+10 FOR X=1:1:IOM
WRITE "-"
+11 QUIT
+12 ;
RETURN(IBR,IBICN,DFN,IBBDT,IBEDT) ;
+1 ; this is called from the main query for local data and from the remote
+2 ; procedure IBO MT LTC COPAY QUERY for remote data. The return is
+3 ; in a global array.
+4 ; if DFN then that will be used to identify the patient
+5 ; if no DFN, then the ICN (ibicn) needs to be there to identify patient
+6 ;
+7 NEW IBA,IBX,IBT,IBZ,IBL,IBS,IBF,IBFRDT,Y,Y1,IBD,IBSTAT,IBTYP,IBAX,IBCHG
+8 ;
+9 IF '$DATA(IBR)
SET IBR=$NAME(^TMP("IBOMTLTC",$JOB))
+10 ;
+11 SET IBL=0
+12 IF '$GET(DFN)
SET DFN=+$$DFN^IBARXMU($GET(IBICN))
IF 'DFN
SET @IBR@(1)="-1^Patient not found"
QUIT
+13 ;
+14 ; look for MT clocks and get info
+15 SET IBX=0
FOR
SET IBX=$ORDER(^IBE(351,"C",DFN,IBX))
if 'IBX
QUIT
Begin DoDot:1
+16 SET IBZ=^IBE(351,IBX,0)
+17 IF '$PIECE(IBZ,"^",10)
SET $PIECE(IBZ,"^",10)=$$FMADD^XLFDT($PIECE(IBZ,"^",3),364)
+18 IF $PIECE(IBZ,"^",3)>IBEDT!($PIECE(IBZ,"^",10)<IBBDT)
QUIT
+19 DO GETS^DIQ(351,IBX,".03:.1","ENR","IBT")
End DoDot:1
+20 ;
+21 ; look for LTC clocks and get info
+22 SET IBX=0
FOR
SET IBX=$ORDER(^IBA(351.81,"C",DFN,IBX))
if 'IBX
QUIT
Begin DoDot:1
+23 SET IBZ=^IBA(351.81,IBX,0)
+24 IF $PIECE(IBZ,"^",3)>IBEDT
IF $PIECE(IBZ,"^",4)>IBBDT
QUIT
+25 DO GETS^DIQ(351.81,IBX,".03:.06","ENR","IBT")
+26 ; get the free days (store in date order with a "[" flag)
+27 SET IBF=0
FOR
SET IBF=$ORDER(^IBA(351.81,IBX,1,IBF))
if IBF<1
QUIT
SET IBFRDT=$PIECE(^IBA(351.81,IBX,1,IBF,0),"^",2)
SET IBT(351.81,IBX_",","["_IBFRDT_"EXEMPT DATE","E")=$$FMTE^XLFDT(IBFRDT)
End DoDot:1
+28 ;
+29 ; move the data to return area
+30 FOR IBF=351,351.81,351.811
SET IBX=""
FOR
SET IBX=$ORDER(IBT(IBF,IBX))
if IBX=""
QUIT
DO SPACE($SELECT(IBF=351:"MT",1:"LTC")_" Billing Clock")
SET IBA=""
FOR
SET IBA=$ORDER(IBT(IBF,IBX,IBA))
if IBA=""
QUIT
Begin DoDot:1
+31 IF $LENGTH(@IBR@(IBL))>40!($LENGTH(IBA_": "_IBT(IBF,IBX,IBA,"E"))>40)
SET IBL=IBL+1
SET @IBR@(IBL)=$SELECT($EXTRACT(IBA)="[":$EXTRACT(IBA,9,99),1:IBA)_": "_IBT(IBF,IBX,IBA,"E")
QUIT
+32 SET IBS=""
SET $PIECE(IBS," ",40-$LENGTH(@IBR@(IBL)))=""
SET @IBR@(IBL)=@IBR@(IBL)_IBS_$SELECT($EXTRACT(IBA)="[":$EXTRACT(IBA,9,99),1:IBA)_": "_IBT(IBF,IBX,IBA,"E")
End DoDot:1
+33 ;
+34 ; get billing info from 350
+35 ; first find the charges and sort
+36 KILL ^TMP("IBECEA",$JOB)
+37 SET Y=""
FOR
SET Y=$ORDER(^IB("AFDT",DFN,Y))
if 'Y
QUIT
IF -Y'>IBEDT
SET Y1=0
FOR
SET Y1=$ORDER(^IB("AFDT",DFN,Y,Y1))
if 'Y1
QUIT
Begin DoDot:1
+38 SET IBX=0
FOR
SET IBX=$ORDER(^IB("AF",Y1,IBX))
if 'IBX
QUIT
Begin DoDot:2
+39 if '$DATA(^IB(IBX,0))
QUIT
SET IBZ=^(0)
+40 if $PIECE(IBZ,"^",8)["ADMISSION"
QUIT
+41 IF $PIECE(IBZ,"^",15)<IBBDT!($PIECE(IBZ,"^",14)>IBEDT)
QUIT
+42 SET ^TMP("IBECEA",$JOB,+$PIECE(IBZ,"^",14),IBX)=""
End DoDot:2
End DoDot:1
+43 ;
+44 SET Y=0
FOR
SET Y=$ORDER(^IB("ACVA",DFN,Y))
if 'Y
QUIT
IF Y'>IBEDT
SET Y1=0
FOR
SET Y1=$ORDER(^IB("ACVA",DFN,Y,Y1))
if 'Y1
QUIT
Begin DoDot:1
+45 SET IBX=0
FOR
SET IBX=$ORDER(^IB("AD",Y1,IBX))
if 'IBX
QUIT
Begin DoDot:2
+46 if '$DATA(^IB(IBX,0))
QUIT
SET IBZ=^(0)
+47 IF $PIECE(IBZ,"^",15)<IBBDT!($PIECE(IBZ,"^",14)>IBEDT)
QUIT
+48 SET ^TMP("IBECEA",$JOB,Y,IBX)=""
End DoDot:2
End DoDot:1
+49 ;
+50 ; now store for return
+51 DO SPACE("Patient Charges")
+52 IF $DATA(^TMP("IBECEA",$JOB))
SET IBL=IBL+1
SET @IBR@(IBL)="Bill From Bill To Charge Type Stop Bill # Status Charge"
+53 SET IBD=""
FOR
SET IBD=$ORDER(^TMP("IBECEA",$JOB,IBD))
if 'IBD
QUIT
Begin DoDot:1
+54 SET IBX=""
FOR
SET IBX=$ORDER(^TMP("IBECEA",$JOB,IBD,IBX))
if 'IBX
QUIT
Begin DoDot:2
+55 SET IBZ=^IB(IBX,0)
if $PIECE(IBZ,"^",7)=""
QUIT
+56 SET IBL=IBL+1
+57 SET IBSTAT=$$EXTERNAL^DILFD(350,.05,"",$PIECE(IBZ,"^",5))
+58 SET IBATYP=$PIECE($GET(^IBE(350.1,+$PIECE(IBZ,"^",3),0)),"^")
+59 if $EXTRACT(IBATYP,1,2)="DG"
SET IBATYP=$EXTRACT(IBATYP,4,99)
+60 ; if ouptatient charge and clinic stop, show it
+61 IF $EXTRACT(IBATYP,1,3)="OPT"
IF $PIECE(IBZ,"^",20)
SET IBATYP=$EXTRACT(IBATYP_" ",1,21)_" "_$PIECE($GET(^IBE(352.5,+$PIECE(IBZ,"^",20),0)),"^")
+62 SET IBCHG=$SELECT(IBATYP["CANCEL":"(",1:" ")_"$"_$PIECE(IBZ,"^",7)_$SELECT(IBATYP["CANCEL":")",1:"")
+63 SET IBAX=$$SETSTR^VALM1($$DAT1^IBOUTL(IBD),"",1,9)
+64 SET IBAX=$$SETSTR^VALM1($$DAT1^IBOUTL($SELECT($PIECE(IBZ,"^",8)["RX COPAY":IBD,1:$PIECE(IBZ,"^",15))),IBAX,12,8)
+65 SET IBAX=$$SETSTR^VALM1(IBATYP,IBAX,22,26)
+66 SET IBAX=$$SETSTR^VALM1($PIECE($PIECE(IBZ,"^",11),"-",2),IBAX,49,8)
+67 SET IBAX=$$SETSTR^VALM1(IBSTAT,IBAX,58,12)
+68 SET IBAX=$$SETSTR^VALM1(IBCHG,IBAX,71,9)
+69 SET @IBR@(IBL)=IBAX
End DoDot:2
End DoDot:1
+70 IF '$DATA(IBAX)
SET @IBR@(IBL+1)=" "
SET @IBR@(IBL+2)="No charges meet criteria"
+71 KILL ^TMP("IBECEA",$JOB)
+72 ;
+73 QUIT
+74 ;
SPACE(IBTEXT) ; spaces out return info (sub-header info)
+1 SET IBL=IBL+1
SET @IBR@(IBL)=""
SET IBL=IBL+1
SET $PIECE(@IBR@(IBL),"-",80)=""
+2 SET IBL=IBL+1
SET $PIECE(@IBR@(IBL)," ",80-$LENGTH(IBTEXT)/2)=IBTEXT
+3 QUIT
+4 ;
