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

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

initial load of WorldVistAEHR

File size: 2.9 KB
Line 
1IBTRKR1 ;ALB/AAS - CLAIMS TRACKER - AUTO-ENROLLER ; 4-AUG-93
2 ;;Version 2.0 ; INTEGRATED BILLING ;**10,23,56**;; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5RANDOM(IBSPEC) ; -- see if random sample
6 ; -- input = treating specialty from 45.7 (piece 9 of dgpma)
7 ; output = 1 if random sample
8 ; 0 if not random sample
9 ;
10 N SPECALTY
11 I '$G(IBSPEC) Q 0
12 ;
13 I $$FMDIFF^XLFDT(DT,$P($G(^IBE(350.9,1,6)),"^",7))>7 D UP1
14 ;
15 ; specialty field (piece 2) is ptr to file 42.4
16 S SPECALTY="^"_$P($G(^DIC(45.7,+IBSPEC,0)),"^",2)_"^"
17 ;
18 ; medicine sample
19 I "^1^2^3^4^5^6^7^8^9^10^14^15^31^"[SPECALTY Q $$PROC("M")
20 ;
21 ; surgery sample
22 I "^50^51^52^53^54^55^56^57^58^59^61^62^"[SPECALTY Q $$PROC("S")
23 ;
24 ; psychiatry sample - none
25 Q 0
26 ;
27 ;
28PROC(TYPE) ; process random sample
29 ; type = 'M'edicine, 'S'urgery, or 'P'sych
30 N IBTRKR,PIECE,RANDNUMB,SAMPMET,SAMPSIZE,SVCCOUNT
31 S PIECE=$S(TYPE="M":8,TYPE="S":13,TYPE="P":18,1:0) I 'PIECE Q 0
32 ;
33 ; allow only 1 process to update site params
34 L +^IBE(350.9,1,6):10 I '$T Q 0
35 S IBTRKR=$G(^IBE(350.9,1,6))
36 ;
37 ; check sample size greater than 0
38 S SAMPSIZE=$P(IBTRKR,"^",PIECE) I SAMPSIZE<1 L -^IBE(350.9,1,6) Q 0
39 ;
40 ; increment service counter
41 S SVCCOUNT=$P(IBTRKR,"^",PIECE+4)+1,$P(^IBE(350.9,1,6),"^",PIECE+4)=SVCCOUNT
42 ;
43 ; sample entries met to date, quit if greater or equal to samples
44 S SAMPMET=$P(IBTRKR,"^",PIECE+3) I SAMPSIZE'>SAMPMET L -^IBE(350.9,1,6) Q 0
45 ;
46 ; service random number, default 3
47 S RANDNUMB=$P(IBTRKR,"^",PIECE+2) I RANDNUMB<1 S RANDNUMB=3
48 ;
49 ; if service counter mod random number = 0, then its a random sample
50 I SVCCOUNT#RANDNUMB'=0 L -^IBE(350.9,1,6) Q 0
51 S $P(^IBE(350.9,1,6),"^",PIECE+3)=SAMPMET+1
52 L -^IBE(350.9,1,6)
53 Q 1
54 ;
55 ;
56UPDATE ; -- weekly update of random sampler called from nightly job
57 ;
58 I $$DOW^XLFDT(DT,1)'=0 Q ; run on sunday night only
59 ;
60UP1 ; -- enter here to force update, nightly job didn't update in over 7 days
61 N %,AVGADM,IBTRKR,PIECE,SAMPSIZE,RANDNUMB
62 ;
63 I '$D(^IBE(350.9,1,6)) Q
64 I $P(^IBE(350.9,1,6),"^",7)=DT Q
65 ; prevent updating site params during weekly update
66 L +^IBE(350.9,1,6):10 I '$T Q
67 ;
68 ; set random sample date to today
69 S $P(^IBE(350.9,1,6),"^",7)=DT
70 ;
71 S IBTRKR=^IBE(350.9,1,6)
72 ; piece 8 for medicine, piece 13 for surgery, piece 18 for psych
73 F PIECE=8,13,18 D
74 . ; average weekly admissions, default is 5
75 . S AVGADM=$P(IBTRKR,"^",PIECE+1) I AVGADM<5 S AVGADM=5
76 . ;
77 . ; generate random number if sample size is greater than 0
78 . S SAMPSIZE=$P(IBTRKR,"^",PIECE)
79 . I SAMPSIZE>0 S %=AVGADM/SAMPSIZE S:%<1 %=1 S RANDNUMB=$R(%)+1
80 . ;
81 . S $P(^IBE(350.9,1,6),"^",PIECE+1,PIECE+4)=AVGADM_"^"_+$G(RANDNUMB)_"^0^0"
82 L -^IBE(350.9,1,6)
83 Q
84 ;
85 ;
86CLEAR ; -- Clear random sampler
87 ;
88 N PIECE
89 L +^IBE(350.9,1,6):10 I '$T Q
90 S $P(^IBE(350.9,1,6),"^",7)=DT
91 F PIECE=8,13,18 S $P(^IBE(350.9,1,6),"^",PIECE,PIECE+4)="2^5^1^0^0"
92 L -^IBE(350.9,1,6)
93 Q
Note: See TracBrowser for help on using the repository browser.