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

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

initial load of WorldVistAEHR
File size: 4.0 KB
Line 
1IBTRPR01 ;ALB/AAS - CLAIMS TRACKING - PENDING WORK SCREEN ; 22-JUL-1993
2 ;;2.0;INTEGRATED BILLING;**23,33,91**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5% G ^IBTRPR
6 ;
7 ;
81 S (X,ENTRY)="",TYPE="Hosp Reviews",FILE=356.1,IBDV=1
9 S IBI=IBTPBDT-.0001 F S IBI=$O(^IBT(356.1,"APEND",IBI)) Q:'IBI!(IBI>(IBTPEDT+.9)) S IBJ="" F S IBJ=$O(^IBT(356.1,"APEND",IBI,IBJ)) Q:'IBJ D
10 .S (ENTRY,IBTRV)=IBJ
11 .I IBTPRT'="B" D Q:IBQUIT
12 ..S IBQUIT=1
13 ..S IBTX=$P($G(^IBE(356.11,+$P($G(^IBT(356.1,+IBTRV,0)),"^",22),0)),"^",2)
14 ..I IBTPRT="C",IBTX>29 S IBQUIT=0 Q
15 ..I IBTPRT="A",IBTX<30 S IBQUIT=0
16 .S IBDATE=IBI
17 .S IBTRN=$P($G(^IBT(356.1,+IBTRV,0)),"^",2)
18 .I $P($G(^IBT(356,+IBTRN,0)),"^",20)'=1 Q
19 .S DFN=$P($G(^IBT(356,+IBTRN,0)),"^",2)
20 .I $G(IBTOPW) S IBDV=$$DIV(IBTRN)
21 .S IBWARD=$P($G(^DPT(DFN,.1)),"^")
22 .S IBSTATUS=$P($G(^IBT(356.1,IBTRV,0)),"^",21)
23 .S IBNEXT=$S(IBSTATUS=10:"ADD NEXT REV.",1:"EDIT REVIEW")
24 .S IBSTATUS=$$EXPAND^IBTRE(356.1,.21,IBSTATUS)
25 .S IBREV=$P($G(^IBT(356.1,IBTRV,0)),"^",22)
26 .S IBASSIGN=$P($G(^VA(200,+$P($G(^IBT(356,IBTRN,1)),"^",5),0)),"^")
27 .I IBTWHO'="A" D Q:IBQUIT
28 ..S IBQUIT=1
29 ..I IBTWHO="Y",DUZ=$P($G(^IBT(356,+IBTRN,1)),"^",5) S IBQUIT=0 Q
30 ..I IBTWHO="U",IBASSIGN=""!(DUZ=$P($G(^IBT(356,+IBTRN,1)),"^",5)) S IBQUIT=0
31 .I IBASSIGN="" S IBASSIGN="Unassigned"
32 .D TEMP
33 .Q
34 S IBQUIT=0
35 Q
36 ;
372 S (X,ENTRY)="",TYPE="Ins. Reviews",FILE=356.2,IBDV=1
38 S IBI=IBTPBDT-.0001 F S IBI=$O(^IBT(356.2,"APEND",IBI)) Q:'IBI!(IBI>(IBTPEDT+.9)) S IBJ="" F S IBJ=$O(^IBT(356.2,"APEND",IBI,IBJ)) Q:'IBJ D
39 .S (ENTRY,IBTRC)=IBJ
40 .I IBTPRT'="B" D Q:IBQUIT
41 ..S IBQUIT=1
42 ..S IBTX=$P($G(^IBE(356.11,+$P($G(^IBT(356.2,+IBTRC,0)),"^",4),0)),"^",2)
43 ..I IBTPRT="C",IBTX>29 S IBQUIT=0
44 ..I IBTPRT="A",IBTX<30 S IBQUIT=0
45 .S IBDATE=IBI
46 .S IBTRN=$P($G(^IBT(356.2,+IBTRC,0)),"^",2)
47 .I $P($G(^IBT(356,+IBTRN,0)),"^",20)'=1 Q
48 .S DFN=$P($G(^IBT(356,+IBTRN,0)),"^",2)
49 .I $G(IBTOPW) S IBDV=$$DIV(IBTRN)
50 .S IBREV=$P($G(^IBT(356.2,IBTRC,0)),"^",4)
51 .S IBWARD=$P($G(^DPT(DFN,.1)),"^")
52 .S IBSTATUS=$P($G(^IBT(356.2,IBTRC,0)),"^",19)
53 .S IBNEXT=$S(IBSTATUS=10:"ADD NEXT REV.",1:"EDIT REVIEW")
54 .S IBSTATUS=$$EXPAND^IBTRE(356.2,.19,IBSTATUS)
55 .S IBASSIGN=$P($G(^VA(200,+$P($G(^IBT(356,IBTRN,1)),"^",6),0)),"^")
56 .I IBTWHO'="A" D Q:IBQUIT
57 ..S IBQUIT=1
58 ..I IBTWHO="Y",DUZ=$P($G(^IBT(356,+IBTRN,1)),"^",6) S IBQUIT=0 Q
59 ..I IBTWHO="U",IBASSIGN=""!(DUZ=$P($G(^IBT(356,+IBTRN,1)),"^",6)) S IBQUIT=0
60 .I IBASSIGN="" S IBASSIGN="Unassigned"
61 .D TEMP
62 .Q
63 S IBQUIT=0
64 Q
65 ;
66 ;
67TEMP ; -- build temp array
68 N IBTSORT
69 S IBTSORT=$S(IBSORT="W":IBWARD,IBSORT="P":$P($G(^DPT(DFN,0)),"^"),IBSORT="T":$P($G(^IBE(356.11,+IBREV,0)),"^"),IBSORT="D":IBDATE,IBSORT="A":IBASSIGN,1:"ZZ!@#$%^&*()_+")
70 I IBTSORT="" S IBTSORT="ZZ!@#$%^&*()_+"
71 S ^TMP("IBSRT",$J,$E(IBDV,1,20),TYPE,$E(IBTSORT,1,20),$E($P(^DPT(DFN,0),"^"),1,20),IBTRN,ENTRY)=IBTRN_"^"_ENTRY_"^"_IBDATE_"^"_DFN_"^"_IBWARD_"^"_IBSTATUS_"^"_IBREV_"^"_FILE_"^"_IBASSIGN_"^"_IBNEXT
72 S ^TMP("IBSRT1",$J,DFN,TYPE)=""
73 Q
74 ;
75DIV(IBTRN) ; -- comput division of a tracking entry
76 ; -- input ien to 356
77 ; -- output name (.01) of entry in 40.8 or unknown
78 N IBDV,DFN S IBDV=""
79 I $G(^IBT(356,+$G(IBTRN),0))="" G DIVQ
80 S DFN=$P(^IBT(356,+IBTRN,0),"^",2)
81 I $P($G(^IBT(356,+IBTRN,0)),"^",5) D G DIVQ
82 .S IBDV=+$P($G(^DIC(42,+$P($G(^DGPM(+$P($G(^IBT(356,+IBTRN,0)),"^",5),0)),"^",6),0)),"^",11) ;default is division of admission movement
83 .I $G(^DPT(DFN,.1))'="",+$P(^IBT(356,+IBTRN,0),"^",5)=+$G(^DPT(DFN,.105)) S IBDV=+$P($G(^DIC(42,+$O(^DIC(42,"B",$P($G(^DPT(DFN,.1)),"^"),0)),0)),"^",11) ;if current adm=adm from movement compute current div
84 ;
85 I $P($G(^IBT(356,+IBTRN,0)),"^",4) D G DIVQ
86 .S IBDV=+$$SCE^IBSDU(+$P($G(^IBT(356,+IBTRN,0)),"^",4),11)
87 ;
88 I $P($G(^IBT(356,+IBTRN,0)),"^",32),'$P(^IBT(356,+IBTRN,0),"^",5) D
89 .S IBDV=+$P($G(^DGS(41.1,+$P(^IBT(356,+IBTRN,0),"^",32),0)),"^",12)
90 .I 'IBDV S IBDV=+$P($G(^DIC(42,+$P($G(^DGS(41.1,+$P(^IBT(356,+IBTRN,0),"^",32),0)),"^",8),0)),"^",11)
91 ;
92DIVQ I IBDV S IBDV=$P($G(^DG(40.8,+IBDV,0)),"^")
93 E S IBDV="UNKNOWN"
94 Q IBDV
Note: See TracBrowser for help on using the repository browser.