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

Last change on this file since 1572 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 7.0 KB
Line 
1IBOMTLTC ;OAKOIFO/ELZ-MT/LTC COPAY REMOTE QUERY ;20-AUG-2002
2 ;;2.0;INTEGRATED BILLING;**188**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5QUERY ; main entry point for user to request a query of mt and ltc copay info
6 ;
7 N IBBDT,IBEDT,DIC,DFN,X,Y,IBT,DIR,DTOUT,DUOUT,DIRUT,DIROUT,IBICN,IBTFL,%ZIS,ZTDESC,ZTREQ,ZTRTN,ZTSAVE,POP
8 ;
9 S DIC="^DPT(",DIC(0)="AEMNQ" D ^DIC Q:Y<1 S DFN=+Y
10 ;
11 D DATE^IBOUTL Q:IBEDT<1
12 ;
13 S IBT=$$TFL^IBARXMU(DFN,.IBTFL)
14 S IBICN=$$ICN^IBARXMU(DFN) I 'IBICN,IBT W !,"There is no ICN for this patient." K IBTFL S IBT=0
15 ;
16 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
17 ;
18 I 'IBT W !!,"Performing query locally only" W:$D(IBTFL)>9 "." I $D(IBTFL)<10 W ", the patient has no remote facilities."
19 ;
20 S %ZIS="MQ" D ^%ZIS Q:POP
21 I $D(IO("Q")) D Q
22 . S ZTRTN="DQ^IBOMTLTC",ZTDESC="MT/LTC COPAY REMOTE QUERY"
23 . S (ZTSAVE("DFN"),ZTSAVE("IB*"))="" D ^%ZTLOAD,HOME^%ZIS K IO("Q")
24 ;
25DQ ; tasked entry point
26 N IBS,IBX,IBH,IBQ,IBC,IBP,IBHERE
27 K ^TMP("IBOMTLTC",$J)
28 ;
29 ; data will be gathered in ^tmp("ibomtltc",$j,site,n) nodes in final
30 ; output format. (where site is the internal value from file 4 locally)
31 ;
32 S IBS=+$$SITE^VASITE ; store the internal value for file 4
33 D DEM^VADPT
34 ;
35 ; send off queries (if needed)
36 I IBT S IBX=0 F S IBX=$O(IBTFL(IBX)) Q:IBX<1 D
37 . ;
38 . W:'$D(ZTQUEUED) !,"Now sending query to ",$P(IBTFL(IBX),"^",2)," ..."
39 . D EN1^XWB2HL7(.IBH,+IBTFL(IBX),"IBO MT LTC COPAY QUERY","",IBICN,"",IBBDT,IBEDT)
40 . I $G(IBH(0))="" S IBR="-1^No handle returned from RPC" Q
41 . S $P(IBTFL(IBX),"^",3)=IBH(0) ; save handle for later.
42 ;
43 ; now while waiting for remote stuff, let's do local stuff.
44 D RETURN($NA(^TMP("IBOMTLTC",$J,IBS)),"",DFN,IBBDT,IBEDT)
45 ;
46 ; now lets look for the remote data
47 I IBT S IBX=0 F S IBX=$O(IBTFL(IBX)) Q:IBX<1 D
48 . ;
49 . F IBC=1:1:10 D RPCCHK^XWB2HL7(.IBR,$P(IBTFL(IBX),"^",3)) Q:$G(IBR(0))["Done" H 2
50 . ; if done get data.
51 . I $G(IBR(0))["Done" D
52 .. K IBR,IBHERE
53 .. D RTNDATA^XWBDRPC(.IBHERE,$P(IBTFL(IBX),"^",3))
54 .. I $D(IBHERE)>10 M ^TMP("IBOMTLTC",$J,+$$LKUP^XUAF4(+IBTFL(IBX)))=IBHERE
55 .. E M ^TMP("IBOMTLTC",$J,+$$LKUP^XUAF4(+IBTFL(IBX)))=^TMP($J,"XWB") K ^TMP($J,"XWB")
56 .. D CLEAR^XWBDRPC(.IBZ,$P(IBTFL(IBX),"^",3))
57 . E S ^TMP("IBOMTLTC",$J,+$$LKUP^XUAF4(+IBTFL(IBX)),0)="Unable to get remote information from this site."
58 ;
59 ; now that I have the info, time to print
60 ;
61 U IO S (IBQ,IBP)=0
62 S IBS=0 F S IBS=$O(^TMP("IBOMTLTC",$J,IBS)) Q:IBS<1!(IBQ) D
63 . S IBS(0)=$$NNT^XUAF4(IBS)
64 . D PAUSE(1)
65 . S IBX=-1 F S IBX=$O(^TMP("IBOMTLTC",$J,IBS,IBX)) Q:IBX=""!(IBQ) W !,^(IBX) D PAUSE()
66 ;
67 I 'IBQ,$E(IOST,1,2)="C-" K DIR S DIR(0)="E" D ^DIR
68 ;
69 D ^%ZISC
70 ;
71 K ^TMP("IBOMTLTC",$J) D KVAR^VADPT
72 S:$D(ZTQUEUED) ZTREQ="@"
73 ;
74 Q
75 ;
76PAUSE(IBNEW) ;
77 ; IBNEW = optional variable, it is a flag for new site
78 ;
79 N DIR,DIRUT,DIROUT,DTOUT,X,Y
80 I IBQ Q
81 I $Y+6<IOSL,IBP,'$D(IBNEW) Q
82 I IBP,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR I $D(DIRUT) S IBQ=1 Q
83 S IBP=IBP+1
84 W @IOF,!,"MT and LTC Copay Information ",$$FMTE^XLFDT(IBBDT)," to ",$$FMTE^XLFDT(IBEDT),?IOM-15,"Page: ",IBP
85 W !,"Patient: ",VADM(1)," (",$P(VADM(2),"-",3),") For Site: ",$P(IBS(0),"^")," (",$P(IBS(0),"^",2),")",!
86 F X=1:1:IOM W "-"
87 Q
88 ;
89RETURN(IBR,IBICN,DFN,IBBDT,IBEDT) ;
90 ; this is called from the main query for local data and from the remote
91 ; procedure IBO MT LTC COPAY QUERY for remote data. The return is
92 ; in a global array.
93 ; if DFN then that will be used to identify the patient
94 ; if no DFN, then the ICN (ibicn) needs to be there to identify patient
95 ;
96 N IBA,IBX,IBT,IBZ,IBL,IBS,IBF,IBFRDT,Y,Y1,IBD,IBSTAT,IBTYP,IBAX,IBCHG
97 ;
98 I '$D(IBR) S IBR=$NA(^TMP("IBOMTLTC",$J))
99 ;
100 S IBL=0
101 I '$G(DFN) S DFN=+$$DFN^IBARXMU($G(IBICN)) I 'DFN S @IBR@(1)="-1^Patient not found" Q
102 ;
103 ; look for MT clocks and get info
104 S IBX=0 F S IBX=$O(^IBE(351,"C",DFN,IBX)) Q:'IBX D
105 . S IBZ=^IBE(351,IBX,0)
106 . I '$P(IBZ,"^",10) S $P(IBZ,"^",10)=$$FMADD^XLFDT($P(IBZ,"^",3),364)
107 . I $P(IBZ,"^",3)>IBEDT!($P(IBZ,"^",10)<IBBDT) Q
108 . D GETS^DIQ(351,IBX,".03:.1","ENR","IBT")
109 ;
110 ; look for LTC clocks and get info
111 S IBX=0 F S IBX=$O(^IBA(351.81,"C",DFN,IBX)) Q:'IBX D
112 . S IBZ=^IBA(351.81,IBX,0)
113 . I $P(IBZ,"^",3)>IBEDT,$P(IBZ,"^",4)>IBBDT Q
114 . D GETS^DIQ(351.81,IBX,".03:.06","ENR","IBT")
115 . ; get the free days (store in date order with a "[" flag)
116 . 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)
117 ;
118 ; move the data to return area
119 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
120 . 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
121 . 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")
122 ;
123 ; get billing info from 350
124 ; first find the charges and sort
125 K ^TMP("IBECEA",$J)
126 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
127 . S IBX=0 F S IBX=$O(^IB("AF",Y1,IBX)) Q:'IBX D
128 .. Q:'$D(^IB(IBX,0)) S IBZ=^(0)
129 .. Q:$P(IBZ,"^",8)["ADMISSION"
130 .. I $P(IBZ,"^",15)<IBBDT!($P(IBZ,"^",14)>IBEDT) Q
131 .. S ^TMP("IBECEA",$J,+$P(IBZ,"^",14),IBX)=""
132 ;
133 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
134 . S IBX=0 F S IBX=$O(^IB("AD",Y1,IBX)) Q:'IBX D
135 .. Q:'$D(^IB(IBX,0)) S IBZ=^(0)
136 .. I $P(IBZ,"^",15)<IBBDT!($P(IBZ,"^",14)>IBEDT) Q
137 .. S ^TMP("IBECEA",$J,Y,IBX)=""
138 ;
139 ; now store for return
140 D SPACE("Patient Charges")
141 I $D(^TMP("IBECEA",$J)) S IBL=IBL+1,@IBR@(IBL)="Bill From Bill To Charge Type Stop Bill # Status Charge"
142 S IBD="" F S IBD=$O(^TMP("IBECEA",$J,IBD)) Q:'IBD D
143 . S IBX="" F S IBX=$O(^TMP("IBECEA",$J,IBD,IBX)) Q:'IBX D
144 .. S IBZ=^IB(IBX,0) Q:$P(IBZ,"^",7)=""
145 .. S IBL=IBL+1
146 .. S IBSTAT=$$EXTERNAL^DILFD(350,.05,"",$P(IBZ,"^",5))
147 .. S IBATYP=$P($G(^IBE(350.1,+$P(IBZ,"^",3),0)),"^")
148 .. S:$E(IBATYP,1,2)="DG" IBATYP=$E(IBATYP,4,99)
149 .. ; if ouptatient charge and clinic stop, show it
150 .. I $E(IBATYP,1,3)="OPT",$P(IBZ,"^",20) S IBATYP=$E(IBATYP_" ",1,21)_" "_$P($G(^IBE(352.5,+$P(IBZ,"^",20),0)),"^")
151 .. S IBCHG=$S(IBATYP["CANCEL":"(",1:" ")_"$"_$P(IBZ,"^",7)_$S(IBATYP["CANCEL":")",1:"")
152 .. S IBAX=$$SETSTR^VALM1($$DAT1^IBOUTL(IBD),"",1,9)
153 .. S IBAX=$$SETSTR^VALM1($$DAT1^IBOUTL($S($P(IBZ,"^",8)["RX COPAY":IBD,1:$P(IBZ,"^",15))),IBAX,12,8)
154 .. S IBAX=$$SETSTR^VALM1(IBATYP,IBAX,22,26)
155 .. S IBAX=$$SETSTR^VALM1($P($P(IBZ,"^",11),"-",2),IBAX,49,8)
156 .. S IBAX=$$SETSTR^VALM1(IBSTAT,IBAX,58,12)
157 .. S IBAX=$$SETSTR^VALM1(IBCHG,IBAX,71,9)
158 .. S @IBR@(IBL)=IBAX
159 I '$D(IBAX) S @IBR@(IBL+1)=" ",@IBR@(IBL+2)="No charges meet criteria"
160 K ^TMP("IBECEA",$J)
161 ;
162 Q
163 ;
164SPACE(IBTEXT) ; spaces out return info (sub-header info)
165 S IBL=IBL+1,@IBR@(IBL)="",IBL=IBL+1,$P(@IBR@(IBL),"-",80)=""
166 S IBL=IBL+1,$P(@IBR@(IBL)," ",80-$L(IBTEXT)/2)=IBTEXT
167 Q
168 ;
Note: See TracBrowser for help on using the repository browser.