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

IBQLLD.m

Go to the documentation of this file. 
  1. IBQLLD ;LEB/MRY - LOAD UMR FILE ; 31-MAR-95
  1.  ;;1.0;UTILIZATION MGMT ROLLUP LOCAL;**2**;Oct 01, 1995
  1.  ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1.  I '$D(IBRPT) Q
  1.  ; --
  1.  I '$D(DT) D DT^DICRW
  1.  D PULL^IBQLPL
  1.  I IBRPT="N" S IBDNLD="N" G START
  1.  W !!,"Create Rollup File"
  1.  ;W !,"The next National Rollup will be " S Y=IBBDT X ^DD("DD") W Y_" to " S Y=IBEDT X ^DD("DD") W Y
  1.  I IBMSG'="" W !!,IBMSG,!,IBMSG1
  1.  ;
  1. DATE ; -- get date range
  1.  W ! D DATE^IBOUTL
  1.  I IBBDT=""!(IBEDT="") G END
  1.  S X1=IBEDT,X2=IBBDT D ^%DTC I X>365 W !,"<<< please report 1 years of information only. >>>" G DATE
  1.  ;
  1.  S DIR(0)="SA^RD:RANDOM & DISEASE;L:LOCAL;A:ALL",DIR("A")="Random & Disease Cases, Local Cases or ALL Cases: ",DIR("B")="ALL" D ^DIR I $D(DUOUT)!($D(DTOUT)) G END
  1.  S IBDNLD=Y
  1.  F I="IBBDT","IBEDT","IBRPT","IBDNLD" S ZTSAVE(I)=""
  1.  S ZTRTN="START^IBQLLD",ZTDESC="IBQ - LOCAL ROLLUP ",ZTIO=""
  1.  D ^%ZTLOAD G END
  1.  ;
  1. START S IBDDT=IBBDT-.01,IBREC=0
  1.  F  S IBDDT=$O(^IBT(356,"ADIS",IBDDT)) Q:'IBDDT!(IBDDT>IBEDT)  D
  1.  .S IBTRN="" F  S IBTRN=$O(^IBT(356,"ADIS",IBDDT,IBTRN)) Q:'IBTRN  D
  1.  ..I '$D(^IBT(356.1,"C",IBTRN))!'$G(^IBT(356,IBTRN,0)) Q
  1.  ..D DATA
  1.  ..Q
  1.  .Q
  1.  ;
  1.  D TRANSMIT^IBQLLD1
  1.  ;
  1. END K IBDATA,X,I,DFN,DGPM,VAINDT,VAIN,IBRPT,IBFLD,IB,IBDDT,IBBDT,IBTRN,IBTRND,IBNAM,IBR,IBD,IBL,IBDNLD,IBHR,IBDAY,IBREC,IBORDER
  1.  Q
  1.  ;
  1. DATA ;
  1.  K IBDATA S IBQUIT=""
  1. CLAIMS ; get Claims Tracking and misc. information into IB(array)
  1.  D CLAIMS^IBQL356 Q:IBQUIT
  1.  ; -- quit if missing entry id, site, ssn, adm diagnosis, enroll code,
  1.  ; admission, rollup type
  1.  F IBFLD=.01,.02,.03,.04,.05,.09,1.06 I IB(IBFLD)="" S IBQUIT=1 Q
  1.  ; -- quit if EVENT TYPE not INPATIENT ADMISSION or INACTIVE.
  1.  I $P(IBTRND,"^",18)'=1!($P(IBTRND,"^",20)'=1) S IBQUIT=1 Q
  1.  Q:IBQUIT
  1.  Q:IBDNLD="N"&(IB(1.06)="L")  Q:IBDNLD="L"&(IB(1.06)="N")  Q:IBDNLD="RD"&(IB(1.06)="L")
  1.  ;
  1. ORDER ; -- check procedure ordering errors, arrange in DAY order.
  1.  S IBTRV=0
  1.  D ORDCHK^IBQLLD2
  1.  Q:IBQUIT
  1.  S IBDAY=0
  1.  F  S IBDAY=$O(IBORDER(IBDAY)) Q:'IBDAY  D  Q:IBQUIT
  1.  .S IBTRV=IBORDER(IBDAY)
  1.  .I IBDAY=1 D ADMIT
  1.  .I IBDAY>1 D STAY
  1.  ;
  1.  ; -- quit if missing discharge date
  1.  I IB(.1)="" S IBQUIT=1 Q
  1.  ;
  1. LOAD ; -- load data into ^ibq(538, file
  1.  Q:IBQUIT  Q:'$D(IBDATA(0))  Q:'$D(IBDATA(1))
  1.  D LOAD^IBQLLD1 S IBREC=IBREC+1
  1.  Q
  1.  ;
  1.  ;
  1. ADMIT ; get Admission Review information into IB(array)
  1.  D ADMIT^IBQL356 Q:IBQUIT
  1.  ; -- quit if missing treating specialty, service
  1.  F IBFLD=.12,1.07 I IB(IBFLD)="" S IBQUIT=1 Q
  1.  ; -- quit if missing si, is and reason from admission
  1.  I IB(1.01)="",IB(1.02)="",IB(1.03)="" S IBQUIT=1 Q
  1.  ; -- quit if not ACTIVE or not COMPLETE.
  1.  I $P(IBTRVD,"^",21)'=10 S IBQUIT=1 Q
  1.  S X="" F IBFLD=.01:.01:.13 S X=X_IBFLD_":"_IB(IBFLD)_"^"
  1.  S IBDATA(0)=$P(X,"^",1,$L(X,"^")-1)
  1.  S X="" F IBFLD=1.01:.01:1.07 S X=X_IBFLD_":"_IB(IBFLD)_"^"
  1.  S IBDATA(1)=$P(X,"^",1,$L(X,"^")-1)
  1.  S IBPIS=IB(1.02)
  1.  Q
  1.  ; 
  1. STAY ;  get Stay Review information into IB(array)
  1.  D STAY^IBQL356 Q:IBQUIT
  1.  ; -- quit if missing 'is' AND missing 'reasons'
  1.  I IB(13.02)="",IB(13.06)="" S IBQUIT=1 Q
  1.  ; -- quit if missing Treating Specialty in continued stay
  1.  I IB(13.07)="" S IBQUIT=1 Q
  1.  ; -- quit if not ACTIVE or not COMPLETE.
  1.  I $P(IBTRVD,"^",21)'=10 S IBQUIT=1 Q
  1.  Q:IBQUIT
  1.  S X="" F IBFLD=13.01,13.02,13.03,13.04,13.05,13.06,13.07,13.08 S X=X_(IBFLD-13)_":"_IB(IBFLD)_"^"
  1.  S IBDATA(IB(13.01))=$P(X,"^",1,$L(X,"^")-1)
  1.  Q