IBCNSC02 ;ALB/ESG - Insurance Company parent/child management ;01-NOV-2005
;;2.0;INTEGRATED BILLING;**320,371,547,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
Q
;
DISP ; entry point for display of parent/child companies
NEW PCFLG,PARENT,PCDESC,TITLE,START,IBLINE,OFFSET,INSDATA,CNT,TXT
S PCFLG=$P($G(^DIC(36,+IBCNS,3)),U,13),PARENT=""
I PCFLG="C" S PARENT=$P($G(^DIC(36,+IBCNS,3)),U,14),PCDESC="Child"
I PCFLG="P" S PCDESC="Parent"
S TITLE=" Associated Insurance Companies "
;
;WCJ;IB*2.0*547
;S (START,IBLINE)=62
S (START,IBLINE)=70+(2*IBACMAX) ; KDM US2487 IB*2.0*592 adjust display item for dental address
S OFFSET=(40-($L(TITLE)/2))\1+1
D SET^IBCNSP(START,OFFSET,TITLE,IORVON,IORVOFF)
;
; no link - display this and get out
I PCFLG="" D G DISPX
. S IBLINE=IBLINE+1
. D SET^IBCNSP(IBLINE,3,"This insurance company is not defined as either a Parent or a Child.")
. Q
;
; display for either parent or child
S IBLINE=IBLINE+1
D SET^IBCNSP(IBLINE,3,"This insurance company is defined as a "_PCDESC_" Insurance Company.")
;
; child display
I PCFLG="C" D G DISPX
. S IBLINE=IBLINE+1
. D SET^IBCNSP(IBLINE,3,"It is associated with the following Parent Insurance Company:")
. S IBLINE=IBLINE+1
. D SET^IBCNSP(IBLINE,2," ") ; blank line
. S INSDATA=""
. I 'PARENT S INSDATA="*** Parent Insurance Company not defined ***"
. I PARENT D
.. N AD S AD=$$INSADD(PARENT) ; get parent ins co data
.. S INSDATA=$P(AD,U,1)_" "_$P(AD,U,2)_" "_$P(AD,U,6)
.. Q
. S IBLINE=IBLINE+1
. D SET^IBCNSP(IBLINE,8,INSDATA)
. Q
;
; parent display
S CNT=$$PCNT(IBCNS) ; count # of children
S TXT="There are "_CNT_" Child Insurance Companies"
I CNT=1 S TXT="There is 1 Child Insurance Company"
S TXT=TXT_" associated with it."
S IBLINE=IBLINE+1
D SET^IBCNSP(IBLINE,3,TXT)
S IBLINE=IBLINE+1
D SET^IBCNSP(IBLINE,3,"Select the ""AC Associate Companies"" action to enter/edit the children.")
;
DISPX ; end with 2 blank lines
S IBLINE=IBLINE+1
D SET^IBCNSP(IBLINE,2," ") ; blank line
S IBLINE=IBLINE+1
D SET^IBCNSP(IBLINE,2," ") ; blank line
Q
;
PARENT(IBCNS) ; Insurance company parent/child management
; Calls ListMan screen for parent insurance companies
NEW PCFLG
I '$G(IBCNS) G PARENTX
S PCFLG=$P($G(^DIC(36,IBCNS,3)),U,13)
;
; special check to remove 3.13 field if 3.14 field is nil
I PCFLG="C",'$P($G(^DIC(36,IBCNS,3)),U,14) D
. N DIE,DA,DR S DIE=36,DA=IBCNS,DR="3.13////@" D ^DIE
. Q
;
; get out if not a parent insurance company
I PCFLG'="P" G PARENTX
;
; call ListMan for parent/children management
D EN^VALM("IBCNS ASSOCIATIONS LIST")
KILL ^TMP($J,"IBCNSL")
PARENTX ;
Q
;
HDR ; List header info
S VALMHDR(1)="Parent Insurance Company:"
S VALMHDR(2)=" "_$$INSCO(IBCNS)
S VALMHDR(3)=""
HDRX ;
Q
;
BLD ; Build list contents
NEW C,INSDATA,INSNAME,STCITY,ENTRY,NM,ST,IEN,X
KILL ^TMP($J,"IBCNSL")
S C=0
F S C=$O(^DIC(36,"APC",IBCNS,C)) Q:'C D
. S INSDATA=$$INSADD(C)
. S INSNAME=$P(INSDATA,U,1)
. I INSNAME="" S INSNAME="~UNKNOWN"
. S STCITY=$P(INSDATA,U,7)
. I STCITY="" S STCITY="~UNKNOWN"
. S ^TMP($J,"IBCNSL",1,INSNAME,STCITY,C)=""
. Q
;
I '$D(^TMP($J,"IBCNSL",1)) D G BLDX
. ; no children insurance companies found
. S ^TMP($J,"IBCNSL",2,1,0)=""
. S ^TMP($J,"IBCNSL",2,2,0)=" No Children Insurance Companies Found"
. S VALMCNT=2
. Q
;
S VALMCNT=0,ENTRY=0
S NM=""
F S NM=$O(^TMP($J,"IBCNSL",1,NM)) Q:NM="" D
. S ST=""
. F S ST=$O(^TMP($J,"IBCNSL",1,NM,ST)) Q:ST="" D
.. S IEN=0
.. F S IEN=$O(^TMP($J,"IBCNSL",1,NM,ST,IEN)) Q:'IEN D
... S VALMCNT=VALMCNT+1,ENTRY=ENTRY+1
... S X=$$FO^IBCNEUT1($J(ENTRY,3),5)_$$INSCO(IEN)
... S ^TMP($J,"IBCNSL",2,VALMCNT,0)=X
... S ^TMP($J,"IBCNSL",2,"IDX",VALMCNT,ENTRY)=""
... S ^TMP($J,"IBCNSL",3,ENTRY)=IEN_U_VALMCNT
... Q
.. Q
. Q
BLDX ;
Q
;
LINK ; action protocol IBCNSL LINK used to associate children insurance
; companies to the current parent ins co for the list
NEW DIC,X,Y,DIE,DR,DA,NEWINS,IBSTOP,PAR,DIR,DIRUT,DTOUT,DUOUT,DIROUT
D FULL^VALM1
I '$$KCHK^XUSRB("IB EDI INSURANCE EDIT") D G LINKX
. W !!?5,"You must hold the IB EDI INSURANCE EDIT key to access this option."
. D PAUSE^VALM1
. Q
;
; lookup ins company
W !
S DIC=36,DIC(0)="AEMQ",DIC("A")="Select Insurance Company: "
S DIC("W")="D INSLIST^IBCNSC02(Y)"
; screen - ins co Y is not a parent and also it is not already in the list of children
S DIC("S")="I $P($G(^DIC(36,Y,3)),U,13)'=""P""&'$D(^DIC(36,""APC"",IBCNS,Y))"
D ^DIC K DIC
I +Y'>0 G LINKX
S NEWINS=+Y
;
; check to see if this selected insurance company is already a child
; for some other parent
S PAR=+$P($G(^DIC(36,NEWINS,3)),U,14),IBSTOP=0
I PAR,PAR'=IBCNS D
. W !
. S DIR(0)="YO",DIR("B")="No"
. S DIR("A",1)="Please Note: The insurance company you selected is currently identified"
. S DIR("A",2)="as a Child insurance company associated with the following Parent:"
. S DIR("A",3)=""
. S DIR("A",4)=" "_$$INSCO(PAR)
. S DIR("A",5)=""
. S DIR("A")="OK to proceed and make this switch"
. D ^DIR K DIR
. I Y'=1 S IBSTOP=1 Q
. Q
I IBSTOP G LINKX
;
; lock the potential new child ins company
L +^DIC(36,NEWINS):0 I '$T D LOCKED^IBTRCD1 G LINKX
;
; update selected child
S DIE=36,DA=NEWINS,DR="3.13////C;3.14////"_IBCNS D ^DIE
;
; Copy the IDs from the parent
D COPY^IBCEPCID(NEWINS)
;
; unlock
L -^DIC(36,NEWINS)
;
D BLD ; rebuild list of children
LINKX ;
S VALMBCK="R"
Q
;
UNLINK ; action protocol IBCNSL UNLINK used to disassociate selected children
; insurance companies from the list.
NEW DIR,X,Y,DIRUT,DTOUT,DUOUT,DIROUT,IBLST,IBSUB,IBPCE,IBSEL,DA,DIE,DR
D FULL^VALM1
I '$$KCHK^XUSRB("IB EDI INSURANCE EDIT") D G UNLINKX
. W !!?5,"You must hold the IB EDI INSURANCE EDIT key to access this option."
. D PAUSE^VALM1
. Q
;
I '$D(^TMP($J,"IBCNSL",3)) D G UNLINKX
. W !!?5,"There are no insurance companies to select." D PAUSE^VALM1
. Q
S DIR(0)="LO^1:"_+$O(^TMP($J,"IBCNSL",3,""),-1)
S DIR("A")="Select Insurance Company(s)"
W ! D ^DIR K DIR
I $D(DIRUT) G UNLINKX
M IBLST=Y
;
W !
S DIR(0)="YO"
S DIR("A")="OK to proceed",DIR("B")="No"
D ^DIR K DIR
I Y'=1 G UNLINKX
;
F IBSUB=0:1 Q:'$D(IBLST(IBSUB)) F IBPCE=1:1 S IBSEL=$P(IBLST(IBSUB),",",IBPCE) Q:'IBSEL D
. S DA=+$G(^TMP($J,"IBCNSL",3,IBSEL)) I 'DA Q
. S DIE=36,DR="3.13////@;3.14////@" D ^DIE
. Q
;
D BLD ; rebuild list of children
UNLINKX ;
S VALMBCK="R"
Q
;
PCNT(Z) ; count number of children for parent ins co Z
NEW C,CNT
S C=0,Z=+$G(Z)
F CNT=0:1 S C=$O(^DIC(36,"APC",Z,C)) Q:'C
Q CNT
;
INSADD(Z) ; function to return ins co address components
NEW INSDATA,AD,NM,L1,CITY,ST,ZIP,CITYST,STCITY
S INSDATA=""
S AD=$G(^DIC(36,+$G(Z),.11))
S NM=$P($G(^DIC(36,Z,0)),U,1)
S L1=$P(AD,U,1),CITY=$P(AD,U,4),ST=$P(AD,U,5),ZIP=$P(AD,U,6)
I ST S ST=$P($G(^DIC(5,ST,0)),U,2)
S CITYST=$E(CITY,1,15)_" "_ST
I CITY'="",ST'="" S CITYST=$E(CITY,1,15)_","_ST
;
S $P(STCITY,"|",1)=ST
I ST="" S $P(STCITY,"|",1)="~~"
S $P(STCITY,"|",2)=CITY
I CITY="" S $P(STCITY,"|",2)="~~~~"
;
S INSDATA=NM_U_L1_U_CITY_U_ST_U_ZIP_U_CITYST_U_STCITY
; 1 2 3 4 5 6 7
INSADDX ;
Q INSDATA
;
INSCO(Z) ; return display data for ins co Z
NEW X,Y
S Y=$$INSADD(Z)
S X=$$FO^IBCNEUT1($P(Y,U,1),27)
S X=X_$$FO^IBCNEUT1($P(Y,U,2),26)
S X=X_$$FO^IBCNEUT1($P(Y,U,6),18)
INSCOX ;
Q X
;
INSLIST(INS) ; insurance company lister for ^DIC call
NEW Z
S Z=$$INSADD(INS)
W ?27,$E($P(Z,U,2),1,20) ; address line 1
W ?47," ",$P(Z,U,6) ; city, state
INSLISTX ;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSC02 7829 printed Apr 09, 2024@21:09:08 Page 2
IBCNSC02 ;ALB/ESG - Insurance Company parent/child management ;01-NOV-2005
+1 ;;2.0;INTEGRATED BILLING;**320,371,547,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
DISP ; entry point for display of parent/child companies
+1 NEW PCFLG,PARENT,PCDESC,TITLE,START,IBLINE,OFFSET,INSDATA,CNT,TXT
+2 SET PCFLG=$PIECE($GET(^DIC(36,+IBCNS,3)),U,13)
SET PARENT=""
+3 IF PCFLG="C"
SET PARENT=$PIECE($GET(^DIC(36,+IBCNS,3)),U,14)
SET PCDESC="Child"
+4 IF PCFLG="P"
SET PCDESC="Parent"
+5 SET TITLE=" Associated Insurance Companies "
+6 ;
+7 ;WCJ;IB*2.0*547
+8 ;S (START,IBLINE)=62
+9 ; KDM US2487 IB*2.0*592 adjust display item for dental address
SET (START,IBLINE)=70+(2*IBACMAX)
+10 SET OFFSET=(40-($LENGTH(TITLE)/2))\1+1
+11 DO SET^IBCNSP(START,OFFSET,TITLE,IORVON,IORVOFF)
+12 ;
+13 ; no link - display this and get out
+14 IF PCFLG=""
Begin DoDot:1
+15 SET IBLINE=IBLINE+1
+16 DO SET^IBCNSP(IBLINE,3,"This insurance company is not defined as either a Parent or a Child.")
+17 QUIT
End DoDot:1
GOTO DISPX
+18 ;
+19 ; display for either parent or child
+20 SET IBLINE=IBLINE+1
+21 DO SET^IBCNSP(IBLINE,3,"This insurance company is defined as a "_PCDESC_" Insurance Company.")
+22 ;
+23 ; child display
+24 IF PCFLG="C"
Begin DoDot:1
+25 SET IBLINE=IBLINE+1
+26 DO SET^IBCNSP(IBLINE,3,"It is associated with the following Parent Insurance Company:")
+27 SET IBLINE=IBLINE+1
+28 ; blank line
DO SET^IBCNSP(IBLINE,2," ")
+29 SET INSDATA=""
+30 IF 'PARENT
SET INSDATA="*** Parent Insurance Company not defined ***"
+31 IF PARENT
Begin DoDot:2
+32 ; get parent ins co data
NEW AD
SET AD=$$INSADD(PARENT)
+33 SET INSDATA=$PIECE(AD,U,1)_" "_$PIECE(AD,U,2)_" "_$PIECE(AD,U,6)
+34 QUIT
End DoDot:2
+35 SET IBLINE=IBLINE+1
+36 DO SET^IBCNSP(IBLINE,8,INSDATA)
+37 QUIT
End DoDot:1
GOTO DISPX
+38 ;
+39 ; parent display
+40 ; count # of children
SET CNT=$$PCNT(IBCNS)
+41 SET TXT="There are "_CNT_" Child Insurance Companies"
+42 IF CNT=1
SET TXT="There is 1 Child Insurance Company"
+43 SET TXT=TXT_" associated with it."
+44 SET IBLINE=IBLINE+1
+45 DO SET^IBCNSP(IBLINE,3,TXT)
+46 SET IBLINE=IBLINE+1
+47 DO SET^IBCNSP(IBLINE,3,"Select the ""AC Associate Companies"" action to enter/edit the children.")
+48 ;
DISPX ; end with 2 blank lines
+1 SET IBLINE=IBLINE+1
+2 ; blank line
DO SET^IBCNSP(IBLINE,2," ")
+3 SET IBLINE=IBLINE+1
+4 ; blank line
DO SET^IBCNSP(IBLINE,2," ")
+5 QUIT
+6 ;
PARENT(IBCNS) ; Insurance company parent/child management
+1 ; Calls ListMan screen for parent insurance companies
+2 NEW PCFLG
+3 IF '$GET(IBCNS)
GOTO PARENTX
+4 SET PCFLG=$PIECE($GET(^DIC(36,IBCNS,3)),U,13)
+5 ;
+6 ; special check to remove 3.13 field if 3.14 field is nil
+7 IF PCFLG="C"
IF '$PIECE($GET(^DIC(36,IBCNS,3)),U,14)
Begin DoDot:1
+8 NEW DIE,DA,DR
SET DIE=36
SET DA=IBCNS
SET DR="3.13////@"
DO ^DIE
+9 QUIT
End DoDot:1
+10 ;
+11 ; get out if not a parent insurance company
+12 IF PCFLG'="P"
GOTO PARENTX
+13 ;
+14 ; call ListMan for parent/children management
+15 DO EN^VALM("IBCNS ASSOCIATIONS LIST")
+16 KILL ^TMP($JOB,"IBCNSL")
PARENTX ;
+1 QUIT
+2 ;
HDR ; List header info
+1 SET VALMHDR(1)="Parent Insurance Company:"
+2 SET VALMHDR(2)=" "_$$INSCO(IBCNS)
+3 SET VALMHDR(3)=""
HDRX ;
+1 QUIT
+2 ;
BLD ; Build list contents
+1 NEW C,INSDATA,INSNAME,STCITY,ENTRY,NM,ST,IEN,X
+2 KILL ^TMP($JOB,"IBCNSL")
+3 SET C=0
+4 FOR
SET C=$ORDER(^DIC(36,"APC",IBCNS,C))
if 'C
QUIT
Begin DoDot:1
+5 SET INSDATA=$$INSADD(C)
+6 SET INSNAME=$PIECE(INSDATA,U,1)
+7 IF INSNAME=""
SET INSNAME="~UNKNOWN"
+8 SET STCITY=$PIECE(INSDATA,U,7)
+9 IF STCITY=""
SET STCITY="~UNKNOWN"
+10 SET ^TMP($JOB,"IBCNSL",1,INSNAME,STCITY,C)=""
+11 QUIT
End DoDot:1
+12 ;
+13 IF '$DATA(^TMP($JOB,"IBCNSL",1))
Begin DoDot:1
+14 ; no children insurance companies found
+15 SET ^TMP($JOB,"IBCNSL",2,1,0)=""
+16 SET ^TMP($JOB,"IBCNSL",2,2,0)=" No Children Insurance Companies Found"
+17 SET VALMCNT=2
+18 QUIT
End DoDot:1
GOTO BLDX
+19 ;
+20 SET VALMCNT=0
SET ENTRY=0
+21 SET NM=""
+22 FOR
SET NM=$ORDER(^TMP($JOB,"IBCNSL",1,NM))
if NM=""
QUIT
Begin DoDot:1
+23 SET ST=""
+24 FOR
SET ST=$ORDER(^TMP($JOB,"IBCNSL",1,NM,ST))
if ST=""
QUIT
Begin DoDot:2
+25 SET IEN=0
+26 FOR
SET IEN=$ORDER(^TMP($JOB,"IBCNSL",1,NM,ST,IEN))
if 'IEN
QUIT
Begin DoDot:3
+27 SET VALMCNT=VALMCNT+1
SET ENTRY=ENTRY+1
+28 SET X=$$FO^IBCNEUT1($JUSTIFY(ENTRY,3),5)_$$INSCO(IEN)
+29 SET ^TMP($JOB,"IBCNSL",2,VALMCNT,0)=X
+30 SET ^TMP($JOB,"IBCNSL",2,"IDX",VALMCNT,ENTRY)=""
+31 SET ^TMP($JOB,"IBCNSL",3,ENTRY)=IEN_U_VALMCNT
+32 QUIT
End DoDot:3
+33 QUIT
End DoDot:2
+34 QUIT
End DoDot:1
BLDX ;
+1 QUIT
+2 ;
LINK ; action protocol IBCNSL LINK used to associate children insurance
+1 ; companies to the current parent ins co for the list
+2 NEW DIC,X,Y,DIE,DR,DA,NEWINS,IBSTOP,PAR,DIR,DIRUT,DTOUT,DUOUT,DIROUT
+3 DO FULL^VALM1
+4 IF '$$KCHK^XUSRB("IB EDI INSURANCE EDIT")
Begin DoDot:1
+5 WRITE !!?5,"You must hold the IB EDI INSURANCE EDIT key to access this option."
+6 DO PAUSE^VALM1
+7 QUIT
End DoDot:1
GOTO LINKX
+8 ;
+9 ; lookup ins company
+10 WRITE !
+11 SET DIC=36
SET DIC(0)="AEMQ"
SET DIC("A")="Select Insurance Company: "
+12 SET DIC("W")="D INSLIST^IBCNSC02(Y)"
+13 ; screen - ins co Y is not a parent and also it is not already in the list of children
+14 SET DIC("S")="I $P($G(^DIC(36,Y,3)),U,13)'=""P""&'$D(^DIC(36,""APC"",IBCNS,Y))"
+15 DO ^DIC
KILL DIC
+16 IF +Y'>0
GOTO LINKX
+17 SET NEWINS=+Y
+18 ;
+19 ; check to see if this selected insurance company is already a child
+20 ; for some other parent
+21 SET PAR=+$PIECE($GET(^DIC(36,NEWINS,3)),U,14)
SET IBSTOP=0
+22 IF PAR
IF PAR'=IBCNS
Begin DoDot:1
+23 WRITE !
+24 SET DIR(0)="YO"
SET DIR("B")="No"
+25 SET DIR("A",1)="Please Note: The insurance company you selected is currently identified"
+26 SET DIR("A",2)="as a Child insurance company associated with the following Parent:"
+27 SET DIR("A",3)=""
+28 SET DIR("A",4)=" "_$$INSCO(PAR)
+29 SET DIR("A",5)=""
+30 SET DIR("A")="OK to proceed and make this switch"
+31 DO ^DIR
KILL DIR
+32 IF Y'=1
SET IBSTOP=1
QUIT
+33 QUIT
End DoDot:1
+34 IF IBSTOP
GOTO LINKX
+35 ;
+36 ; lock the potential new child ins company
+37 LOCK +^DIC(36,NEWINS):0
IF '$TEST
DO LOCKED^IBTRCD1
GOTO LINKX
+38 ;
+39 ; update selected child
+40 SET DIE=36
SET DA=NEWINS
SET DR="3.13////C;3.14////"_IBCNS
DO ^DIE
+41 ;
+42 ; Copy the IDs from the parent
+43 DO COPY^IBCEPCID(NEWINS)
+44 ;
+45 ; unlock
+46 LOCK -^DIC(36,NEWINS)
+47 ;
+48 ; rebuild list of children
DO BLD
LINKX ;
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
UNLINK ; action protocol IBCNSL UNLINK used to disassociate selected children
+1 ; insurance companies from the list.
+2 NEW DIR,X,Y,DIRUT,DTOUT,DUOUT,DIROUT,IBLST,IBSUB,IBPCE,IBSEL,DA,DIE,DR
+3 DO FULL^VALM1
+4 IF '$$KCHK^XUSRB("IB EDI INSURANCE EDIT")
Begin DoDot:1
+5 WRITE !!?5,"You must hold the IB EDI INSURANCE EDIT key to access this option."
+6 DO PAUSE^VALM1
+7 QUIT
End DoDot:1
GOTO UNLINKX
+8 ;
+9 IF '$DATA(^TMP($JOB,"IBCNSL",3))
Begin DoDot:1
+10 WRITE !!?5,"There are no insurance companies to select."
DO PAUSE^VALM1
+11 QUIT
End DoDot:1
GOTO UNLINKX
+12 SET DIR(0)="LO^1:"_+$ORDER(^TMP($JOB,"IBCNSL",3,""),-1)
+13 SET DIR("A")="Select Insurance Company(s)"
+14 WRITE !
DO ^DIR
KILL DIR
+15 IF $DATA(DIRUT)
GOTO UNLINKX
+16 MERGE IBLST=Y
+17 ;
+18 WRITE !
+19 SET DIR(0)="YO"
+20 SET DIR("A")="OK to proceed"
SET DIR("B")="No"
+21 DO ^DIR
KILL DIR
+22 IF Y'=1
GOTO UNLINKX
+23 ;
+24 FOR IBSUB=0:1
if '$DATA(IBLST(IBSUB))
QUIT
FOR IBPCE=1:1
SET IBSEL=$PIECE(IBLST(IBSUB),",",IBPCE)
if 'IBSEL
QUIT
Begin DoDot:1
+25 SET DA=+$GET(^TMP($JOB,"IBCNSL",3,IBSEL))
IF 'DA
QUIT
+26 SET DIE=36
SET DR="3.13////@;3.14////@"
DO ^DIE
+27 QUIT
End DoDot:1
+28 ;
+29 ; rebuild list of children
DO BLD
UNLINKX ;
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
PCNT(Z) ; count number of children for parent ins co Z
+1 NEW C,CNT
+2 SET C=0
SET Z=+$GET(Z)
+3 FOR CNT=0:1
SET C=$ORDER(^DIC(36,"APC",Z,C))
if 'C
QUIT
+4 QUIT CNT
+5 ;
INSADD(Z) ; function to return ins co address components
+1 NEW INSDATA,AD,NM,L1,CITY,ST,ZIP,CITYST,STCITY
+2 SET INSDATA=""
+3 SET AD=$GET(^DIC(36,+$GET(Z),.11))
+4 SET NM=$PIECE($GET(^DIC(36,Z,0)),U,1)
+5 SET L1=$PIECE(AD,U,1)
SET CITY=$PIECE(AD,U,4)
SET ST=$PIECE(AD,U,5)
SET ZIP=$PIECE(AD,U,6)
+6 IF ST
SET ST=$PIECE($GET(^DIC(5,ST,0)),U,2)
+7 SET CITYST=$EXTRACT(CITY,1,15)_" "_ST
+8 IF CITY'=""
IF ST'=""
SET CITYST=$EXTRACT(CITY,1,15)_","_ST
+9 ;
+10 SET $PIECE(STCITY,"|",1)=ST
+11 IF ST=""
SET $PIECE(STCITY,"|",1)="~~"
+12 SET $PIECE(STCITY,"|",2)=CITY
+13 IF CITY=""
SET $PIECE(STCITY,"|",2)="~~~~"
+14 ;
+15 SET INSDATA=NM_U_L1_U_CITY_U_ST_U_ZIP_U_CITYST_U_STCITY
+16 ; 1 2 3 4 5 6 7
INSADDX ;
+1 QUIT INSDATA
+2 ;
INSCO(Z) ; return display data for ins co Z
+1 NEW X,Y
+2 SET Y=$$INSADD(Z)
+3 SET X=$$FO^IBCNEUT1($PIECE(Y,U,1),27)
+4 SET X=X_$$FO^IBCNEUT1($PIECE(Y,U,2),26)
+5 SET X=X_$$FO^IBCNEUT1($PIECE(Y,U,6),18)
INSCOX ;
+1 QUIT X
+2 ;
INSLIST(INS) ; insurance company lister for ^DIC call
+1 NEW Z
+2 SET Z=$$INSADD(INS)
+3 ; address line 1
WRITE ?27,$EXTRACT($PIECE(Z,U,2),1,20)
+4 ; city, state
WRITE ?47," ",$PIECE(Z,U,6)
INSLISTX ;
+1 QUIT
+2 ;
