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

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

initial load of WorldVistAEHR
File size: 8.3 KB
Line 
1IBTUTL1 ;ALB/AAS - CLAIMS TRACKING UTILITY ROUTINE ;21-JUN-93
2 ;;2.0;INTEGRATED BILLING;**13,223,249,292**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5OPT(DFN,IBETYP,IBTDT,ENCTR,IBRMARK,IBVSIT) ; -- add outpatient care entries
6 ; -- input dfn := patient pointer to 2
7 ; ibetyp := pointer to type entry in 356.6
8 ; ibtdt := episode date
9 ; enctr := pointer to opt. encounter file (optional)
10 ; ibrmark := text of reason not billable (optional)
11 ; ibvsit := pointer to visit file (optional)
12 ;
13 N X,Y,DA,DR,DIE,DIC,IBSCRN
14 S IBSCRN=0
15 ;Allow user inter-actions if not queued and IBTALK=1 or not exist.
16 I '$D(ZTQUEUED) D I IBSCRN G OPTSCRN
17 . I $D(IBTALK),'$G(IBTALK) Q
18 . I IBTDT<3060101 Q ;Don't use new code for claims prior to 1/1/2006
19 . S IBSCRN=1
20 I $G(IBETYP) S IBETYP=$O(^IBE(356.6,"AC",2,0))
21 I IBTDT<3060101 S X=$O(^IBT(356,"APTY",DFN,IBETYP,IBTDT,0)) I X S IBTRN=X G OPTQ ;Prevent duplicate date/time claims prior to 1/1/2006
22 ;Check for encounter already in claims tracking.
23 I $D(ENCTR),$D(^IBT(356,"AENC",+DFN,+ENCTR)) S IBTRN=$O(^IBT(356,"AENC",+DFN,+ENCTR,0)) G OPTQ
24 D ADDT^IBTUTL
25 S DA=IBTRN,DIE="^IBT(356,"
26 I IBTRN<1 G OPTQ
27 L +^IBT(356,+IBTRN):10 I '$T G OPTQ
28 S DR=".02////"_$G(DFN)_";.03////"_$G(IBVSIT)_";.04////"_$G(ENCTR)_";.06////"_+IBTDT_";.18////"_IBETYP_";.2////1;.24////"_$$INSURED^IBCNS1(DFN)_";1.01///NOW;1.02////"_DUZ_";.17////"_$$EABD^IBTUTL(IBETYP)
29 I $G(IBRMARK)'="" S DR=DR_";.19///"_IBRMARK
30 D ^DIE K DA,DR,DIE
31 L -^IBT(356,+IBTRN)
32OPTQ Q
33 ;
34REFILL(DFN,IBETYP,IBTDT,IBRXN,IBRXN1,IBRMARK,IBEABD) ; -- add refill
35 ; -- input dfn := patient pointer to 2
36 ; ibetyp := pointer to type entry in 356.6
37 ; ibtdt := episode date (refill date)
38 ; ibrxn := pointer to 52
39 ; ibrxn1 := refill multiple entry
40 ; ibrmark := non billable reason if unsure
41 ; ibeabd := optional, can specify an earliest auto bill date
42 ;
43 N X,Y,DA,DR,DIE,DIC
44 ;S X=$O(^IBT(356,"APTY",DFN,IBETYP,IBTDT,0)) I X S IBTRN=X G REFILLQ
45 S X=$O(^IBT(356,"ARXFL",IBRXN,IBRXN1,0)) I X S IBTRN=X G REFILLQ
46 D ADDT^IBTUTL
47 I IBTRN<1 G REFILLQ
48 S DA=IBTRN,DIE="^IBT(356,"
49 L +^IBT(356,+IBTRN):10 I '$T G REFILLQ
50 S DR=".02////"_$G(DFN)_";.06////"_+IBTDT_";.08////"_IBRXN_";.1////"_IBRXN1_";.18////"_IBETYP_";.2////1;.24////"_$$INSURED^IBCNS1(DFN)_";1.01///NOW;1.02////"_$S($G(IBDUZ):IBDUZ,1:DUZ)_";.17////"_$S($G(IBEABD):IBEABD,1:$$EABD^IBTUTL(IBETYP))
51 I $G(IBRMARK)'="" S DR=DR_";.19///"_IBRMARK
52 D ^DIE K DA,DR,DIE
53 L -^IBT(356,+IBTRN)
54REFILLQ Q
55 ;
56PRO(DFN,IBTDT,IBPRO,IBRMARK) ; -- add prosthetic entries
57 ; -- input dfn := patient pointer to 2
58 ; ibetyp := pointer to type entry in 356.6
59 ; ibtdt := episode date
60 ;
61 N X,Y,DA,DR,DIE,DIC,IBETYP
62 ;S IBETYP=$O(^IBE(356.6,"ACODE",4,0))
63 S IBETYP=$O(^IBE(356.6,"AC",3,0)) ;prosthetics type
64 S X=$O(^IBT(356,"APRO",IBPRO,0)) I X S IBTRN=X G PROQ
65 D ADDT^IBTUTL
66 I IBTRN<1 G PROQ
67 S DA=IBTRN,DIE="^IBT(356,"
68 L +^IBT(356,+IBTRN):10 I '$T G PROQ
69 S DR=".02////"_$G(DFN)_";.06////"_+IBTDT_";.09////"_IBPRO_";.18////"_IBETYP_";.2////1;.24////"_$$INSURED^IBCNS1(DFN)_";1.01///NOW;1.02////"_DUZ_";.17////"_$$EABD^IBTUTL(IBETYP)
70 I $G(IBRMARK)'="" S DR=DR_";.19///"_IBRMARK
71 D ^DIE K DA,DR,DIE
72 L -^IBT(356,+IBTRN)
73PROQ Q
74 ;
75PT(DFN) ; -- format patient name - last 4 for output
76 S Y="" I '$G(DFN) G PTQ
77 I '$D(VA("PID")) D PID^VADPT
78 S Y=$E($P($G(^DPT(DFN,0)),"^"),1,20)_" "_$E($G(^(0)),1)_VA("BID")
79PTQ Q Y
80 ;
81PRODATA(IBDA) ; -- return data from prosthetics file
82 N IBDA0,DA,DIC,DIE,DR
83 K IBRMPR ; only one array at a time
84 I '$G(IBDA) G PRODAQ
85 S IBDA0=$G(^RMPR(660,+IBDA,0))
86 G:IBDA0="" PRODAQ
87DIQ S DIC="^RMPR(660,",DR=".01;1:5;7;10;12:17;24"
88 S DIQ="IBRMPR",DIQ(0)="E",DA=IBDA
89 D EN^DIQ1
90PRODAQ Q
91 ;
92OPTSCRN ; -- add outpatient care entries with user feedback
93 ; called from OPT^IBTUTL1 which has following inputs
94 ; -- input dfn := patient pointer to 2
95 ; ibetyp := pointer to type entry in 356.6
96 ; ibtdt := episode date
97 ; enctr := pointer to opt. encounter file (optional)
98 ; ibrmark := text of reason not billable (optional)
99 ; ibvsit := pointer to visit file (optional)
100 ;
101 N CNT,DIR,DIROUT,DIRUT,DTOUT,DUOUT,IB3560,IBACT,IBDATE,IBENC,IBETYPNM
102 N IBID,IBPATNM,IBQUIT,LINE,TEMP,TMP
103 ;If encounter passed in already exists in claims Tracking, remove it.
104 I $D(ENCTR),$D(^IBT(356,"AENC",+DFN,+ENCTR)) S ENCTR=""
105 I $G(IBETYP) S IBETYP=$O(^IBE(356.6,"AC",2,0))
106 S IBQUIT=0
107 I $O(^IBT(356,"APTY",DFN,IBETYP,IBTDT,0)) D I X S IBTRN=X G OPTSCRNQ
108 . S (CNT,LINE)=1,(TEMP,TMP,X)=""
109 . S Y=IBTDT D DD^%DT S IBDATE=$E(Y_" ",1,18) S Y=""
110 . S TMP("DIMSG",LINE)=" ",LINE=LINE+1
111 . S TMP("DIMSG",LINE)=" ",LINE=LINE+1
112 . S TMP("DIMSG",LINE)="There are match(es) for the episode date you have entered:",LINE=LINE+1
113 . S TMP("DIMSG",LINE)=" ",LINE=LINE+1
114 . S TMP("DIMSG",LINE)=" EPISODE DATE PATIENT NAME CT ID TYPE ENCOUNTER ACTIVE",LINE=LINE+1
115 . S TMP("DIMSG",LINE)=" ------------ ------------ ----- ---- --------- ------",LINE=LINE+1
116 . S TMP("DIMSG",LINE)=" ",LINE=LINE+1
117 . F S X=$O(^IBT(356,"APTY",DFN,IBETYP,IBTDT,X)) Q:X="" D
118 .. S IB3560=$G(^IBT(356,X,0)) I IB3560="" Q
119 .. S IBID=$P($G(IB3560),U,1) S IBID=$S(IBID="":"ID_UNKNOWN",1:$E(IBID_" ",1,10))
120 .. S IBPATNM=$P($G(^DPT(DFN,0)),U,1) S IBPATNM=$S(IBPATNM="":"PATIENT_UNKNOWN",1:$E(IBPATNM_" ",1,15))
121 .. S IBENC=$P($G(IB3560),U,4) S IBENC=$S(IBENC="":"NONE ",1:$E(IBENC_" ",1,10))
122 .. S IBACT=$S($P($G(IB3560),U,20)=1:"YES",1:"NO ")
123 .. S IBETYPNM=$P($G(^IBE(356.6,IBETYP,0)),U,2) S IBETYPNM=$S(IBETYPNM="":"NONE ",1:$E(IBETYPNM_" ",1,8))
124 .. S TMP("DIMSG",LINE)=$E(CNT_" ",1,3)_IBDATE_" "_IBPATNM_" "_IBID_" "_IBETYPNM_" "_IBENC_" "_IBACT
125 .. S TEMP(CNT)=X_"^"_$TR(IBENC," ",""),CNT=CNT+1
126 .. S LINE=LINE+1
127 . I CNT>0 D
128 .. S TMP("DIMSG",LINE+1)=$E(CNT_" ",1,3)_"*** CREATE A NEW CLAIMS TRACKING ENTRY ***"
129 .. D MSG^DIALOG("WM",,,,"TMP")
130 .. S DIR(0)="NA^1:"_CNT_":0"
131 .. S DIR("A")="Select a Claims Tracking entry: "
132 .. S DIR("?",1)="Choose a Claims Tracking entry from the previous list to continue processing."
133 .. S DIR("?")="Valid responses are 1 thru "_CNT_" or ^ to exit."
134 .. D ^DIR
135 .. I ($G(DTOUT))!($G(DUOUT))!($G(DIRUT))!($G(DIROUT)) S IBQUIT=1
136 .. I Y>0 S X=+$G(TEMP(Y)) I +$P($G(TEMP(Y)),U,2)>0 S ENCTR=$P($G(TEMP(Y)),U,2)
137 I IBQUIT Q
138 I '$G(ENCTR) D
139 . N CNT,DIR,IBDATA,IBDATA1,IBDATA2,IBERR,IBMSG,IBSCRN,IBTMP,LINE,TMP,X
140 . N DIOUT,DIROUT,DTOUT,DUOUT
141 . S X(1)=IBTDT
142 . S IBSCRN="I $P($G(^(0)),U,2)="_DFN
143 . S IBMSG="IBTMP(""ENC"")"
144 . S IBERR="IBTMP(""ERR"")"
145 . D FIND^DIC(409.68,,,"PQX",.X,,"B",IBSCRN,,IBMSG,IBERR)
146 . I +IBTMP("ENC","DILIST",0)=0 S ENCTR="" Q
147 . S CNT=+IBTMP("ENC","DILIST",0)+1
148 . S (LINE,X)=0
149 . S TMP("DIMSG",LINE)=" ",LINE=LINE+1
150 . S TMP("DIMSG",LINE)=" ",LINE=LINE+1
151 . S TMP("DIMSG",LINE)=" ",LINE=LINE+1
152 . S TMP("DIMSG",LINE)="There are encounters for the episode date you have selected:",LINE=LINE+1
153 . S TMP("DIMSG",LINE)=" ",LINE=LINE+1
154 . F S X=$O(IBTMP("ENC","DILIST",X)) Q:X="" D
155 .. S LINE=LINE+1
156 .. S IBDATA1=$P($G(IBTMP("ENC","DILIST",X,0)),"^"_IBTDT,1)
157 .. S IBDATA2=$P($G(IBTMP("ENC","DILIST",X,0)),"^"_IBTDT,2)
158 .. S IBDATA=$TR(IBDATA1_IBDATA2,"^"," ")
159 .. S TMP("DIMSG",LINE)=$E(X_" ",1,4)_IBDATA
160 . S TMP("DIMSG",LINE+1)=$E(+IBTMP("ENC","DILIST",0)+1_" ",1,4)_"*** CREATE A NEW CLAIMS TRACKING ENTRY WITHOUT AN ENCOUNTER ***"
161 . D MSG^DIALOG("WM",,,,"TMP")
162 . S DIR(0)="NA^1:"_CNT_":0"
163 . S DIR("A")="Select an Encounter for the Claims Tracking entry: "
164 . S DIR("?",1)="Choose an Encounter from the previous list to continue processing."
165 . S DIR("?")="Valid responses are 1 thru "_CNT_" or ^ to exit."
166 . D ^DIR
167 . I ($G(DTOUT))!($G(DUOUT))!($G(DIRUT))!($G(DIROUT)) S IBQUIT=1
168 . I +$G(Y)<1 Q
169 . S ENCTR=+$G(IBTMP("ENC","DILIST",+Y,0)) I 'ENCTR Q
170 . I $D(^IBT(356,"AENC",+DFN,ENCTR)) S IBTRN=$O(^IBT(356,"AENC",+DFN,ENCTR,0)) Q
171 I IBQUIT Q
172 G:$G(IBTRN)'="" OPTSCRNQ
173 D ADDT^IBTUTL
174 S DA=IBTRN,DIE="^IBT(356,"
175 I IBTRN<1 G OPTSCRNQ
176 L +^IBT(356,+IBTRN):10 I '$T G OPTSCRNQ
177 S DR=".02////"_$G(DFN)_";.03////"_$G(IBVSIT)_";.04////"_$G(ENCTR)_";.06////"_+IBTDT_";.18////"_IBETYP_";.2////1;.24////"_$$INSURED^IBCNS1(DFN)_";1.01///NOW;1.02////"_DUZ_";.17////"_$$EABD^IBTUTL(IBETYP)
178 I $G(IBRMARK)'="" S DR=DR_";.19///"_IBRMARK
179 D ^DIE K DA,DR,DIE
180 L -^IBT(356,+IBTRN)
181OPTSCRNQ Q
Note: See TracBrowser for help on using the repository browser.