Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBTRKR1

IBTRKR1.m

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