source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBOMTLTC.m@ 1147

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
 ;