IBTRKR1 ;ALB/AAS - CLAIMS TRACKER - AUTO-ENROLLER ; 4-AUG-93
;;Version 2.0 ; INTEGRATED BILLING ;**10,23,56**;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
RANDOM(IBSPEC) ; -- see if random sample
; -- input = treating specialty from 45.7 (piece 9 of dgpma)
; output = 1 if random sample
; 0 if not random sample
;
N SPECALTY
I '$G(IBSPEC) Q 0
;
I $$FMDIFF^XLFDT(DT,$P($G(^IBE(350.9,1,6)),"^",7))>7 D UP1
;
; specialty field (piece 2) is ptr to file 42.4
S SPECALTY="^"_$P($G(^DIC(45.7,+IBSPEC,0)),"^",2)_"^"
;
; medicine sample
I "^1^2^3^4^5^6^7^8^9^10^14^15^31^"[SPECALTY Q $$PROC("M")
;
; surgery sample
I "^50^51^52^53^54^55^56^57^58^59^61^62^"[SPECALTY Q $$PROC("S")
;
; psychiatry sample - none
Q 0
;
;
PROC(TYPE) ; process random sample
; type = 'M'edicine, 'S'urgery, or 'P'sych
N IBTRKR,PIECE,RANDNUMB,SAMPMET,SAMPSIZE,SVCCOUNT
S PIECE=$S(TYPE="M":8,TYPE="S":13,TYPE="P":18,1:0) I 'PIECE Q 0
;
; allow only 1 process to update site params
L +^IBE(350.9,1,6):10 I '$T Q 0
S IBTRKR=$G(^IBE(350.9,1,6))
;
; check sample size greater than 0
S SAMPSIZE=$P(IBTRKR,"^",PIECE) I SAMPSIZE<1 L -^IBE(350.9,1,6) Q 0
;
; increment service counter
S SVCCOUNT=$P(IBTRKR,"^",PIECE+4)+1,$P(^IBE(350.9,1,6),"^",PIECE+4)=SVCCOUNT
;
; sample entries met to date, quit if greater or equal to samples
S SAMPMET=$P(IBTRKR,"^",PIECE+3) I SAMPSIZE'>SAMPMET L -^IBE(350.9,1,6) Q 0
;
; service random number, default 3
S RANDNUMB=$P(IBTRKR,"^",PIECE+2) I RANDNUMB<1 S RANDNUMB=3
;
; if service counter mod random number = 0, then its a random sample
I SVCCOUNT#RANDNUMB'=0 L -^IBE(350.9,1,6) Q 0
S $P(^IBE(350.9,1,6),"^",PIECE+3)=SAMPMET+1
L -^IBE(350.9,1,6)
Q 1
;
;
UPDATE ; -- weekly update of random sampler called from nightly job
;
I $$DOW^XLFDT(DT,1)'=0 Q ; run on sunday night only
;
UP1 ; -- enter here to force update, nightly job didn't update in over 7 days
N %,AVGADM,IBTRKR,PIECE,SAMPSIZE,RANDNUMB
;
I '$D(^IBE(350.9,1,6)) Q
I $P(^IBE(350.9,1,6),"^",7)=DT Q
; prevent updating site params during weekly update
L +^IBE(350.9,1,6):10 I '$T Q
;
; set random sample date to today
S $P(^IBE(350.9,1,6),"^",7)=DT
;
S IBTRKR=^IBE(350.9,1,6)
; piece 8 for medicine, piece 13 for surgery, piece 18 for psych
F PIECE=8,13,18 D
. ; average weekly admissions, default is 5
. S AVGADM=$P(IBTRKR,"^",PIECE+1) I AVGADM<5 S AVGADM=5
. ;
. ; generate random number if sample size is greater than 0
. S SAMPSIZE=$P(IBTRKR,"^",PIECE)
. I SAMPSIZE>0 S %=AVGADM/SAMPSIZE S:%<1 %=1 S RANDNUMB=$R(%)+1
. ;
. S $P(^IBE(350.9,1,6),"^",PIECE+1,PIECE+4)=AVGADM_"^"_+$G(RANDNUMB)_"^0^0"
L -^IBE(350.9,1,6)
Q
;
;
CLEAR ; -- Clear random sampler
;
N PIECE
L +^IBE(350.9,1,6):10 I '$T Q
S $P(^IBE(350.9,1,6),"^",7)=DT
F PIECE=8,13,18 S $P(^IBE(350.9,1,6),"^",PIECE,PIECE+4)="2^5^1^0^0"
L -^IBE(350.9,1,6)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTRKR1 3046 printed Apr 09, 2024@21:34:53 Page 2
IBTRKR1 ;ALB/AAS - CLAIMS TRACKER - AUTO-ENROLLER ; 4-AUG-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;**10,23,56**;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
RANDOM(IBSPEC) ; -- see if random sample
+1 ; -- input = treating specialty from 45.7 (piece 9 of dgpma)
+2 ; output = 1 if random sample
+3 ; 0 if not random sample
+4 ;
+5 NEW SPECALTY
+6 IF '$GET(IBSPEC)
QUIT 0
+7 ;
+8 IF $$FMDIFF^XLFDT(DT,$PIECE($GET(^IBE(350.9,1,6)),"^",7))>7
DO UP1
+9 ;
+10 ; specialty field (piece 2) is ptr to file 42.4
+11 SET SPECALTY="^"_$PIECE($GET(^DIC(45.7,+IBSPEC,0)),"^",2)_"^"
+12 ;
+13 ; medicine sample
+14 IF "^1^2^3^4^5^6^7^8^9^10^14^15^31^"[SPECALTY
QUIT $$PROC("M")
+15 ;
+16 ; surgery sample
+17 IF "^50^51^52^53^54^55^56^57^58^59^61^62^"[SPECALTY
QUIT $$PROC("S")
+18 ;
+19 ; psychiatry sample - none
+20 QUIT 0
+21 ;
+22 ;
PROC(TYPE) ; process random sample
+1 ; type = 'M'edicine, 'S'urgery, or 'P'sych
+2 NEW IBTRKR,PIECE,RANDNUMB,SAMPMET,SAMPSIZE,SVCCOUNT
+3 SET PIECE=$SELECT(TYPE="M":8,TYPE="S":13,TYPE="P":18,1:0)
IF 'PIECE
QUIT 0
+4 ;
+5 ; allow only 1 process to update site params
+6 LOCK +^IBE(350.9,1,6):10
IF '$TEST
QUIT 0
+7 SET IBTRKR=$GET(^IBE(350.9,1,6))
+8 ;
+9 ; check sample size greater than 0
+10 SET SAMPSIZE=$PIECE(IBTRKR,"^",PIECE)
IF SAMPSIZE<1
LOCK -^IBE(350.9,1,6)
QUIT 0
+11 ;
+12 ; increment service counter
+13 SET SVCCOUNT=$PIECE(IBTRKR,"^",PIECE+4)+1
SET $PIECE(^IBE(350.9,1,6),"^",PIECE+4)=SVCCOUNT
+14 ;
+15 ; sample entries met to date, quit if greater or equal to samples
+16 SET SAMPMET=$PIECE(IBTRKR,"^",PIECE+3)
IF SAMPSIZE'>SAMPMET
LOCK -^IBE(350.9,1,6)
QUIT 0
+17 ;
+18 ; service random number, default 3
+19 SET RANDNUMB=$PIECE(IBTRKR,"^",PIECE+2)
IF RANDNUMB<1
SET RANDNUMB=3
+20 ;
+21 ; if service counter mod random number = 0, then its a random sample
+22 IF SVCCOUNT#RANDNUMB'=0
LOCK -^IBE(350.9,1,6)
QUIT 0
+23 SET $PIECE(^IBE(350.9,1,6),"^",PIECE+3)=SAMPMET+1
+24 LOCK -^IBE(350.9,1,6)
+25 QUIT 1
+26 ;
+27 ;
UPDATE ; -- weekly update of random sampler called from nightly job
+1 ;
+2 ; run on sunday night only
IF $$DOW^XLFDT(DT,1)'=0
QUIT
+3 ;
UP1 ; -- enter here to force update, nightly job didn't update in over 7 days
+1 NEW %,AVGADM,IBTRKR,PIECE,SAMPSIZE,RANDNUMB
+2 ;
+3 IF '$DATA(^IBE(350.9,1,6))
QUIT
+4 IF $PIECE(^IBE(350.9,1,6),"^",7)=DT
QUIT
+5 ; prevent updating site params during weekly update
+6 LOCK +^IBE(350.9,1,6):10
IF '$TEST
QUIT
+7 ;
+8 ; set random sample date to today
+9 SET $PIECE(^IBE(350.9,1,6),"^",7)=DT
+10 ;
+11 SET IBTRKR=^IBE(350.9,1,6)
+12 ; piece 8 for medicine, piece 13 for surgery, piece 18 for psych
+13 FOR PIECE=8,13,18
Begin DoDot:1
+14 ; average weekly admissions, default is 5
+15 SET AVGADM=$PIECE(IBTRKR,"^",PIECE+1)
IF AVGADM<5
SET AVGADM=5
+16 ;
+17 ; generate random number if sample size is greater than 0
+18 SET SAMPSIZE=$PIECE(IBTRKR,"^",PIECE)
+19 IF SAMPSIZE>0
SET %=AVGADM/SAMPSIZE
if %<1
SET %=1
SET RANDNUMB=$RANDOM(%)+1
+20 ;
+21 SET $PIECE(^IBE(350.9,1,6),"^",PIECE+1,PIECE+4)=AVGADM_"^"_+$GET(RANDNUMB)_"^0^0"
End DoDot:1
+22 LOCK -^IBE(350.9,1,6)
+23 QUIT
+24 ;
+25 ;
CLEAR ; -- Clear random sampler
+1 ;
+2 NEW PIECE
+3 LOCK +^IBE(350.9,1,6):10
IF '$TEST
QUIT
+4 SET $PIECE(^IBE(350.9,1,6),"^",7)=DT
+5 FOR PIECE=8,13,18
SET $PIECE(^IBE(350.9,1,6),"^",PIECE,PIECE+4)="2^5^1^0^0"
+6 LOCK -^IBE(350.9,1,6)
+7 QUIT
