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

IBCOMD1.m

Go to the documentation of this file. 
  1. 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
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  Q
  1.  ;
  1. BEG ; Queued entry point.
  1.  ;  Input variables:
  1.  ;
  1.  ;  IBCASE(n) = x ^ y ^ z  (Optional), where
  1.  ;     n = 1-4  (1:Name, 2:Street, 3:City, 4:State)
  1.  ;     x = C (Contains), or R (RANGE)
  1.  ;     y = Pointer to the STATE (#5) file, if n=4
  1.  ;         The 'Contains' value, if x = C
  1.  ;         The 'Start From' value, if x = R
  1.  ;     z = The 'Go To' value, if x = R
  1.  ;
  1.  ;  IBFLD(n) = x  (Required), where
  1.  ;     n = 1-4  (1:Name, 2:Street, 3:City, 4:State)
  1.  ;     x = NAME (n=1), STREET (n=2), CITY (n=3), STATE (n=4)
  1.  ;
  1.  ;  IBAIB - Required.   Include Active Insurance
  1.  ;          1= Active Ins.   2= Inactive Ins. 3= Both
  1.  ;  IBOUT - Required.   Output format
  1.  ;          "R"= report format         "E"= Excel format
  1.  ;
  1.  ;IB*732/CKB - put variables in alphabetical order
  1.  N IBDA,IBDA0,IBDA11,IBDA13,IBI,IBJ,IBNOT,IBPAGE,IBTMP,IBX,X,Y
  1.  ;
  1.  I $E(IOST,1,2)["C-" W !!,?15,"... One Moment Please ..." ;IB*732/CKB
  1.  ;
  1.  I "^R^E^"'[(U_$G(IBOUT)_U) S IBOUT="R"
  1.  K ^TMP("IBCOMD",$J) S IBPAGE=0
  1.  ;
  1.  ; - must look at all entries in file #36
  1.  S IBDA=0 F  S IBDA=$O(^DIC(36,IBDA)) Q:'IBDA  S IBDA0=$G(^(IBDA,0)) D
  1.  .;
  1.  .; - screen out active/inactive companies
  1.  .I IBAIB=1,$P(IBDA0,U,5) Q
  1.  .I IBAIB=2,'$P(IBDA0,U,5) Q
  1.  .;
  1.  .S IBDA11=$G(^DIC(36,IBDA,.11)),IBDA13=$G(^(.13))
  1.  .;
  1.  .; - screen out entries based on user-selected field screens
  1.  .S (IBJ,IBNOT)=0 F  S IBJ=$O(IBCASE(IBJ)) Q:'IBJ  D  Q:IBNOT
  1.  ..N IBD,VAL S IBD=IBCASE(IBJ)
  1.  ..;
  1.  ..; - check state first
  1.  ..I IBJ=4 S:$P(IBDA11,"^",5)'=$P(IBD,"^",2) IBNOT=1 Q
  1.  ..;
  1.  ..;IB*732/CKB - modified to check street address lines 1-3
  1.  ..; Convert field & values to uppercase (case insensitive)
  1.  ..; - find the field value to be evaluated
  1.  ..S VAL=$S(IBJ=1:$P(IBDA0,"^"),1:$P(IBDA11,"^",4))
  1.  ..I IBJ=2 S VAL=$P(IBDA11,"^",1,3)
  1.  ..S VAL=$$UP^XLFSTR(VAL)
  1.  ..F I=2:1:3 I $P(IBD,"^",I)'="" S $P(IBD,"^",I)=$$UP^XLFSTR($P(IBD,"^",I))
  1.  ..;
  1.  ..;IB*732/CKB - call $$FILTER^IBCNINSU to check 'contains' AND 'range' values
  1.  ..; - check 'contains' values
  1.  ..;I $P(IBD,"^")="C" S:VAL'[$P(IBD,"^",2) IBNOT=1 Q
  1.  ..;
  1.  ..; - check 'range' values
  1.  ..I VAL="" S IBNOT=1 Q  ; VAL must have a value in a range
  1.  ..;I $P(IBD,"^",2)]VAL S IBNOT=1 Q  ; VAL doesn't follow Start value
  1.  ..;I VAL]$P(IBD,"^",3) S IBNOT=1 ;    VAL follows the Go To value
  1.  ..;IB*732/CKB - added IBFILT (Converts Contains=2, Range=3)
  1.  ..N IBFILT
  1.  ..S IBFILT=$S($P(IBD,"^")="C":2,1:3)_"^"_$P(IBD,"^",2,3)
  1.  ..I '$$FILTER^IBCNINSU(VAL,IBFILT) S IBNOT=1
  1.  .;
  1.  .Q:IBNOT  ; entry does not meet criteria
  1.  .;
  1.  .;
  1.  .; - set entry in global
  1.  .S IBTMP=$P(IBDA0,U,1)_U
  1.  .;IB*732/CKB - do not truncate the REIMBURSE field
  1.  .S IBX=$P(IBDA0,U,2) S $P(IBTMP,U,2)=$S(IBX]"":$$EXPAND^IBTRE(36,1,IBX),1:"")_U
  1.  .F IBX=1:1:6 S IBTMP=IBTMP_$P(IBDA11,U,IBX)_U
  1.  .;S IBX=$P(IBTMP,U,7) S $P(IBTMP,U,7)=$S(IBX]"":$$STATE^IBCF2(IBX),1:"")_U
  1.  .;/vd-IB*2.0*664 - Replaced the above line with the following 2 lines.
  1.  .S IBX=$P(IBTMP,U,7) S $P(IBTMP,U,7)=$S(IBX]"":$$STATE^IBCF2(IBX),1:"")
  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)
  1.  .;
  1.  .S $P(IBTMP,U,9)=$P(IBDA13,U,1)
  1.  .S ^TMP("IBCOMD",$J,+$P(IBDA0,U,5),$S($P(IBDA0,U,1)]"":$P(IBDA0,U,1),1:"ZZZZ"),+IBDA)=IBTMP
  1.  ;
  1.  I '$D(^TMP("IBCOMD",$J)) D HD W !!,"** NO DATA FOUND **" G END
  1.  D HD:IBOUT="E",WRT
  1.  ;
  1. END ;IB*732/CKB - add End of Report
  1.  I $G(IBQUIT)'=1 D
  1.  . W !! I IBOUT="R" W ?30
  1.  . W "*** End of Report ***",!
  1.  . D ASK
  1.  ; 
  1.  ; Exit clean-up
  1. QUEQ K IBAIB,IBCASE,IBFLD,IBOUT,IBQUIT,^TMP("IBCOMD",$J)
  1.  I $D(ZTQUEUED) S ZTREQ="@" Q
  1.  W ! D ^%ZISC
  1.  Q
  1.  ;
  1.  ;
  1. HD ; Write Heading
  1.  S IBPAGE=IBPAGE+1
  1.  ;IB*732/CKB - added call to ASK here and checking IBQUIT
  1.  I IBPAGE>1 D ASK I IBQUIT=1 Q
  1.  ; IB*602/HN ; Add report headers to Excel Spreadsheets
  1.  I IBOUT="E" D  Q
  1.  .W !,"Generate Insurance Company Listings^"_$$FMTE^XLFDT($$NOW^XLFDT,1)
  1.  .W !,"List of ",$S(IBAIB=1:"Active",IBAIB=2:"Inactive",1:"All")," Insurance Companies"
  1.  .;
  1.  .; - display definition of screens
  1.  .I $D(IBCASE) W "^where" D
  1.  ..N I,H
  1.  ..S (H,I)=0 F  S I=$O(IBCASE(I)) Q:'I  D
  1.  ...; IB*664/DW ; update display of filter to remove delimiters between each word
  1.  ...;I H W "^and"
  1.  ...;S H=1 W "^"_IBFLD(I)
  1.  ...;W $S(I=4:"^Equals ",$P(IBCASE(I),"^")="C":"^Contains ",1:"^Between ")
  1.  ...;W $S(I=4:$P($G(^DIC(5,+$P(IBCASE(I),"^",2),0)),"^"),$P(IBCASE(I),"^",2)="":"^'FIRST'",1:$P(IBCASE(I),"^",2))
  1.  ...;I $P(IBCASE(I),"^")="R" W "^and ",$S($P(IBCASE(I),"^",3)="zzzzzz":"^'LAST'",1:$P(IBCASE(I),"^",3)) ; **IB*2.0*602
  1.  ...I H W " and"
  1.  ...S H=1 W " "_IBFLD(I)
  1.  ...W $S(I=4:" Equals ",$P(IBCASE(I),"^")="C":" Contains ",1:" Between ")
  1.  ...W $S(I=4:$P($G(^DIC(5,+$P(IBCASE(I),"^",2),0)),"^"),$P(IBCASE(I),"^",2)="":"'FIRST'",1:$P(IBCASE(I),"^",2))
  1.  ...I $P(IBCASE(I),"^")="R" W " and ",$S($P(IBCASE(I),"^",3)="zzzzzz":"'LAST'",1:$P(IBCASE(I),"^",3))
  1.  ...; IB*664/DW end changes
  1.  .;
  1.  .W !,"Active/Inactive^Insurance Name^Reimburse?^Street Address 1^Street Address 2^Street Address 3^City^State^ZIP^Phone Number"
  1.  ; IB*602/HN end 
  1.  ;
  1.  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
  1.  W @IOF,"Generate Insurance Company Listings",?50,$$FMTE^XLFDT($$NOW^XLFDT,"Z"),?70," Page ",IBPAGE
  1.  W !,"List of ",$S(IBAIB=1:"Active",IBAIB=2:"Inactive",1:"All")," Insurance Companies"
  1.  ;
  1.  ; - display definition of screens
  1.  I $D(IBCASE) W ", where" D
  1.  .N I,H
  1.  .S (H,I)=0 F  S I=$O(IBCASE(I)) Q:'I  D
  1.  ..W ! I H W ?3,"and"
  1.  ..S H=1 W ?8,IBFLD(I)," "
  1.  ..W $S(I=4:"Equals ",$P(IBCASE(I),"^")="C":"Contains ",1:"Between ")
  1.  ..W $S(I=4:$P($G(^DIC(5,+$P(IBCASE(I),"^",2),0)),"^"),$P(IBCASE(I),"^",2)="":"'FIRST'",1:$P(IBCASE(I),"^",2))
  1.  ..I $P(IBCASE(I),"^")="R" W " and ",$S($P(IBCASE(I),"^",3)="zzzzzz":"'LAST'",1:$P(IBCASE(I),"^",3))
  1.  ;
  1.  W !,"Insurance Name/Address",?33,"Reimburse?",?56,"Phone Number"
  1.  W ! F IBX=1:1:79 W "="
  1.  Q
  1.  ;
  1. WRT ; Write data lines
  1.  ;IB*732/CKB - put variables in alphabetical order
  1.  N IBA,IBACT,IBNA,IBOFF,X,Y
  1.  S IBQUIT=0
  1.  S IBA="" F  S IBA=$O(^TMP("IBCOMD",$J,IBA)) Q:(IBA="")!(IBQUIT=1)  D
  1.  .;I IBPAGE,(IBOUT="R") D ASK I IBQUIT=1 Q  ;IB*732/CKB - moved D ASK to HD
  1.  .; Excel Output
  1.  .I IBOUT="E" S IBACT=$S(IBA=1:"Inactive",1:"Active")
  1.  .; Report Output
  1.  .I IBOUT="R" D HD W !,$S(IBA=1:"Inactive Companies",1:"Active Companies"),!
  1.  .S IBNA="" F  S IBNA=$O(^TMP("IBCOMD",$J,IBA,IBNA)) Q:(IBNA="")!(IBQUIT=1)  D
  1.  ..S IBDA="" F  S IBDA=$O(^TMP("IBCOMD",$J,IBA,IBNA,IBDA)) Q:('IBDA)!(IBQUIT=1)  D
  1.  ...S IBTMP=^TMP("IBCOMD",$J,IBA,IBNA,IBDA)
  1.  ...S IBOFF=$S($P(IBTMP,U,4)]""!($P(IBTMP,U,5)]""):7,1:6)
  1.  ...I ($Y+IBOFF)>IOSL,(IBOUT="R") D  I IBQUIT=1 Q
  1.  ....;IB*732/CKB - moved D ASK to HD
  1.  ....I IBQUIT=1 Q  ;D ASK I IBQUIT=1 Q
  1.  ....D HD
  1.  ...S IBTMP=^TMP("IBCOMD",$J,IBA,IBNA,IBDA)
  1.  ...; Excel Output
  1.  ...I IBOUT="E" W !,IBACT_U_IBTMP Q
  1.  ...; Report Output
  1.  ...;IB*732/CKB - only truncte the REIMBURSE field for the Report output, not Excel
  1.  ...W !!,$P(IBTMP,U,1),?33,$E($P(IBTMP,U,2),1,20),?56,$P(IBTMP,U,9)
  1.  ...I $P(IBTMP,U,3)]"" W !,$P(IBTMP,U,3)
  1.  ...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)
  1.  ...W !,$P(IBTMP,U,6) W:$P(IBTMP,U,6)]""&($P(IBTMP,U,7)]"") ", " W $P(IBTMP,U,7),"  ",$P(IBTMP,U,8)
  1.  ;I 'IBQUIT D ASK ;IB*732/CKB - moved D ASK to HD
  1.  Q
  1.  ;
  1. ASK ; Ask to Continue with display
  1.  ; Returns IBQUIT=1 if user Timed out or entered ^
  1.  I $E(IOST,1,2)'["C-" Q
  1.  N DIR,DIROUT,DIRUT,DTOUT,DUOUT,IBI,X,Y
  1.  S DIR(0)="E" D ^DIR
  1.  I ($D(DIRUT))!($D(DUOUT))!(X="^") S IBQUIT=1
  1.  Q