- 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 Mar 13, 2025@21:30:55 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 ;
