IBQLCHK ;LEB/MRY - UM ROLLUP - CHECK INFO. IN IB(array) ; 4-JUN-95
;;1.0;UTILIZATION MGMT ROLLUP LOCAL;;Oct 01, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; Input: IBTRN
; Output: IB(array)
;
I '$D(DT) D DT^DICRW
K IBDATA S IBQUIT=""
CLAIMS ;
D CLAIMS^IBQL356 Q:IBQUIT
ADM ;
S IBTRV=$O(^IBT(356.1,"C",IBTRN,""))
D ADMIT^IBQL356 Q:IBQUIT
S X="" F IBFLD=.01:.01:.13 S X=X_IBFLD_":"_IB(IBFLD)_"^"
S IBDATA(0)=$P(X,"^",1,$L(X,"^")-1)
S X="" F IBFLD=1.01:.01:1.07 S X=X_IBFLD_":"_IB(IBFLD)_"^"
S IBDATA(1)=$P(X,"^",1,$L(X,"^")-1)
STAY ;
S IBPIS=IB(1.02)
F S IBTRV=$O(^IBT(356.1,"C",IBTRN,IBTRV)) Q:'IBTRV D Q:IBQUIT
.D STAY^IBQL356 Q:IBQUIT
.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)_"^"
.S IBDATA(IB(13.01))=$P(X,"^",1,$L(X,"^")-1)
;Q
;
PRINT ;
;D HDR
W #,"CLAIMS TRACKING AND ADMISSION REVIEW DATA"
W ! F I=1:1:80 W "="
W !
W !!,"IB(.01) - ENTRY ID: ",?25,IB(.01)
W !,"IB(.02) - SITE: ",?25,IB(.02)
W !,"IB(.03) - SSN#: ",?25,IB(.03)
W !,"IB(.04) - ADM DIAGNOSIS: ",?25,IB(.04)
W !,"IB(.05) - ENROLL: ",?25,IB(.05)
W !,"IB(.06) - ADMITTING PHY: ",?25,IB(.06)
W !,"IB(.07) - ATTENDING PHY: ",?25,IB(.07)
W !,"IB(.08) - RESIDENT PHY: ",?25,IB(.08)
W !,"IB(.09) - ADMISSION: ",?25,IB(.09)
W !,"IB(.1) - DISCHARGE: ",?25,IB(.1)
W !,"IB(.11) - WARD: ",?25,IB(.11)
W !,"IB(.12) - TREATING SPECIALTY: ",?25,IB(.12)
W !,"IB(1.01) - SI FROM ADM: ",?25,IB(1.01)
W !,"IB(1.02) - IS FROM ADM: ",?25,IB(1.02)
W !,"IB(1.03) - REASONS FROM ADM: ",?25,IB(1.03)
W !,"IB(1.04) - PROVIDER INTERVIEWED?: ",?25,IB(1.04)
W !,"IB(1.05) - ADM INFLUENCED?: ",?25,IB(1.05)
W !,"IB(1.06) - ROLLUP TYPE: ",?25,IB(1.06)
W !,"IB(1.07) - SERVICE: ",?25,IB(1.07)
;
W !,"<<< DATA STREAM FOR TRANSMISSION >>>",! S X="ZW IBDATA" X X
W !,"<<< VADPT CALL VARIABLES >>>",! S X="ZW VAIN" X X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBQLCHK 1943 printed Dec 13, 2024@02:41:07 Page 2
IBQLCHK ;LEB/MRY - UM ROLLUP - CHECK INFO. IN IB(array) ; 4-JUN-95
+1 ;;1.0;UTILIZATION MGMT ROLLUP LOCAL;;Oct 01, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; Input: IBTRN
+5 ; Output: IB(array)
+6 ;
+7 IF '$DATA(DT)
DO DT^DICRW
+8 KILL IBDATA
SET IBQUIT=""
CLAIMS ;
+1 DO CLAIMS^IBQL356
if IBQUIT
QUIT
ADM ;
+1 SET IBTRV=$ORDER(^IBT(356.1,"C",IBTRN,""))
+2 DO ADMIT^IBQL356
if IBQUIT
QUIT
+3 SET X=""
FOR IBFLD=.01:.01:.13
SET X=X_IBFLD_":"_IB(IBFLD)_"^"
+4 SET IBDATA(0)=$PIECE(X,"^",1,$LENGTH(X,"^")-1)
+5 SET X=""
FOR IBFLD=1.01:.01:1.07
SET X=X_IBFLD_":"_IB(IBFLD)_"^"
+6 SET IBDATA(1)=$PIECE(X,"^",1,$LENGTH(X,"^")-1)
STAY ;
+1 SET IBPIS=IB(1.02)
+2 FOR
SET IBTRV=$ORDER(^IBT(356.1,"C",IBTRN,IBTRV))
if 'IBTRV
QUIT
Begin DoDot:1
+3 DO STAY^IBQL356
if IBQUIT
QUIT
+4 SET X=""
FOR IBFLD=13.01,13.02,13.03,13.04,13.05,13.06,13.07,13.08
SET X=X_(IBFLD-13)_":"_IB(IBFLD)_"^"
+5 SET IBDATA(IB(13.01))=$PIECE(X,"^",1,$LENGTH(X,"^")-1)
End DoDot:1
if IBQUIT
QUIT
+6 ;Q
+7 ;
PRINT ;
+1 ;D HDR
+2 WRITE #,"CLAIMS TRACKING AND ADMISSION REVIEW DATA"
+3 WRITE !
FOR I=1:1:80
WRITE "="
+4 WRITE !
+5 WRITE !!,"IB(.01) - ENTRY ID: ",?25,IB(.01)
+6 WRITE !,"IB(.02) - SITE: ",?25,IB(.02)
+7 WRITE !,"IB(.03) - SSN#: ",?25,IB(.03)
+8 WRITE !,"IB(.04) - ADM DIAGNOSIS: ",?25,IB(.04)
+9 WRITE !,"IB(.05) - ENROLL: ",?25,IB(.05)
+10 WRITE !,"IB(.06) - ADMITTING PHY: ",?25,IB(.06)
+11 WRITE !,"IB(.07) - ATTENDING PHY: ",?25,IB(.07)
+12 WRITE !,"IB(.08) - RESIDENT PHY: ",?25,IB(.08)
+13 WRITE !,"IB(.09) - ADMISSION: ",?25,IB(.09)
+14 WRITE !,"IB(.1) - DISCHARGE: ",?25,IB(.1)
+15 WRITE !,"IB(.11) - WARD: ",?25,IB(.11)
+16 WRITE !,"IB(.12) - TREATING SPECIALTY: ",?25,IB(.12)
+17 WRITE !,"IB(1.01) - SI FROM ADM: ",?25,IB(1.01)
+18 WRITE !,"IB(1.02) - IS FROM ADM: ",?25,IB(1.02)
+19 WRITE !,"IB(1.03) - REASONS FROM ADM: ",?25,IB(1.03)
+20 WRITE !,"IB(1.04) - PROVIDER INTERVIEWED?: ",?25,IB(1.04)
+21 WRITE !,"IB(1.05) - ADM INFLUENCED?: ",?25,IB(1.05)
+22 WRITE !,"IB(1.06) - ROLLUP TYPE: ",?25,IB(1.06)
+23 WRITE !,"IB(1.07) - SERVICE: ",?25,IB(1.07)
+24 ;
+25 WRITE !,"<<< DATA STREAM FOR TRANSMISSION >>>",!
SET X="ZW IBDATA"
XECUTE X
+26 WRITE !,"<<< VADPT CALL VARIABLES >>>",!
SET X="ZW VAIN"
XECUTE X
+27 QUIT
