IBCOMD1 ;ALB/CMS - GENERATE INSURANCE COMPANY LISTINGS ;03-AUG-98
;;2.0;INTEGRATED BILLING;**103,528,602,664,732**;21-MAR-94;Build 13
;;Per VA Directive 6402, this routine should not be modified.
Q
;
BEG ; Queued entry point.
; Input variables:
;
; IBCASE(n) = x ^ y ^ z (Optional), where
; n = 1-4 (1:Name, 2:Street, 3:City, 4:State)
; x = C (Contains), or R (RANGE)
; y = Pointer to the STATE (#5) file, if n=4
; The 'Contains' value, if x = C
; The 'Start From' value, if x = R
; z = The 'Go To' value, if x = R
;
; IBFLD(n) = x (Required), where
; n = 1-4 (1:Name, 2:Street, 3:City, 4:State)
; x = NAME (n=1), STREET (n=2), CITY (n=3), STATE (n=4)
;
; IBAIB - Required. Include Active Insurance
; 1= Active Ins. 2= Inactive Ins. 3= Both
; IBOUT - Required. Output format
; "R"= report format "E"= Excel format
;
;IB*732/CKB - put variables in alphabetical order
N IBDA,IBDA0,IBDA11,IBDA13,IBI,IBJ,IBNOT,IBPAGE,IBTMP,IBX,X,Y
;
I $E(IOST,1,2)["C-" W !!,?15,"... One Moment Please ..." ;IB*732/CKB
;
I "^R^E^"'[(U_$G(IBOUT)_U) S IBOUT="R"
K ^TMP("IBCOMD",$J) S IBPAGE=0
;
; - must look at all entries in file #36
S IBDA=0 F S IBDA=$O(^DIC(36,IBDA)) Q:'IBDA S IBDA0=$G(^(IBDA,0)) D
.;
.; - screen out active/inactive companies
.I IBAIB=1,$P(IBDA0,U,5) Q
.I IBAIB=2,'$P(IBDA0,U,5) Q
.;
.S IBDA11=$G(^DIC(36,IBDA,.11)),IBDA13=$G(^(.13))
.;
.; - screen out entries based on user-selected field screens
.S (IBJ,IBNOT)=0 F S IBJ=$O(IBCASE(IBJ)) Q:'IBJ D Q:IBNOT
..N IBD,VAL S IBD=IBCASE(IBJ)
..;
..; - check state first
..I IBJ=4 S:$P(IBDA11,"^",5)'=$P(IBD,"^",2) IBNOT=1 Q
..;
..;IB*732/CKB - modified to check street address lines 1-3
..; Convert field & values to uppercase (case insensitive)
..; - find the field value to be evaluated
..S VAL=$S(IBJ=1:$P(IBDA0,"^"),1:$P(IBDA11,"^",4))
..I IBJ=2 S VAL=$P(IBDA11,"^",1,3)
..S VAL=$$UP^XLFSTR(VAL)
..F I=2:1:3 I $P(IBD,"^",I)'="" S $P(IBD,"^",I)=$$UP^XLFSTR($P(IBD,"^",I))
..;
..;IB*732/CKB - call $$FILTER^IBCNINSU to check 'contains' AND 'range' values
..; - check 'contains' values
..;I $P(IBD,"^")="C" S:VAL'[$P(IBD,"^",2) IBNOT=1 Q
..;
..; - check 'range' values
..I VAL="" S IBNOT=1 Q ; VAL must have a value in a range
..;I $P(IBD,"^",2)]VAL S IBNOT=1 Q ; VAL doesn't follow Start value
..;I VAL]$P(IBD,"^",3) S IBNOT=1 ; VAL follows the Go To value
..;IB*732/CKB - added IBFILT (Converts Contains=2, Range=3)
..N IBFILT
..S IBFILT=$S($P(IBD,"^")="C":2,1:3)_"^"_$P(IBD,"^",2,3)
..I '$$FILTER^IBCNINSU(VAL,IBFILT) S IBNOT=1
.;
.Q:IBNOT ; entry does not meet criteria
.;
.;
.; - set entry in global
.S IBTMP=$P(IBDA0,U,1)_U
.;IB*732/CKB - do not truncate the REIMBURSE field
.S IBX=$P(IBDA0,U,2) S $P(IBTMP,U,2)=$S(IBX]"":$$EXPAND^IBTRE(36,1,IBX),1:"")_U
.F IBX=1:1:6 S IBTMP=IBTMP_$P(IBDA11,U,IBX)_U
.;S IBX=$P(IBTMP,U,7) S $P(IBTMP,U,7)=$S(IBX]"":$$STATE^IBCF2(IBX),1:"")_U
.;/vd-IB*2.0*664 - Replaced the above line with the following 2 lines.
.S IBX=$P(IBTMP,U,7) S $P(IBTMP,U,7)=$S(IBX]"":$$STATE^IBCF2(IBX),1:"")
.S IBX=$P(IBTMP,U,8) S $P(IBTMP,U,8)=$S($L(IBX)=9:$E(IBX,1,5)_"-"_$E(IBX,6,9),1:IBX)
.;
.S $P(IBTMP,U,9)=$P(IBDA13,U,1)
.S ^TMP("IBCOMD",$J,+$P(IBDA0,U,5),$S($P(IBDA0,U,1)]"":$P(IBDA0,U,1),1:"ZZZZ"),+IBDA)=IBTMP
;
I '$D(^TMP("IBCOMD",$J)) D HD W !!,"** NO DATA FOUND **" G END
D HD:IBOUT="E",WRT
;
END ;IB*732/CKB - add End of Report
I $G(IBQUIT)'=1 D
. W !! I IBOUT="R" W ?30
. W "*** End of Report ***",!
. D ASK
;
; Exit clean-up
QUEQ K IBAIB,IBCASE,IBFLD,IBOUT,IBQUIT,^TMP("IBCOMD",$J)
I $D(ZTQUEUED) S ZTREQ="@" Q
W ! D ^%ZISC
Q
;
;
HD ; Write Heading
S IBPAGE=IBPAGE+1
;IB*732/CKB - added call to ASK here and checking IBQUIT
I IBPAGE>1 D ASK I IBQUIT=1 Q
; IB*602/HN ; Add report headers to Excel Spreadsheets
I IBOUT="E" D Q
.W !,"Generate Insurance Company Listings^"_$$FMTE^XLFDT($$NOW^XLFDT,1)
.W !,"List of ",$S(IBAIB=1:"Active",IBAIB=2:"Inactive",1:"All")," Insurance Companies"
.;
.; - display definition of screens
.I $D(IBCASE) W "^where" D
..N I,H
..S (H,I)=0 F S I=$O(IBCASE(I)) Q:'I D
...; IB*664/DW ; update display of filter to remove delimiters between each word
...;I H W "^and"
...;S H=1 W "^"_IBFLD(I)
...;W $S(I=4:"^Equals ",$P(IBCASE(I),"^")="C":"^Contains ",1:"^Between ")
...;W $S(I=4:$P($G(^DIC(5,+$P(IBCASE(I),"^",2),0)),"^"),$P(IBCASE(I),"^",2)="":"^'FIRST'",1:$P(IBCASE(I),"^",2))
...;I $P(IBCASE(I),"^")="R" W "^and ",$S($P(IBCASE(I),"^",3)="zzzzzz":"^'LAST'",1:$P(IBCASE(I),"^",3)) ; **IB*2.0*602
...I H W " and"
...S H=1 W " "_IBFLD(I)
...W $S(I=4:" Equals ",$P(IBCASE(I),"^")="C":" Contains ",1:" Between ")
...W $S(I=4:$P($G(^DIC(5,+$P(IBCASE(I),"^",2),0)),"^"),$P(IBCASE(I),"^",2)="":"'FIRST'",1:$P(IBCASE(I),"^",2))
...I $P(IBCASE(I),"^")="R" W " and ",$S($P(IBCASE(I),"^",3)="zzzzzz":"'LAST'",1:$P(IBCASE(I),"^",3))
...; IB*664/DW end changes
.;
.W !,"Active/Inactive^Insurance Name^Reimburse?^Street Address 1^Street Address 2^Street Address 3^City^State^ZIP^Phone Number"
; IB*602/HN end
;
I IBOUT="E" W:($E(IOST,1,2)["C-") ! W "Active/Inactive^Insurance Name^Reimburse?^Street Address 1^Street Address 2^Street Address 3^City^State^ZIP^Phone Number" Q
W @IOF,"Generate Insurance Company Listings",?50,$$FMTE^XLFDT($$NOW^XLFDT,"Z"),?70," Page ",IBPAGE
W !,"List of ",$S(IBAIB=1:"Active",IBAIB=2:"Inactive",1:"All")," Insurance Companies"
;
; - display definition of screens
I $D(IBCASE) W ", where" D
.N I,H
.S (H,I)=0 F S I=$O(IBCASE(I)) Q:'I D
..W ! I H W ?3,"and"
..S H=1 W ?8,IBFLD(I)," "
..W $S(I=4:"Equals ",$P(IBCASE(I),"^")="C":"Contains ",1:"Between ")
..W $S(I=4:$P($G(^DIC(5,+$P(IBCASE(I),"^",2),0)),"^"),$P(IBCASE(I),"^",2)="":"'FIRST'",1:$P(IBCASE(I),"^",2))
..I $P(IBCASE(I),"^")="R" W " and ",$S($P(IBCASE(I),"^",3)="zzzzzz":"'LAST'",1:$P(IBCASE(I),"^",3))
;
W !,"Insurance Name/Address",?33,"Reimburse?",?56,"Phone Number"
W ! F IBX=1:1:79 W "="
Q
;
WRT ; Write data lines
;IB*732/CKB - put variables in alphabetical order
N IBA,IBACT,IBNA,IBOFF,X,Y
S IBQUIT=0
S IBA="" F S IBA=$O(^TMP("IBCOMD",$J,IBA)) Q:(IBA="")!(IBQUIT=1) D
.;I IBPAGE,(IBOUT="R") D ASK I IBQUIT=1 Q ;IB*732/CKB - moved D ASK to HD
.; Excel Output
.I IBOUT="E" S IBACT=$S(IBA=1:"Inactive",1:"Active")
.; Report Output
.I IBOUT="R" D HD W !,$S(IBA=1:"Inactive Companies",1:"Active Companies"),!
.S IBNA="" F S IBNA=$O(^TMP("IBCOMD",$J,IBA,IBNA)) Q:(IBNA="")!(IBQUIT=1) D
..S IBDA="" F S IBDA=$O(^TMP("IBCOMD",$J,IBA,IBNA,IBDA)) Q:('IBDA)!(IBQUIT=1) D
...S IBTMP=^TMP("IBCOMD",$J,IBA,IBNA,IBDA)
...S IBOFF=$S($P(IBTMP,U,4)]""!($P(IBTMP,U,5)]""):7,1:6)
...I ($Y+IBOFF)>IOSL,(IBOUT="R") D I IBQUIT=1 Q
....;IB*732/CKB - moved D ASK to HD
....I IBQUIT=1 Q ;D ASK I IBQUIT=1 Q
....D HD
...S IBTMP=^TMP("IBCOMD",$J,IBA,IBNA,IBDA)
...; Excel Output
...I IBOUT="E" W !,IBACT_U_IBTMP Q
...; Report Output
...;IB*732/CKB - only truncte the REIMBURSE field for the Report output, not Excel
...W !!,$P(IBTMP,U,1),?33,$E($P(IBTMP,U,2),1,20),?56,$P(IBTMP,U,9)
...I $P(IBTMP,U,3)]"" W !,$P(IBTMP,U,3)
...I $P(IBTMP,U,4)]""!($P(IBTMP,U,5)]"") W !,$P(IBTMP,U,4) W:$P(IBTMP,U,4)]""&($P(IBTMP,U,5)]"") ", " W $P(IBTMP,U,5)
...W !,$P(IBTMP,U,6) W:$P(IBTMP,U,6)]""&($P(IBTMP,U,7)]"") ", " W $P(IBTMP,U,7)," ",$P(IBTMP,U,8)
;I 'IBQUIT D ASK ;IB*732/CKB - moved D ASK to HD
Q
;
ASK ; Ask to Continue with display
; Returns IBQUIT=1 if user Timed out or entered ^
I $E(IOST,1,2)'["C-" Q
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,IBI,X,Y
S DIR(0)="E" D ^DIR
I ($D(DIRUT))!($D(DUOUT))!(X="^") S IBQUIT=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCOMD1 7842 printed Apr 09, 2024@21:27:52 Page 2
IBCOMD1 ;ALB/CMS - GENERATE INSURANCE COMPANY LISTINGS ;03-AUG-98
+1 ;;2.0;INTEGRATED BILLING;**103,528,602,664,732**;21-MAR-94;Build 13
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
BEG ; Queued entry point.
+1 ; Input variables:
+2 ;
+3 ; IBCASE(n) = x ^ y ^ z (Optional), where
+4 ; n = 1-4 (1:Name, 2:Street, 3:City, 4:State)
+5 ; x = C (Contains), or R (RANGE)
+6 ; y = Pointer to the STATE (#5) file, if n=4
+7 ; The 'Contains' value, if x = C
+8 ; The 'Start From' value, if x = R
+9 ; z = The 'Go To' value, if x = R
+10 ;
+11 ; IBFLD(n) = x (Required), where
+12 ; n = 1-4 (1:Name, 2:Street, 3:City, 4:State)
+13 ; x = NAME (n=1), STREET (n=2), CITY (n=3), STATE (n=4)
+14 ;
+15 ; IBAIB - Required. Include Active Insurance
+16 ; 1= Active Ins. 2= Inactive Ins. 3= Both
+17 ; IBOUT - Required. Output format
+18 ; "R"= report format "E"= Excel format
+19 ;
+20 ;IB*732/CKB - put variables in alphabetical order
+21 NEW IBDA,IBDA0,IBDA11,IBDA13,IBI,IBJ,IBNOT,IBPAGE,IBTMP,IBX,X,Y
+22 ;
+23 ;IB*732/CKB
IF $EXTRACT(IOST,1,2)["C-"
WRITE !!,?15,"... One Moment Please ..."
+24 ;
+25 IF "^R^E^"'[(U_$GET(IBOUT)_U)
SET IBOUT="R"
+26 KILL ^TMP("IBCOMD",$JOB)
SET IBPAGE=0
+27 ;
+28 ; - must look at all entries in file #36
+29 SET IBDA=0
FOR
SET IBDA=$ORDER(^DIC(36,IBDA))
if 'IBDA
QUIT
SET IBDA0=$GET(^(IBDA,0))
Begin DoDot:1
+30 ;
+31 ; - screen out active/inactive companies
+32 IF IBAIB=1
IF $PIECE(IBDA0,U,5)
QUIT
+33 IF IBAIB=2
IF '$PIECE(IBDA0,U,5)
QUIT
+34 ;
+35 SET IBDA11=$GET(^DIC(36,IBDA,.11))
SET IBDA13=$GET(^(.13))
+36 ;
+37 ; - screen out entries based on user-selected field screens
+38 SET (IBJ,IBNOT)=0
FOR
SET IBJ=$ORDER(IBCASE(IBJ))
if 'IBJ
QUIT
Begin DoDot:2
+39 NEW IBD,VAL
SET IBD=IBCASE(IBJ)
+40 ;
+41 ; - check state first
+42 IF IBJ=4
if $PIECE(IBDA11,"^",5)'=$PIECE(IBD,"^",2)
SET IBNOT=1
QUIT
+43 ;
+44 ;IB*732/CKB - modified to check street address lines 1-3
+45 ; Convert field & values to uppercase (case insensitive)
+46 ; - find the field value to be evaluated
+47 SET VAL=$SELECT(IBJ=1:$PIECE(IBDA0,"^"),1:$PIECE(IBDA11,"^",4))
+48 IF IBJ=2
SET VAL=$PIECE(IBDA11,"^",1,3)
+49 SET VAL=$$UP^XLFSTR(VAL)
+50 FOR I=2:1:3
IF $PIECE(IBD,"^",I)'=""
SET $PIECE(IBD,"^",I)=$$UP^XLFSTR($PIECE(IBD,"^",I))
+51 ;
+52 ;IB*732/CKB - call $$FILTER^IBCNINSU to check 'contains' AND 'range' values
+53 ; - check 'contains' values
+54 ;I $P(IBD,"^")="C" S:VAL'[$P(IBD,"^",2) IBNOT=1 Q
+55 ;
+56 ; - check 'range' values
+57 ; VAL must have a value in a range
IF VAL=""
SET IBNOT=1
QUIT
+58 ;I $P(IBD,"^",2)]VAL S IBNOT=1 Q ; VAL doesn't follow Start value
+59 ;I VAL]$P(IBD,"^",3) S IBNOT=1 ; VAL follows the Go To value
+60 ;IB*732/CKB - added IBFILT (Converts Contains=2, Range=3)
+61 NEW IBFILT
+62 SET IBFILT=$SELECT($PIECE(IBD,"^")="C":2,1:3)_"^"_$PIECE(IBD,"^",2,3)
+63 IF '$$FILTER^IBCNINSU(VAL,IBFILT)
SET IBNOT=1
End DoDot:2
if IBNOT
QUIT
+64 ;
+65 ; entry does not meet criteria
if IBNOT
QUIT
+66 ;
+67 ;
+68 ; - set entry in global
+69 SET IBTMP=$PIECE(IBDA0,U,1)_U
+70 ;IB*732/CKB - do not truncate the REIMBURSE field
+71 SET IBX=$PIECE(IBDA0,U,2)
SET $PIECE(IBTMP,U,2)=$SELECT(IBX]"":$$EXPAND^IBTRE(36,1,IBX),1:"")_U
+72 FOR IBX=1:1:6
SET IBTMP=IBTMP_$PIECE(IBDA11,U,IBX)_U
+73 ;S IBX=$P(IBTMP,U,7) S $P(IBTMP,U,7)=$S(IBX]"":$$STATE^IBCF2(IBX),1:"")_U
+74 ;/vd-IB*2.0*664 - Replaced the above line with the following 2 lines.
+75 SET IBX=$PIECE(IBTMP,U,7)
SET $PIECE(IBTMP,U,7)=$SELECT(IBX]"":$$STATE^IBCF2(IBX),1:"")
+76 SET IBX=$PIECE(IBTMP,U,8)
SET $PIECE(IBTMP,U,8)=$SELECT($LENGTH(IBX)=9:$EXTRACT(IBX,1,5)_"-"_$EXTRACT(IBX,6,9),1:IBX)
+77 ;
+78 SET $PIECE(IBTMP,U,9)=$PIECE(IBDA13,U,1)
+79 SET ^TMP("IBCOMD",$JOB,+$PIECE(IBDA0,U,5),$SELECT($PIECE(IBDA0,U,1)]"":$PIECE(IBDA0,U,1),1:"ZZZZ"),+IBDA)=IBTMP
End DoDot:1
+80 ;
+81 IF '$DATA(^TMP("IBCOMD",$JOB))
DO HD
WRITE !!,"** NO DATA FOUND **"
GOTO END
+82 if IBOUT="E"
DO HD
DO WRT
+83 ;
END ;IB*732/CKB - add End of Report
+1 IF $GET(IBQUIT)'=1
Begin DoDot:1
+2 WRITE !!
IF IBOUT="R"
WRITE ?30
+3 WRITE "*** End of Report ***",!
+4 DO ASK
End DoDot:1
+5 ;
+6 ; Exit clean-up
QUEQ KILL IBAIB,IBCASE,IBFLD,IBOUT,IBQUIT,^TMP("IBCOMD",$JOB)
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+2 WRITE !
DO ^%ZISC
+3 QUIT
+4 ;
+5 ;
HD ; Write Heading
+1 SET IBPAGE=IBPAGE+1
+2 ;IB*732/CKB - added call to ASK here and checking IBQUIT
+3 IF IBPAGE>1
DO ASK
IF IBQUIT=1
QUIT
+4 ; IB*602/HN ; Add report headers to Excel Spreadsheets
+5 IF IBOUT="E"
Begin DoDot:1
+6 WRITE !,"Generate Insurance Company Listings^"_$$FMTE^XLFDT($$NOW^XLFDT,1)
+7 WRITE !,"List of ",$SELECT(IBAIB=1:"Active",IBAIB=2:"Inactive",1:"All")," Insurance Companies"
+8 ;
+9 ; - display definition of screens
+10 IF $DATA(IBCASE)
WRITE "^where"
Begin DoDot:2
+11 NEW I,H
+12 SET (H,I)=0
FOR
SET I=$ORDER(IBCASE(I))
if 'I
QUIT
Begin DoDot:3
+13 ; IB*664/DW ; update display of filter to remove delimiters between each word
+14 ;I H W "^and"
+15 ;S H=1 W "^"_IBFLD(I)
+16 ;W $S(I=4:"^Equals ",$P(IBCASE(I),"^")="C":"^Contains ",1:"^Between ")
+17 ;W $S(I=4:$P($G(^DIC(5,+$P(IBCASE(I),"^",2),0)),"^"),$P(IBCASE(I),"^",2)="":"^'FIRST'",1:$P(IBCASE(I),"^",2))
+18 ;I $P(IBCASE(I),"^")="R" W "^and ",$S($P(IBCASE(I),"^",3)="zzzzzz":"^'LAST'",1:$P(IBCASE(I),"^",3)) ; **IB*2.0*602
+19 IF H
WRITE " and"
+20 SET H=1
WRITE " "_IBFLD(I)
+21 WRITE $SELECT(I=4:" Equals ",$PIECE(IBCASE(I),"^")="C":" Contains ",1:" Between ")
+22 WRITE $SELECT(I=4:$PIECE($GET(^DIC(5,+$PIECE(IBCASE(I),"^",2),0)),"^"),$PIECE(IBCASE(I),"^",2)="":"'FIRST'",1:$PIECE(IBCASE(I),"^",2))
+23 IF $PIECE(IBCASE(I),"^")="R"
WRITE " and ",$SELECT($PIECE(IBCASE(I),"^",3)="zzzzzz":"'LAST'",1:$PIECE(IBCASE(I),"^",3))
+24 ; IB*664/DW end changes
End DoDot:3
End DoDot:2
+25 ;
+26 WRITE !,"Active/Inactive^Insurance Name^Reimburse?^Street Address 1^Street Address 2^Street Address 3^City^State^ZIP^Phone Number"
End DoDot:1
QUIT
+27 ; IB*602/HN end
+28 ;
+29 IF IBOUT="E"
if ($EXTRACT(IOST,1,2)["C-")
WRITE !
WRITE "Active/Inactive^Insurance Name^Reimburse?^Street Address 1^Street Address 2^Street Address 3^City^State^ZIP^Phone Number"
QUIT
+30 WRITE @IOF,"Generate Insurance Company Listings",?50,$$FMTE^XLFDT($$NOW^XLFDT,"Z"),?70," Page ",IBPAGE
+31 WRITE !,"List of ",$SELECT(IBAIB=1:"Active",IBAIB=2:"Inactive",1:"All")," Insurance Companies"
+32 ;
+33 ; - display definition of screens
+34 IF $DATA(IBCASE)
WRITE ", where"
Begin DoDot:1
+35 NEW I,H
+36 SET (H,I)=0
FOR
SET I=$ORDER(IBCASE(I))
if 'I
QUIT
Begin DoDot:2
+37 WRITE !
IF H
WRITE ?3,"and"
+38 SET H=1
WRITE ?8,IBFLD(I)," "
+39 WRITE $SELECT(I=4:"Equals ",$PIECE(IBCASE(I),"^")="C":"Contains ",1:"Between ")
+40 WRITE $SELECT(I=4:$PIECE($GET(^DIC(5,+$PIECE(IBCASE(I),"^",2),0)),"^"),$PIECE(IBCASE(I),"^",2)="":"'FIRST'",1:$PIECE(IBCASE(I),"^",2))
+41 IF $PIECE(IBCASE(I),"^")="R"
WRITE " and ",$SELECT($PIECE(IBCASE(I),"^",3)="zzzzzz":"'LAST'",1:$PIECE(IBCASE(I),"^",3))
End DoDot:2
End DoDot:1
+42 ;
+43 WRITE !,"Insurance Name/Address",?33,"Reimburse?",?56,"Phone Number"
+44 WRITE !
FOR IBX=1:1:79
WRITE "="
+45 QUIT
+46 ;
WRT ; Write data lines
+1 ;IB*732/CKB - put variables in alphabetical order
+2 NEW IBA,IBACT,IBNA,IBOFF,X,Y
+3 SET IBQUIT=0
+4 SET IBA=""
FOR
SET IBA=$ORDER(^TMP("IBCOMD",$JOB,IBA))
if (IBA="")!(IBQUIT=1)
QUIT
Begin DoDot:1
+5 ;I IBPAGE,(IBOUT="R") D ASK I IBQUIT=1 Q ;IB*732/CKB - moved D ASK to HD
+6 ; Excel Output
+7 IF IBOUT="E"
SET IBACT=$SELECT(IBA=1:"Inactive",1:"Active")
+8 ; Report Output
+9 IF IBOUT="R"
DO HD
WRITE !,$SELECT(IBA=1:"Inactive Companies",1:"Active Companies"),!
+10 SET IBNA=""
FOR
SET IBNA=$ORDER(^TMP("IBCOMD",$JOB,IBA,IBNA))
if (IBNA="")!(IBQUIT=1)
QUIT
Begin DoDot:2
+11 SET IBDA=""
FOR
SET IBDA=$ORDER(^TMP("IBCOMD",$JOB,IBA,IBNA,IBDA))
if ('IBDA)!(IBQUIT=1)
QUIT
Begin DoDot:3
+12 SET IBTMP=^TMP("IBCOMD",$JOB,IBA,IBNA,IBDA)
+13 SET IBOFF=$SELECT($PIECE(IBTMP,U,4)]""!($PIECE(IBTMP,U,5)]""):7,1:6)
+14 IF ($Y+IBOFF)>IOSL
IF (IBOUT="R")
Begin DoDot:4
+15 ;IB*732/CKB - moved D ASK to HD
+16 ;D ASK I IBQUIT=1 Q
IF IBQUIT=1
QUIT
+17 DO HD
End DoDot:4
IF IBQUIT=1
QUIT
+18 SET IBTMP=^TMP("IBCOMD",$JOB,IBA,IBNA,IBDA)
+19 ; Excel Output
+20 IF IBOUT="E"
WRITE !,IBACT_U_IBTMP
QUIT
+21 ; Report Output
+22 ;IB*732/CKB - only truncte the REIMBURSE field for the Report output, not Excel
+23 WRITE !!,$PIECE(IBTMP,U,1),?33,$EXTRACT($PIECE(IBTMP,U,2),1,20),?56,$PIECE(IBTMP,U,9)
+24 IF $PIECE(IBTMP,U,3)]""
WRITE !,$PIECE(IBTMP,U,3)
+25 IF $PIECE(IBTMP,U,4)]""!($PIECE(IBTMP,U,5)]"")
WRITE !,$PIECE(IBTMP,U,4)
if $PIECE(IBTMP,U,4)]""&($PIECE(IBTMP,U,5)]"")
WRITE ", "
WRITE $PIECE(IBTMP,U,5)
+26 WRITE !,$PIECE(IBTMP,U,6)
if $PIECE(IBTMP,U,6)]""&($PIECE(IBTMP,U,7)]"")
WRITE ", "
WRITE $PIECE(IBTMP,U,7)," ",$PIECE(IBTMP,U,8)
End DoDot:3
End DoDot:2
End DoDot:1
+27 ;I 'IBQUIT D ASK ;IB*732/CKB - moved D ASK to HD
+28 QUIT
+29 ;
ASK ; Ask to Continue with display
+1 ; Returns IBQUIT=1 if user Timed out or entered ^
+2 IF $EXTRACT(IOST,1,2)'["C-"
QUIT
+3 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,IBI,X,Y
+4 SET DIR(0)="E"
DO ^DIR
+5 IF ($DATA(DIRUT))!($DATA(DUOUT))!(X="^")
SET IBQUIT=1
+6 QUIT
