IBQLCHK.m

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 ---IBQLCHK   1943     printed  Mar 13, 2025@21:45:51                                                                                                                                                                                                     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