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

IBQLPL1.m

Go to the documentation of this file. 
  1. IBQLPL1 ;LEB/MRY - PATIENTS QUALIFY/MISSING INFO LIST ; 24-MAR-95
  1.  ;;1.0;UTILIZATION MGMT ROLLUP LOCAL;**1**;Oct 01, 1995
  1.  ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  Q
  1.  ;
  1. START ; -- loop thru discharges in Claims Tracking
  1.  S IBDDT=IBBDT-.01
  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.  ..;
  1.  ..S IBQUIT=0 D CLAIMS^IBQL356 Q:IBQUIT
  1.  ..S IB(1.06)=$S(IB(1.06)="L":"ZL",IB(1.06)="":"AA",1:IB(1.06))
  1.  ..;
  1.  ..I IBRPT="Q" D QUALIFY
  1.  ..I IBRPT="M" D MISSING
  1.  I $$STOP Q
  1.  Q
  1.  ;
  1. QUALIFY ; --list patients to be included in Rollup
  1.  S DFN=$P(IBTRND,"^",2),X=$G(^DPT(DFN,0))
  1.  S IBNAM=$P(X,"^"),SSN=$P(X,"^",9) S:SSN ^TMP("IBQLPL",$J,IB(1.06),IBDDT,SSN)=IBNAM
  1.  Q
  1.  ;
  1.  ;
  1. MISSING ; -- list patients with missing data
  1.  ;
  1.  ; -- send message if missing adm diagnosis, enroll code, adm
  1.  F IBFLD=.04,.05,.09 D ERR I IBERR'="" S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),IBFLD)=IBERR
  1.  ; -- check for (.0001) fundemental completion errors
  1.  I $P(IBTRND,"^",18)'=1 D
  1.  .S IBERR="EVENT TYPE NOT OF INPATIENT ADMISSION (#"_IB(.01)_")"
  1.  .S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),.0001)=IBERR
  1.  I $P(IBTRND,"^",20)'=1 D
  1.  .S IBERR="CLAIMS TRACKING ENTRY IS INACTIVE (#"_IB(.01)_")"
  1.  .S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),.0002)=IBERR
  1.  ;
  1. ORDER ; -- check (.001) procedure ordering errors, arrange in DAY order.
  1.  S IBTRV=0
  1.  D ORDCHK^IBQLPL3
  1.  Q:IB001
  1.  S IBDAY=0
  1.  F  S IBDAY=$O(IBORDER(IBDAY)) Q:'IBDAY  D
  1.  .S IBTRV=IBORDER(IBDAY)
  1.  .I IBDAY=1 D ADMIT
  1.  .I IBDAY>1 D STAY
  1.  I $O(^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),0)) S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03))=IBNAM
  1.  Q
  1.  ;
  1. ADMIT ; get Admission Review infomation into IB(array)
  1.  D ADMIT^IBQL356 Q:IBQUIT
  1.  ; -- send message if no treating specialty, service
  1.  F IBFLD=.12,1.07 D ERR I IBERR'="" S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),IBFLD)=IBERR
  1.  ; -- send message if si,is, reasons are not answered
  1.  I IB(1.01)="",IB(1.02)="",IB(1.03)="" F IBFLD=1.01,1.02,1.03 D ERR I IBERR'="" S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),IBFLD)=IBERR
  1.  ; -- check for (.0001) fundemetally completion errors
  1.  I $P(IBTRVD,"^",21)'=10 D
  1.  .S IBERR="Admission Stay not COMPLETE (#"_IB(.01)_")"
  1.  .S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),.0004)=IBERR
  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.  F IBFLD=13.07,13.08 D ERR I IBERR'="" S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),(IB(13.01)+IBFLD))=IBERR
  1.  I IB(13.02)="",IB(13.06)="" F IBFLD=13.02,13.06 D ERR I IBERR'="" S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),(IB(13.01)+IBFLD))=IBERR
  1.  ; -- check for (.0001) fundementally completion errors
  1.  I $P(IBTRVD,"^",21)'=10 D
  1.  .S IBERR="STAY DAY "_IB(13.01)_" NOT COMPLETE (#"_IB(.01)_")"
  1.  .S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),(IB(13.01)+.0004))=IBERR
  1.  Q
  1.  ;
  1. ERR ; -- return missing message
  1.  S IBERR=""
  1.  I IB(IBFLD)="" S IBERR="MISSING "_IBD(IBFLD) S:IBFLD>13 IBERR=IBERR_" DAY "_IB(13.01) S IBERR=IBERR_" (#"_IB(.01)_")"
  1.  Q
  1. ERR1 ; -- return error message that entry EVENT TYPE is not Inpatient status.
  1.  S IBERR="EVENT TYPE not of INPATIENT ADMISSION (#"_IB(.01)_")"
  1.  Q
  1. STOP() ;determine if user has requested the queued report to stop
  1.  I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ I +$G(IBPAG) W !,"***TASK STOPPED BY USER***"
  1.  Q +$G(ZTSTOP)