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

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

initial load of WorldVistAEHR

File size: 5.4 KB
RevLine 
[613]1IBCROE ;OAK/ELZ - CHARGE MASTER TO EXCEL OUTPUT ;28-NOV-2005
2 ;;2.0;INTEGRATED BILLING;**308**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; This routine will produce output from Charge Master for the local site in a format that can be imported
6 ; into excel.
7 ;
8 ; load an Inpatient and a Non-Provider based site for same zip code first
9 ;
10 ;
11EN ; main option entry point
12 N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,IBRCVER,IBZIP,POP,%ZIS,IBVERS,ZTRTN,ZTDESC,ZTSAVE,ZTSK
13 ;
14 ;find zip code for extraction
15 S DIR(0)="F^3:3^K:X'?3N X",DIR("A")="Enter a 3 digit zip identifier"
16 S DIR("?")="Enter the first 3 digits of a zip code for which you want to extract data." D ^DIR Q:$D(DIRUT)
17 S IBZIP=Y
18 ;
19 S IBVERS=$$SELVERS Q:'IBVERS
20 ;
21 ; find out where to write output
22 W !!,"Select where you would like the output. This will be very large and you",!,"should select either a Host File Server (HFS) printer or Current Terminal",!,"(screen capture) to save the output to a file."
23 S %ZIS="QM" D ^%ZIS Q:POP
24 I $D(IO("Q")) D Q
25 . S ZTRTN="DQ^IBCROE",ZTDESC="IB Reasonable Charges Extract"
26 . S (ZTSAVE("IBZIP"),ZTSAVE("IBVERS"))=""
27 . D ^%ZTLOAD D HOME^%ZIS K IO("Q") W !,"QUEUED TASK #",ZTSK
28 ;
29 ;
30DQ ; tasked entry point
31 U IO D EXCEL(IBZIP,IBVERS)
32 ;
33 ;
34 D ^%ZISC
35 S:$D(ZTQUEUED) ZTREQ="@"
36 I '$D(ZTQUEUED) D HOME^%ZIS W !,"Done!"
37 ;
38 ;
39 Q
40 ;
41SELVERS() ; get version to extract from user
42 N DIR,DIRUT,DTOUT,DUOUT,X,Y,IB,IBV,IBVP,IBX,IBVL
43 ; use primary site to list and remove prior to version 2.0 as choices
44 S IBVL=$$VERSITE^IBCRHBRV($P($$SITE^VASITE,"^",3)),IBV=""
45 F X=1:1 Q:'$P(IBVL,",",X) S:$P(IBVL,",",X)>1.9 IBV=IBV_$S($L($P(IBVL,",",X))>2:$P(IBVL,",",X),1:$P(IBVL,",",X)_".0")_"^"
46 S IBV=$E(IBV,1,$L(IBV)-1)
47 S IBX=0
48 W !!,"Select the version of Reasonable Charges to extract.",!
49 S DIR("?")="Enter a code from the list corresponding to the version of Reasonable Charges to upload. Must be version 2.0 or greater. There was no version 2.2 of Reasonable Charges."
50 S DIR(0)="SO^"
51 F IB=1:1:$L(IBV,U) S IBVP=$P(IBV,U,IB),DIR(0)=DIR(0)_+IBVP_":RC version "_IBVP_" eff "_$$FMTE^XLFDT($$VERSDT^IBCRHBRV(+IBVP),"2Z")_" inact "_$$FMTE^XLFDT($$VERSEDT^IBCRHBRV(+IBVP),"2Z")_";"
52 D ^DIR K DIR S:$L(Y)=1 Y=Y_".0" S IBX=+$S(IBV[Y:Y,1:0)
53 Q IBX
54 ;
55 ;
56 ; call at EXEL with zip and version, will print to host file the calculated charges by type
57EXCEL(ZIP,VERS) ;
58 N IB2,IB3,IBZ,COL,IBBI,IBBR,IBBR0,IBCHG,IBCI,IBCI0,IBCM,IBCNT,IBCPT,IBCS,IBCS0,IBCSNM,IBCT,IBDV,IBLNZ,IBMOD,IBMODI,IBNAME,IBPB,IBRG,IBRG0,Z
59 K ^TMP("IBCROE",$J)
60 S IBCNT=0
61 ;
62 S IBCS=0 F S IBCS=$O(^IBE(363.1,IBCS)) Q:'IBCS D
63 . S IBCS0=$G(^IBE(363.1,IBCS,0))
64 . ;
65 . S IBCSNM=$P(IBCS0,U,1) Q:$E(IBCSNM,1,3)'="RC-"
66 . S IBBR=+$P(IBCS0,U,2),IBBR0=$G(^IBE(363.3,IBBR,0))
67 . S IBRG=+$P(IBCS0,U,7),IBRG0=$G(^IBE(363.31,IBRG,0)),IBDV=$P(IBRG0," ",2)
68 . ;
69 . I $P(IBRG0,U,2)'=ZIP Q
70 . ;
71 . S IBBI=$$EXPAND^IBCRU1(363.3,.04,$P(IBBR0,U,4))
72 . S IBCT=$S(IBBR0["FACILITY":"FACILITY",IBBR0["PHYSICIAN":"PHYSICIAN",1:$P(IBBR0,U,1))
73 . ;
74 . I IBBI["MISC",IBCSNM'["SNF" S COL=2,IBNAME="Partial Hospitalization"
75 . I IBBI["MISC",IBCSNM["SKILLED" S COL=1,IBNAME="Skilled Nursing"
76 . I IBBI="DRG",IBCSNM["ANC" S COL=1,IBNAME="Inpatient Anc" I IBCSNM["ICU" S COL=COL+1,IBNAME=IBNAME_" ICU"
77 . I IBBI="DRG",IBCSNM["R&B" S COL=3,IBNAME="Inpatient R&B" I IBCSNM["ICU" S COL=COL+1,IBNAME=IBNAME_" ICU"
78 . ;
79 . I IBBI="CPT",IBCSNM["INPT" S COL=1,IBNAME="Inpatient Facility" I IBCT="PHYSICIAN" S COL=COL+1,IBNAME="Inpatient Physician"
80 . I IBBI="CPT",IBCSNM["SNF" S COL=3,IBNAME="SNF Facility" I IBCT="PHYSICIAN" S COL=COL+1,IBNAME="SNF Physician"
81 . I IBBI="CPT",IBCSNM["OPT" S COL=5,IBNAME="Outpatient Facility" I IBCT="PHYSICIAN" S COL=COL+1,IBNAME="Outpatient Physician"
82 . I IBBI="CPT",IBCSNM["FS" S COL=7,IBNAME="Freestanding Physician"
83 . ;
84 . S IBPB=$P(IBRG0,U,3),IBPB=$S(IBPB=1:"VAMC Provider Based",IBPB=2:"Opt Provider Based",IBPB=3:"Non-Provider Based",1:"Provider Based Unknown")
85 . ;
86 . S IBCM=$P(IBBR0,U,5),IBCM=$S(IBCM=4:"ml",IBCM=5:"mn+",IBCM=6:"hr+",1:"")
87 . ;
88 . S IB2(IBCS)=IBBI_U_COL_U_IBNAME_U_IBDV_U_IBPB_U_IBCM
89 . S $P(IB3(IBBI),U,COL)=IBNAME_" "_IBDV_" "_IBPB
90 . ;
91 . S IBCNT=IBCNT+1 I IBCNT#1000=0,'$D(ZTQUEUED) U IO(0) W "." U IO
92 ;
93ITEMS ;
94 S IBBI="" F S IBBI=$O(IB3(IBBI)) Q:IBBI="" S ^TMP("IBCROE",$J,IBBI)="Item^Modifier^"_IB3(IBBI)
95 ;
96 S IBCI=0 F S IBCI=$O(^IBA(363.2,IBCI)) Q:'IBCI D
97 . S IBCI0=^IBA(363.2,IBCI,0),IBCSNM=$P($G(^IBE(363.1,+$P(IBCI0,U,2),0)),U,1) Q:IBCSNM=""
98 . S IBLNZ=$G(IB2($P(IBCI0,U,2))) I IBLNZ="" S IBZ("NOT DONE ",IBCSNM)="" Q
99 . S IBZ("DONE",IBCSNM)=""
100 . ;
101 . Q:$P(IBCI0,U,3)'=$$VERSDT^IBCRHBRV(VERS)
102 . ;
103 . S IBCHG=$P(IBCI0,U,5)_$P(IBLNZ,U,6)_$P(IBCI0,U,8)
104 . S IBMOD=$P(IBCI0,U,7) I IBMOD'="" S IBMOD=$P($$MOD^ICPTMOD(IBMOD,"I"),U,2)
105 . I IBMOD="" S IBMOD=0
106 . S IBCPT=$$EXPAND^IBCRU1(363.2,.01,$P(IBCI0,U,1))
107 . ;
108 . S IBBI=$P(IBLNZ,U,1)
109 . S COL=$P(IBLNZ,U,2)
110 . I $P($G(^TMP("IBCROE",$J,IBBI,IBCPT,IBMOD)),U,COL)'="" Q ;DUP
111 . S $P(^TMP("IBCROE",$J,IBBI,IBCPT,IBMOD),U,COL)=IBCHG
112 . ;
113 . S IBCNT=IBCNT+1 I IBCNT#1000=0,'$D(ZTQUEUED) U IO(0) W "." U IO
114 ;
115 ;
116 D WRT
117 K ^TMP("IBCROE",$J)
118 Q
119WRT ;
120 S IBBI="" F S IBBI=$O(^TMP("IBCROE",$J,IBBI)) Q:IBBI="" D
121 . W !,^TMP("IBCROE",$J,IBBI)
122 . S IBCPT="" F S IBCPT=$O(^TMP("IBCROE",$J,IBBI,IBCPT)) Q:IBCPT="" D
123 .. S IBMOD="" F S IBMOD=$O(^TMP("IBCROE",$J,IBBI,IBCPT,IBMOD)) Q:IBMOD="" D
124 ... S IBMODI=IBMOD I IBMOD=0 S IBMODI=""
125 ... W !,IBCPT,U,IBMODI,U,^TMP("IBCROE",$J,IBBI,IBCPT,IBMOD)
126 ... S IBCNT=IBCNT+1 I IBCNT#1000=0,'$D(ZTQUEUED),$E(IOST,1,2)'="C-" U IO(0) W "." U IO
127 Q
Note: See TracBrowser for help on using the repository browser.