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