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

IBCNINSC.m

Go to the documentation of this file. 
  1. IBCNINSC ;AITC/DG/TAZ - GENERAL INSURANCE UTILITIES - INSURANCE COMPANY LOOKUP ;02/01/23
  1.  ;;2.0;INTEGRATED BILLING;**752,763,771**;21-MAR-94;Build 26
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  ; Reference to RECALL^DILFD supported by ICR #2055
  1.  Q
  1.  ;
  1. INSOCAS(ARRY,IBNE,IBLIMIT,IBSCR) ; lookup for case insensitive
  1.  ;INPUT:
  1.  ; ARRY   - REQUIRED return array passed by reference
  1.  ; IBNE    - OPTIONAL single lookup or many   single=1  many=0 or null  default is many
  1.  ; IBLIMIT - OPTIONAL limiting the number of found/selected items default is no limit
  1.  ; IBSCR    - OPTIONAL screen for item passed by reference (like DIC("S")) Default is no screen
  1.  ;              ( If a screen is used, variable 'X' is the input value, 'Y' is the IEN if one.
  1.  ;                Naked references should not be used, unless the screen has initiated the reference
  1.  ;                to the file/level that the naked is working with. )
  1.  ;
  1.  ;
  1.  ;OUTPUT:
  1.  ; ARRY   - The return array:
  1.  ;           ARRY=number of insurances selected
  1.  ;           ARRY(IEN of insurance company) = insurance company IEN ^ the complete zero node for that insurance company
  1.  ;           ARRY='^' If the person quits (enters an '^' up-caret at the select Insurance prompt and no other selected)
  1.  ;           ARRY='Insurance company name as entered by user' IF optional single lookup is one (IBNE=1)
  1.  ;                 AND the name entered is not found.
  1.  ;
  1.  ;IB*763/TAZ - Added IBSBR to new statement
  1.  N C,DIR,DIROUT,DIRUT,DTOUT,DUOUT,IBA,IBB,IBC,IBCT,IBD,IBFILTER,IBFND,IBI,IBINDX,IBJ,IBK,IBL
  1.  N IBLKNM,IBLKX,IBLM,IBLKUNM,IBN,IBNMA,IBNMR,IBNML,IBOK,IBOK1,IBOK2,IBPROMPT,IBR,IBRNM,IBSBR,IBTIC,IBTMPA
  1.  N IBTMPFIL,IBTMPTRK,IBTN,IBX,IBXN,X,Y
  1.  ;
  1.  I $G(U)'="^" S U="^"
  1.  I '+DT S DT=$$DT^XLFDT
  1.  ;
  1.  S IBPROMPT="INSURANCE COMPANY"
  1.  S IBNE=+$G(IBNE),IBLIMIT=$G(IBLIMIT),IBSCR=$G(IBSCR)
  1.  ; get IDENTIFIED BY: for display
  1.  K IBLKX S IBI="" F  S IBI=$O(^DD(36,0,"ID",IBI)) Q:'IBI  S IBLKX(IBI)=$G(^DD(36,0,"ID",IBI))
  1.  S IBI=""
  1.  ;
  1.  K ARRY S ARRY=""
  1. INSOCAS1 ; entry point for loop back
  1.  ;
  1.  S IBSBR=0
  1.  S IBA="Select "_($S(+$G(ARRY)>0:"another ",1:""))_IBPROMPT
  1.  S IBTMPFIL="^TMP("_$J_",""IBCNINSC_LKUP"")" K @IBTMPFIL
  1.  S IBTMPTRK="^TMP("_$J_",""IBCNINSC_TRK"")" K @IBTMPTRK
  1.  S IBFILTER=1  ; 1 - begins with
  1.  K DIR,DIROUT,DIRUT,DTOUT,DUOUT
  1.  S DIR(0)="FO^1:30"
  1.  S DIR("A")=IBA
  1.  S DIR("?")="^D HLPLST^IBCNINSC"
  1.  S DIR("??")="^D HLPLSA^IBCNINSC"
  1.  D ^DIR
  1.  I $E(Y)=U!($D(DTOUT))!($D(DUOUT))!($D(DIROUT)) S:'$G(ARRY) ARRY=U G INSOCASX
  1.  ;IB*763/TAZ-DTG - Added processing for Spacebar return or tic and IEN ex: ' ' or '`12345'
  1.  I $E(Y)="`" S IBTIC=1 D  I 'IBTIC W "   Insurance Company IEN not found" G INSOCAS1  ;IB*763/DTG validate that the IEN for the tic is real.
  1.  . N IBTR S IBTR=$E(Y,2,$L(Y)) I IBTR="" S IBTIC=0 Q  ; IB*763/DTG must start with a number
  1.  . I '$D(^DIC(36,IBTR,0)) S IBTIC=0  ; IB*763/DTG must be a found record.
  1.  I Y=" "!($E(Y)="`") N X,DIC S X=Y,DIC=36 D ^DIC I Y G:$$SELECTED(Y) INSOCAS1 D  G SKIPLKUP
  1.  . S IBSBR=1
  1.  . S IBC=$G(@IBTMPFIL@(0))+1,@IBTMPFIL@(0)=IBC
  1.  . S @IBTMPFIL@(IBC)=$P(Y,U,2)_U_+Y,@IBTMPTRK@(+Y)=1
  1.  . S IBX=X,IBFND=""
  1.  I Y="" G INSOCASX
  1.  S IBFND=""
  1.  S IBX=X
  1.  S IBLKNM=Y,IBLKUNM=$$UP^XLFSTR(IBLKNM),IBNML=$L(IBLKUNM),X=IBLKNM
  1.  ; collect names
  1.  K @IBTMPFIL
  1.  K @IBTMPTRK
  1.  S @IBTMPFIL@(0)=0,IBOK=0
  1.  ; check B and C indexes
  1.  F IBINDX="B","C" S (IBFND,IBNMA,IBNMR)="" D
  1.  . F  S IBNMA=$O(^DIC(36,IBINDX,IBNMA)) Q:IBNMA=""  S IBOK="" D
  1.  .. S IBA=IBNMA,IBB=$$UP^XLFSTR(IBNMA)
  1.  .. S IBOK=$$FILTER^IBCNINSU(IBB,IBFILTER_U_IBLKUNM) I 'IBOK Q
  1.  .. S IBNMR="" F  S IBNMR=$O(^DIC(36,IBINDX,IBNMA,IBNMR)) Q:'IBNMR  D
  1.  ... I '$D(^DIC(36,+IBNMR,0)) Q  ;IB*763/DTG to protect against bad index value
  1.  ... S IBN=IBNMR
  1.  ... S IBOK1=1 I IBSCR'="" S IBOK1=0,Y=+IBN X IBSCR I  S IBOK1=1
  1.  ... I 'IBOK1 Q
  1.  ... I $G(@IBTMPTRK@(IBN))=1 Q  ; only select the item once
  1.  ... S IBC=@IBTMPFIL@(0)+1,@IBTMPFIL@(0)=IBC
  1.  ... S @IBTMPFIL@(IBC)=IBA_U_IBN
  1.  ... I IBINDX="C" S @IBTMPFIL@(IBC)=@IBTMPFIL@(IBC)_U_$P($G(^DIC(36,IBN,0)),U,1)
  1.  ... S @IBTMPTRK@(IBN)=1
  1.  ;
  1. SKIPLKUP ; Bypass Lookup if spacebar-return used. IB*763/TAZ
  1.  ;
  1.  ; display / select displayed names
  1.  ; no insurance found
  1.  I '@IBTMPFIL@(0) S IBFND="",IBOK=0 D  G INSOCAS1:'IBOK,INSOCASX
  1.  . ;I IBNE,'ARRY S ARRY=X,IBOK=1 Q  ; if only one insurance allowed treat as a new insurance if an insurance has not been selected
  1.  . I IBNE,'ARRY D  Q:IBOK  ;IB*763/DTG only use if minimum 3 characters in length
  1.  . . I $L(X)>2 S ARRY=X,IBOK=1 Q  ; if only one insurance allowed treat as a new insurance if an insurance has not been selected
  1.  . W "   No Insurance names found that match the criteria."
  1.  ;
  1.  ; if only one item found
  1.  S IBOK=0 I +$G(@IBTMPFIL@(0))=1 D  G INSOCASX:'IBOK,INSOCAS1  ;exit if only one insurance is allowed
  1.  . S IBE=$$IBESET($G(@IBTMPFIL@(1)))
  1.  . S IBFND=$$FNDSET(IBE)
  1.  . D ARSET(IBFND)
  1.  . ;IB*763/TAZ - Print complete Ins Co Name for spacebar-return
  1.  . S IBXN=$E($P(IBE,U,2),$S(IBSBR:0,1:($L(IBX)+1)),($L($P(IBE,U,2))))
  1.  . D DISPADDR(IBXN,+IBE,"",1,$P(IBE,U,3))
  1.  . I 'IBNE S IBOK=1
  1.  ;
  1.  ;
  1.  S IBFND="",IBCT=$G(@IBTMPFIL@(0)),IBR="",IBTN=$FN((IBCT/5),"",1),IBR=+$P(IBTN,".",1)*5,IBTN=$P(IBTN,".",2)
  1.  S:IBTN IBR=IBR+5 K IBTMPA
  1.  S IBTN="" I IBCT<6 M IBTMPA=@IBTMPFIL K IBTMPA(0) D  G INSOP
  1.  . S IBK=IBCT,IBFND=$$INSD(.IBTMPA,0,IBK)
  1.  . I +IBFND D DISPADDR("  "_$P(IBFND,U,2),+IBFND,"",1)
  1.  S IBK=0
  1.  F IBI=0:5:IBR Q:IBFND!(IBFND=U)  K IBTMPA F IBJ=1:1:5 S IBK=IBI+IBJ D  Q:IBFND!(IBFND=U)!(IBK>IBCT)
  1.  . S IBD=$G(@IBTMPFIL@(IBK)),IBFND="" I IBD'="" S IBTMPA(IBK)=IBD
  1.  . I IBD=""!(IBJ=5) S IBL=$S(IBK<IBCT:1,IBK=IBCT:0,1:0) D
  1.  . . S IBLM=IBK I 'IBL&(IBK>IBCT) S IBLM=IBCT
  1.  . . S IBFND=$$INSD(.IBTMPA,IBL,IBLM)
  1.  . . I +IBFND D DISPADDR("  "_$P(IBFND,U,2),+IBFND,"",1)
  1.  ;
  1. INSOP ; process return
  1.  I IBFND=U G INSOCAS1
  1.  I 'IBFND G INSOCAS1
  1.  D ARSET(IBFND)
  1.  I +IBNE G INSOCASX
  1.  I +IBLIMIT,(+ARRY=+IBLIMIT) D  G INSOCASX
  1.  . W !,"Maximum allowed selected items of "_IBLIMIT_" has been reached"
  1.  G INSOCAS1
  1.  ;
  1. INSOCASX ; insurance lookup exit point
  1.  K @IBTMPFIL
  1.  K DIR,DIROUT,DIRUT,DTOUT,DUOUT,IBA,IBB,IBC,IBCT,IBFILTER,IBFND,IBI,IBJ,IBK,IBL
  1.  K IBLKNM,IBLM,IBLKUNM,IBN,IBNMA,IBNMR,IBNML,IBOK,IBOK1,IBPROMPT,IBR,IBTMPA,IBTMPFIL,IBTN,X,Y
  1.  ;END
  1.  Q
  1.  ;
  1. IBESET(IBSTR) ; set IBE equal to array item
  1.  ;
  1.  ; IBSTR - item string to parse
  1.  ;
  1.  N IBA S IBA=""
  1.  S IBA=$P(IBSTR,U,2)_U_$P(IBSTR,U,1)_U_$P(IBSTR,U,3)
  1.  ;IB*763/TAZ - Added "spacebar-return" functionality to recall the last insurance company selected.
  1.  D RECALL^DILFD(36,+IBA_",",DUZ)  ;ICR #2055
  1.  Q IBA
  1.  ;
  1. FNDSET(IBIN) ; set string to be saved in the return array
  1.  ;
  1.  ; IBIN - string to be parsed
  1.  ;
  1.  N IBF S IBF=""
  1.  S IBF=+IBIN_U_($S($P(IBIN,U,3)'="":$P(IBIN,U,3),1:$P(IBIN,U,2)))_U_$P($G(^DIC(36,+IBIN,0)),U,2,999)
  1.  Q IBF
  1.  ;
  1. ARSET(IBITM) ; set item into ARRY
  1.  ;
  1.  ; IBITM - data to be set into ARRY (form IEN^NAME^zero node minus .01)
  1.  ;
  1.  I IBITM="" Q
  1.  S ARRY(+IBITM)=IBITM,ARRY=$G(ARRY)+1
  1.  Q
  1.  ;
  1. INSD(IBARY,IBO,IBLM) ; display up to 5 insurances for selection at a time.
  1.  ; IBARY - 5 items to display
  1.  ; IBO - are there more to display
  1.  ; IBLM - max number counter
  1.  ;
  1.  I $O(IBARY(0))="" Q ""
  1.  N DIR,DIRUT,DIROUT,IBA,IBB,IBD,IBE,IBM,X,Y
  1.  ; array is insurance name ^ insurance #36 ien ^ insurance real name(.01) if synonym is beibg used
  1. INSDA ; loop back point
  1.  K DIR
  1.  S DIR(0)="LCO^1:"_IBLM,IBA=0 F  S IBA=$O(IBARY(IBA)) Q:'IBA  D
  1.  . S IBD=IBARY(IBA)
  1.  . S IBM=$P(IBD,U,1)
  1.  . D DISPADDR(IBM,$P(IBD,U,2),IBA,"",$P(IBD,U,3))
  1.  S DIR("?")="Enter the Item Number for the Insurance desired"
  1.  S DIR("A")="CHOOSE"
  1.  I IBO=1 D
  1.  . S DIR("A",1)="Press "_($S(IBO=1:"<Enter> to see more, ",1:""))_"'^' to exit this list,  OR"
  1.  D ^DIR
  1.  I $E(Y)=U S IBFND=U Q IBFND
  1.  I 'Y Q ""
  1.  S IBE=$$IBESET($G(@IBTMPFIL@(+Y)))
  1.  I $$SELECTED(IBE) G INSDA
  1.  ; return ien ^ name ^ zero node
  1.  S IBFND=$$FNDSET(IBE)
  1.  Q IBFND
  1.  ;
  1.  ;IB*763/TAZ - Created subroutine so could be called from multiple locations.
  1. SELECTED(IBE) ; Check to see if selected.
  1.  N SEL S SEL=0
  1.  I $D(ARRY(+IBE)) W:IBSBR $P(IBE,U,2) W !!?3,"Already selected. Choose another insurance company.",!,*7 S SEL=1
  1.  Q SEL
  1.  ;
  1. DISPADDR(IBNAME,IBNMIEN,IBNUM,IBPCK,IBRNM) ; display the item with identifying info
  1.  ;
  1.  ; IBNAME - Item name to display
  1.  ; IBNMIEN - Item IEN
  1.  ; IBNUM - item number
  1.  ; IBPCK - is this a picked item
  1.  ; IBRNM - If IBNAME is a synonym this is the real name (.01)
  1.  ;
  1.  N DIC,IBAA,IBAB,IBAC,X,Y
  1.  I +IBNMIEN<1 Q  ;IB*771/DTG to protect against bad IEN values
  1.  I '$D(^DIC(36,+IBNMIEN,0)) Q  ;IB*771/DTG to protect against bad index value
  1.  S DIC="^DIC(36,",IBNUM=$G(IBNUM),IBPCK=+$G(IBPCK),IBRNM=$G(IBRNM)
  1.  I 'IBPCK W !
  1.  I IBNUM W ?5,IBNUM,?10
  1.  W IBNAME
  1.  I IBRNM'="" W "  ",IBRNM
  1.  S Y=IBNMIEN S IBAC=$G(^DIC(36,Y,0)),IBAA=""
  1.  W " " F  S IBAA=$O(IBLKX(IBAA)) Q:'IBAA  S IBAB=$G(IBLKX(IBAA)) I IBAB'="" X IBAB
  1.  ;
  1.  Q
  1.  ;
  1. HLPLST ; list out Insurance cos. in 'B' index in groups of 20
  1.  ;
  1.  N DIC,DIR,DTOUT,DUOUT,IBA,IBB,IBC,IBD,IBOK,X,Y
  1.  W !,"Answer with INSURANCE COMPANY NAME, or SYNONYM"
  1.  S IBD=$P($G(^DIC(36,0)),U,4)
  1.  K DIR S DIR("A")="Do you want the entire "_IBD_"-Entry INSURANCE COMPANY List",DIR(0)="YO"
  1.  D ^DIR
  1.  I 'Y!(Y=U) Q
  1.  D HLPLSA
  1.  Q
  1.  ;
  1. HLPLSA ; to list all without question
  1.  N DIC,DIR,DTOUT,DUOUT,IBA,IBB,IBC,IBD,IBOK,X,Y
  1.  S IBA="",IBC=0 K DIR
  1.  F  S IBA=$O(^DIC(36,"B",IBA)) Q:IBA=""  S IBOK=1 D  Q:'IBOK
  1.  . ;S IBB="" F  S IBB=$O(^DIC(36,"B",IBA,IBB)) Q:IBB=""  S IBC=IBC+1 D  Q:'IBOK
  1.  . S IBB="" F  S IBB=$O(^DIC(36,"B",IBA,IBB)) Q:IBB=""  D  Q:'IBOK
  1.  .. I +IBB<1 Q  ;IB*771/DTG to protect against bad IEN values
  1.  .. I '$D(^DIC(36,+IBB,0)) Q  ;IB*771/DTG to protect against bad index value
  1.  .. S IBC=IBC+1
  1.  .. D DISPADDR(IBA,IBB,"","")
  1.  .. I IBC#20'=0 Q
  1.  .. S DIR(0)="E" D ^DIR K DIR
  1.  .. I $D(DTOUT)!($D(DUOUT)) S IBOK=0
  1.  W !!,"        You may enter a new INSURANCE COMPANY, if you wish"
  1.  W !,"        Answer must be 3-30 characters in length."
  1.  Q
  1.  ;