IBCNSU41 ;ALB/CPM - SPONSOR UTILITIES (CON'T) ; 5/9/03 1:25pm
;;2.0;INTEGRATED BILLING;**52,211,240,497,654**;21-MAR-94;Build 8
;;Per VA Directive 6402, this routine should not be modified.
;
SPON(DFN) ; Add/edit sponsor/sponsor relationships for a patient.
; Input: DFN -- Pointer to the patient in file #2
;
I '$G(DFN) G SPONQ
N IBQ S IBQ=0
F D LSP Q:IBQ
SPONQ Q
;
;
;
LSP ; Main loop to collect sponsor and relation data.
S DIR(0)="FAO^3:30",DIR("A")="Select SPONSOR: " D ^DIR K DIR
I $D(DIRUT)!$D(DIROUT)!$D(DUOUT)!$D(DTOUT) K DIRUT,DIROUT,DTOUT,DUOUT S IBQ=1 G LSPQ
S IBX=X
;
; - perform lookup to find sponsor or add a patient sponsor
S DIC(0)="ELMZ",DIC="^IBA(355.8,",DLAYGO=355.8 D ^DIC K DIC,DLAYGO
I Y>0 S IBSP=+Y,IBSPD=$G(^IBA(355.8,IBSP,0)),IBNAM=Y(0,0) G LSPC
I IBX'?1.A1","1.ANP W !,"New sponsors must be in the format LAST,FIRST.",! G LSP
;
; - is this a new sponsor to be added to the system?
S DIR(0)="Y",DIR("A")=" Are you adding '"_IBX_"' as a new SPONSOR"
D ^DIR K DIR
I 'Y!$D(DIRUT)!$D(DIROUT)!$D(DUOUT)!$D(DTOUT) K DIRUT,DIROUT,DTOUT,DUOUT G LSP
;
; - add non-patient sponsor to file #355.82 (sponsor person file)
S (X,IBNAM)=IBX,DIC(0)="L",DIC="^IBA(355.82,",DLAYGO=355.82
D FILE^DICN S IBSPP=+Y K DLAYGO
I IBSPP<0 W !,"Unable to add a new sponsor!" G LSPQ
;
; - now add to file #355.8 (sponsor file)
S (IBSPD,X)=IBSPP_";IBA(355.82,",DIC(0)="L",DIC="^IBA(355.8,",DLAYGO=355.8
D FILE^DICN S IBSP=+Y K DLAYGO
I IBSP<0 W !,"Unable to add a new sponsor!" G LSPQ
;
LSPC ; - allow edit of non-patient sponsor name/dob/ssn
; Start of Sponsor changes for IB*2.0*654
N IBFLAG,IBIEN,IBPAT,IBSPON,IBTXT1,IBTXT2,IBTXT3,DIR,DIE,DA,DR
S IBIEN=""
; Loop though Sponsors to find match
F S IBIEN=$O(^IBA(355.81,"B",DFN,IBIEN)) Q:'IBIEN I $P($G(^IBA(355.81,IBIEN,0)),U,2)=IBSP D
.S DIR(0)="YAO",DIR("B")="NO"
.; Get Patient name from #2
.S IBPAT=$$GET1^DIQ(2,DFN_",",.01,"E")
.; Get Sponsor name from #355.8
.S IBSPON=$$GET1^DIQ(355.8,IBSP_",",.01,"E")
.S (IBTXT1,IBTXT2,IBTXT3)=""
.S IBTXT1=IBSPON_" is a current Sponsor of the Patient "
.; IF both Sponsor and Patient will fit on 1 line
.I $L(IBTXT1)+$L(IBPAT)+1'>80 D
.. S IBTXT1=IBTXT1_IBPAT_"."
.. S IBTXT2="Would you like to remove this Sponsor from this Patient?"
.; If IBTXT2 is not defined, 1st IF failed so put the Patient Name on 2nd line
.I '$L(IBTXT2) D
.. S IBTXT2=IBPAT_". Would you like to remove this Sponsor from this Patient?"
.. I $L(IBTXT2)>80 D SPTXT(.IBTXT2,.IBTXT3)
.W !!,IBTXT1
.W !,IBTXT2
.I $L(IBTXT3) W !,IBTXT3
.S DIR("A")="(Yes to Delete, No to Edit, ^ to Exit ) "
.S DIR("??")="^ D HELP^IBCNSU41"
.D ^DIR I Y=1 D
..W !
..S DIR("A",1)="This will permanently delete the Sponsor Relationship."
..S DIR("A")="Are you sure you would like to delete this entry? "
..S DIR("??")="^ D HELP^IBCNSU41"
..S DIR(0)="YAO",DIR("B")="NO"
..D ^DIR I Y=1 D
...S DIK="^IBA(355.81,",DA=IBIEN D ^DIK K DIK S IBFLAG=1
.W !
.; End of Sponsor changes for IB*2.0*654
G:$G(IBFLAG) LSPQ
;
; - allow edit of non-patient sponsor name/dob/ssn
I $P(IBSPD,"^")["IBA" D
.S DIE="^IBA(355.82,",DA=+IBSPD
.S DR=".01 NAME;.02 DATE OF BIRTH;.03 SOCIAL SECURITY NUMBER"
.D ^DIE K DIE,DA,DR
;
; - edit remaining sponsor attributes
S DIE="^IBA(355.8,",DA=IBSP
S DR=".02 MILITARY STATUS;.03 BRANCH;.04 RANK"
D ^DIE K DA,DR,DIE
;
; - find patient relation to sponsor, or create one
S IBSPR=0 F S IBSPR=$O(^IBA(355.81,"B",DFN,IBSPR)) Q:'IBSPR I $P($G(^IBA(355.81,IBSPR,0)),"^",2)=IBSP Q
I 'IBSPR S IBQQ=0 D G:IBQQ LSPQ
.W !!,"The person '",IBNAM,"' is not currently the sponsor of this patient."
.S DIR(0)="Y",DIR("A")="Okay to add this person as the patient's sponsor"
.S DIR("?")="Please enter 'YES' to add this person as the patient's sponsor, or 'NO' to select a new sponsor."
.D ^DIR K DIR I 'Y W ! S IBQQ=1 Q
.;
.S X=DFN,DIC="^IBA(355.81,",DIC(0)="L",DIC("DR")=".02////"_IBSP,DLAYGO=355.81
.D FILE^DICN S IBSPR=+Y S:Y<0 IBQQ=1 K DLAYGO
;
; - edit sponsor relation attributes
S DIE="^IBA(355.81,",DA=IBSPR,DR=".03:.06" D ^DIE K DA,DIE,DR
W !
;
LSPQ K IBFLAG,IBIEN,IBPAT,IBSPON,IBSP,IBSPD,IBSPP,IBSPR,IBQQ,IBNAM,IBX,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
Q
;
LSPCX ; - allow edit of non-patient sponsor name/dob/ssn
I $P(IBSPD,"^")["IBA" D
.S DIE="^IBA(355.82,",DA=+IBSPD
.S DR=".01 NAME;.02 DATE OF BIRTH;.03 SOCIAL SECURITY NUMBER"
.D ^DIE K DIE,DA,DR
;
; - edit remaining sponsor attributes
S DIE="^IBA(355.8,",DA=IBSP
S DR=".02 MILITARY STATUS;.03 BRANCH;.04 RANK"
D ^DIE K DA,DR,DIE
;
; - find patient relation to sponsor, or create one
S IBSPR=0 F S IBSPR=$O(^IBA(355.81,"B",DFN,IBSPR)) Q:'IBSPR I $P($G(^IBA(355.81,IBSPR,0)),"^",2)=IBSP Q
I 'IBSPR S IBQQ=0 D G:IBQQ LSPQ
.W !!,"The person '",IBNAM,"' is not currently the sponsor of this patient."
.S DIR(0)="Y",DIR("A")="Okay to add this person as the patient's sponsor"
.S DIR("?")="Please enter 'YES' to add this person as the patient's sponsor, or 'NO' to select a new sponsor."
.D ^DIR K DIR I 'Y W ! S IBQQ=1 Q
.;
.S X=DFN,DIC="^IBA(355.81,",DIC(0)="L",DIC("DR")=".02////"_IBSP,DLAYGO=355.81
.D FILE^DICN S IBSPR=+Y S:Y<0 IBQQ=1 K DLAYGO
;
; - edit sponsor relation attributes
S DIE="^IBA(355.81,",DA=IBSPR,DR=".03:.06" D ^DIE K DA,DIE,DR
W !
;
LSPQX K IBSP,IBSPD,IBSPP,IBSPR,IBQQ,IBNAM,IBX,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
Q
;
;
;
POL(DFN) ; Update TRICARE policies with Sponsor information.
; Input: DFN -- Pointer to the patient in file #2
;
I '$G(DFN) G POLQ
N IBX,IBY,IBY7,SPON,X,X1,X3,Y,Z
;
S X=0 F S X=$O(^IBA(355.81,"B",DFN,X)) Q:'X D Q:$D(Z)
.S Y=$G(^IBA(355.81,X,0))
.;
.; - relationship must be with a Tricare sponsor
.Q:$P(Y,"^",4)'="T"
.;
.S SPON=$G(^IBA(355.8,+$P(Y,"^",2),0)) Q:SPON=""
.;
.; - if sponsor is a patient, get name/dob/SSN from the patient
.; file; otherwise, use file #355.82
.I $P(SPON,"^")["DPT" D
..S X1=$G(^DPT(+SPON,0)) Q:X1=""
..S Z("NAME")=$P(X1,"^"),Z("DOB")=$P(X1,"^",3),Z("SSN")=$P(X1,"^",9)
.E D
..S X1=$G(^IBA(355.82,+SPON,0)) Q:X1=""
..S Z("NAME")=$P(X1,"^"),Z("DOB")=$P(X1,"^",2),Z("SSN")=$TR($P(X1,"^",3),"-","")
.;
.S Z("BRAN")=$P(SPON,"^",3),Z("RANK")=$P(SPON,"^",4)
;
; - if no Tricare sponsors were found, quit.
I '$D(Z) G POLQ
;
; - update any policies with TRICARE plans
S IBX=0 F S IBX=$O(^DPT(DFN,.312,IBX)) Q:'IBX S IBY=$G(^(IBX,0)),IBY7=$G(^(7)) D ; IB*2.0*497 (vd)
.;
.; - only consider TRICARE plans
.Q:$P($G(^IBE(355.1,+$P($G(^IBA(355.3,+$P(IBY,"^",18),0)),"^",9),0)),"^",3)'=7
.;
.; - the policyholder should not be the veteran (patient)
.Q:$P(IBY,"^",6)="v"
.;
.; - if a sponsor DOB exists, be sure it's the same as the
.; sponsor file DOB
.S X3=$G(^DPT(DFN,.312,IBX,3))
.I X3,+X3'=Z("DOB") Q
.;
.S DR=""
.;IB*2*211
.I $P(IBY7,"^")="" S DR=DR_"7.01////"_Z("NAME")_";" ; IB*2.0*497 (vd)
.I $P(X3,"^")="",Z("DOB") S DR=DR_"3.01////"_Z("DOB")_";"
.I $P(X3,"^",2)="",Z("BRAN") S DR=DR_"3.02////"_Z("BRAN")_";"
.I $P(X3,"^",3)="",Z("RANK")]"" S DR=DR_"3.03////"_Z("RANK")_";"
.I $P(X3,"^",5)="",Z("SSN")]"" S DR=DR_"3.05////"_Z("SSN")_";"
.;
.Q:DR=""
.I $E(DR,$L(DR))=";" S DR=$E(DR,1,$L(DR)-1)
.;
.S DIE="^DPT(DFN,.312,",DA(1)=DFN,DA=IBX D ^DIE K DA,DIE,DR
;
POLQ Q
;
HELP ; Sponsor Delete Help
W !!,"Answering Yes will only remove this Sponsor from this Patient."
W !,"The Sponsor will remain in the Sponsor file and will be"
W !,"available for selection for other Patients."
Q
;
SPTXT(IBTXT2,IBTXT3) ;
; Function to split IBTXT2 into 2 lines each <=80 chars.
I $L(IBTXT2)'>80 Q
N ICNT,IBQUIT
S IBQUIT=0
F ICNT=80:-1:1 D Q:IBQUIT
.I $E(IBTXT2,ICNT)=" " D Q
..S IBQUIT=1
..S IBTXT3=$E(IBTXT2,ICNT+1,999)
..S IBTXT2=$E(IBTXT2,1,ICNT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSU41 7958 printed Sep 02, 2024@19:03:15 Page 2
IBCNSU41 ;ALB/CPM - SPONSOR UTILITIES (CON'T) ; 5/9/03 1:25pm
+1 ;;2.0;INTEGRATED BILLING;**52,211,240,497,654**;21-MAR-94;Build 8
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
SPON(DFN) ; Add/edit sponsor/sponsor relationships for a patient.
+1 ; Input: DFN -- Pointer to the patient in file #2
+2 ;
+3 IF '$GET(DFN)
GOTO SPONQ
+4 NEW IBQ
SET IBQ=0
+5 FOR
DO LSP
if IBQ
QUIT
SPONQ QUIT
+1 ;
+2 ;
+3 ;
LSP ; Main loop to collect sponsor and relation data.
+1 SET DIR(0)="FAO^3:30"
SET DIR("A")="Select SPONSOR: "
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)!$DATA(DIROUT)!$DATA(DUOUT)!$DATA(DTOUT)
KILL DIRUT,DIROUT,DTOUT,DUOUT
SET IBQ=1
GOTO LSPQ
+3 SET IBX=X
+4 ;
+5 ; - perform lookup to find sponsor or add a patient sponsor
+6 SET DIC(0)="ELMZ"
SET DIC="^IBA(355.8,"
SET DLAYGO=355.8
DO ^DIC
KILL DIC,DLAYGO
+7 IF Y>0
SET IBSP=+Y
SET IBSPD=$GET(^IBA(355.8,IBSP,0))
SET IBNAM=Y(0,0)
GOTO LSPC
+8 IF IBX'?1.A1","1.ANP
WRITE !,"New sponsors must be in the format LAST,FIRST.",!
GOTO LSP
+9 ;
+10 ; - is this a new sponsor to be added to the system?
+11 SET DIR(0)="Y"
SET DIR("A")=" Are you adding '"_IBX_"' as a new SPONSOR"
+12 DO ^DIR
KILL DIR
+13 IF 'Y!$DATA(DIRUT)!$DATA(DIROUT)!$DATA(DUOUT)!$DATA(DTOUT)
KILL DIRUT,DIROUT,DTOUT,DUOUT
GOTO LSP
+14 ;
+15 ; - add non-patient sponsor to file #355.82 (sponsor person file)
+16 SET (X,IBNAM)=IBX
SET DIC(0)="L"
SET DIC="^IBA(355.82,"
SET DLAYGO=355.82
+17 DO FILE^DICN
SET IBSPP=+Y
KILL DLAYGO
+18 IF IBSPP<0
WRITE !,"Unable to add a new sponsor!"
GOTO LSPQ
+19 ;
+20 ; - now add to file #355.8 (sponsor file)
+21 SET (IBSPD,X)=IBSPP_";IBA(355.82,"
SET DIC(0)="L"
SET DIC="^IBA(355.8,"
SET DLAYGO=355.8
+22 DO FILE^DICN
SET IBSP=+Y
KILL DLAYGO
+23 IF IBSP<0
WRITE !,"Unable to add a new sponsor!"
GOTO LSPQ
+24 ;
LSPC ; - allow edit of non-patient sponsor name/dob/ssn
+1 ; Start of Sponsor changes for IB*2.0*654
+2 NEW IBFLAG,IBIEN,IBPAT,IBSPON,IBTXT1,IBTXT2,IBTXT3,DIR,DIE,DA,DR
+3 SET IBIEN=""
+4 ; Loop though Sponsors to find match
+5 FOR
SET IBIEN=$ORDER(^IBA(355.81,"B",DFN,IBIEN))
if 'IBIEN
QUIT
IF $PIECE($GET(^IBA(355.81,IBIEN,0)),U,2)=IBSP
Begin DoDot:1
+6 SET DIR(0)="YAO"
SET DIR("B")="NO"
+7 ; Get Patient name from #2
+8 SET IBPAT=$$GET1^DIQ(2,DFN_",",.01,"E")
+9 ; Get Sponsor name from #355.8
+10 SET IBSPON=$$GET1^DIQ(355.8,IBSP_",",.01,"E")
+11 SET (IBTXT1,IBTXT2,IBTXT3)=""
+12 SET IBTXT1=IBSPON_" is a current Sponsor of the Patient "
+13 ; IF both Sponsor and Patient will fit on 1 line
+14 IF $LENGTH(IBTXT1)+$LENGTH(IBPAT)+1'>80
Begin DoDot:2
+15 SET IBTXT1=IBTXT1_IBPAT_"."
+16 SET IBTXT2="Would you like to remove this Sponsor from this Patient?"
End DoDot:2
+17 ; If IBTXT2 is not defined, 1st IF failed so put the Patient Name on 2nd line
+18 IF '$LENGTH(IBTXT2)
Begin DoDot:2
+19 SET IBTXT2=IBPAT_". Would you like to remove this Sponsor from this Patient?"
+20 IF $LENGTH(IBTXT2)>80
DO SPTXT(.IBTXT2,.IBTXT3)
End DoDot:2
+21 WRITE !!,IBTXT1
+22 WRITE !,IBTXT2
+23 IF $LENGTH(IBTXT3)
WRITE !,IBTXT3
+24 SET DIR("A")="(Yes to Delete, No to Edit, ^ to Exit ) "
+25 SET DIR("??")="^ D HELP^IBCNSU41"
+26 DO ^DIR
IF Y=1
Begin DoDot:2
+27 WRITE !
+28 SET DIR("A",1)="This will permanently delete the Sponsor Relationship."
+29 SET DIR("A")="Are you sure you would like to delete this entry? "
+30 SET DIR("??")="^ D HELP^IBCNSU41"
+31 SET DIR(0)="YAO"
SET DIR("B")="NO"
+32 DO ^DIR
IF Y=1
Begin DoDot:3
+33 SET DIK="^IBA(355.81,"
SET DA=IBIEN
DO ^DIK
KILL DIK
SET IBFLAG=1
End DoDot:3
End DoDot:2
+34 WRITE !
+35 ; End of Sponsor changes for IB*2.0*654
End DoDot:1
+36 if $GET(IBFLAG)
GOTO LSPQ
+37 ;
+38 ; - allow edit of non-patient sponsor name/dob/ssn
+39 IF $PIECE(IBSPD,"^")["IBA"
Begin DoDot:1
+40 SET DIE="^IBA(355.82,"
SET DA=+IBSPD
+41 SET DR=".01 NAME;.02 DATE OF BIRTH;.03 SOCIAL SECURITY NUMBER"
+42 DO ^DIE
KILL DIE,DA,DR
End DoDot:1
+43 ;
+44 ; - edit remaining sponsor attributes
+45 SET DIE="^IBA(355.8,"
SET DA=IBSP
+46 SET DR=".02 MILITARY STATUS;.03 BRANCH;.04 RANK"
+47 DO ^DIE
KILL DA,DR,DIE
+48 ;
+49 ; - find patient relation to sponsor, or create one
+50 SET IBSPR=0
FOR
SET IBSPR=$ORDER(^IBA(355.81,"B",DFN,IBSPR))
if 'IBSPR
QUIT
IF $PIECE($GET(^IBA(355.81,IBSPR,0)),"^",2)=IBSP
QUIT
+51 IF 'IBSPR
SET IBQQ=0
Begin DoDot:1
+52 WRITE !!,"The person '",IBNAM,"' is not currently the sponsor of this patient."
+53 SET DIR(0)="Y"
SET DIR("A")="Okay to add this person as the patient's sponsor"
+54 SET DIR("?")="Please enter 'YES' to add this person as the patient's sponsor, or 'NO' to select a new sponsor."
+55 DO ^DIR
KILL DIR
IF 'Y
WRITE !
SET IBQQ=1
QUIT
+56 ;
+57 SET X=DFN
SET DIC="^IBA(355.81,"
SET DIC(0)="L"
SET DIC("DR")=".02////"_IBSP
SET DLAYGO=355.81
+58 DO FILE^DICN
SET IBSPR=+Y
if Y<0
SET IBQQ=1
KILL DLAYGO
End DoDot:1
if IBQQ
GOTO LSPQ
+59 ;
+60 ; - edit sponsor relation attributes
+61 SET DIE="^IBA(355.81,"
SET DA=IBSPR
SET DR=".03:.06"
DO ^DIE
KILL DA,DIE,DR
+62 WRITE !
+63 ;
LSPQ KILL IBFLAG,IBIEN,IBPAT,IBSPON,IBSP,IBSPD,IBSPP,IBSPR,IBQQ,IBNAM,IBX,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
+1 QUIT
+2 ;
LSPCX ; - allow edit of non-patient sponsor name/dob/ssn
+1 IF $PIECE(IBSPD,"^")["IBA"
Begin DoDot:1
+2 SET DIE="^IBA(355.82,"
SET DA=+IBSPD
+3 SET DR=".01 NAME;.02 DATE OF BIRTH;.03 SOCIAL SECURITY NUMBER"
+4 DO ^DIE
KILL DIE,DA,DR
End DoDot:1
+5 ;
+6 ; - edit remaining sponsor attributes
+7 SET DIE="^IBA(355.8,"
SET DA=IBSP
+8 SET DR=".02 MILITARY STATUS;.03 BRANCH;.04 RANK"
+9 DO ^DIE
KILL DA,DR,DIE
+10 ;
+11 ; - find patient relation to sponsor, or create one
+12 SET IBSPR=0
FOR
SET IBSPR=$ORDER(^IBA(355.81,"B",DFN,IBSPR))
if 'IBSPR
QUIT
IF $PIECE($GET(^IBA(355.81,IBSPR,0)),"^",2)=IBSP
QUIT
+13 IF 'IBSPR
SET IBQQ=0
Begin DoDot:1
+14 WRITE !!,"The person '",IBNAM,"' is not currently the sponsor of this patient."
+15 SET DIR(0)="Y"
SET DIR("A")="Okay to add this person as the patient's sponsor"
+16 SET DIR("?")="Please enter 'YES' to add this person as the patient's sponsor, or 'NO' to select a new sponsor."
+17 DO ^DIR
KILL DIR
IF 'Y
WRITE !
SET IBQQ=1
QUIT
+18 ;
+19 SET X=DFN
SET DIC="^IBA(355.81,"
SET DIC(0)="L"
SET DIC("DR")=".02////"_IBSP
SET DLAYGO=355.81
+20 DO FILE^DICN
SET IBSPR=+Y
if Y<0
SET IBQQ=1
KILL DLAYGO
End DoDot:1
if IBQQ
GOTO LSPQ
+21 ;
+22 ; - edit sponsor relation attributes
+23 SET DIE="^IBA(355.81,"
SET DA=IBSPR
SET DR=".03:.06"
DO ^DIE
KILL DA,DIE,DR
+24 WRITE !
+25 ;
LSPQX KILL IBSP,IBSPD,IBSPP,IBSPR,IBQQ,IBNAM,IBX,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
+1 QUIT
+2 ;
+3 ;
+4 ;
POL(DFN) ; Update TRICARE policies with Sponsor information.
+1 ; Input: DFN -- Pointer to the patient in file #2
+2 ;
+3 IF '$GET(DFN)
GOTO POLQ
+4 NEW IBX,IBY,IBY7,SPON,X,X1,X3,Y,Z
+5 ;
+6 SET X=0
FOR
SET X=$ORDER(^IBA(355.81,"B",DFN,X))
if 'X
QUIT
Begin DoDot:1
+7 SET Y=$GET(^IBA(355.81,X,0))
+8 ;
+9 ; - relationship must be with a Tricare sponsor
+10 if $PIECE(Y,"^",4)'="T"
QUIT
+11 ;
+12 SET SPON=$GET(^IBA(355.8,+$PIECE(Y,"^",2),0))
if SPON=""
QUIT
+13 ;
+14 ; - if sponsor is a patient, get name/dob/SSN from the patient
+15 ; file; otherwise, use file #355.82
+16 IF $PIECE(SPON,"^")["DPT"
Begin DoDot:2
+17 SET X1=$GET(^DPT(+SPON,0))
if X1=""
QUIT
+18 SET Z("NAME")=$PIECE(X1,"^")
SET Z("DOB")=$PIECE(X1,"^",3)
SET Z("SSN")=$PIECE(X1,"^",9)
End DoDot:2
+19 IF '$TEST
Begin DoDot:2
+20 SET X1=$GET(^IBA(355.82,+SPON,0))
if X1=""
QUIT
+21 SET Z("NAME")=$PIECE(X1,"^")
SET Z("DOB")=$PIECE(X1,"^",2)
SET Z("SSN")=$TRANSLATE($PIECE(X1,"^",3),"-","")
End DoDot:2
+22 ;
+23 SET Z("BRAN")=$PIECE(SPON,"^",3)
SET Z("RANK")=$PIECE(SPON,"^",4)
End DoDot:1
if $DATA(Z)
QUIT
+24 ;
+25 ; - if no Tricare sponsors were found, quit.
+26 IF '$DATA(Z)
GOTO POLQ
+27 ;
+28 ; - update any policies with TRICARE plans
+29 ; IB*2.0*497 (vd)
SET IBX=0
FOR
SET IBX=$ORDER(^DPT(DFN,.312,IBX))
if 'IBX
QUIT
SET IBY=$GET(^(IBX,0))
SET IBY7=$GET(^(7))
Begin DoDot:1
+30 ;
+31 ; - only consider TRICARE plans
+32 if $PIECE($GET(^IBE(355.1,+$PIECE($GET(^IBA(355.3,+$PIECE(IBY,"^",18),0)),"^",9),0)),"^",3)'=7
QUIT
+33 ;
+34 ; - the policyholder should not be the veteran (patient)
+35 if $PIECE(IBY,"^",6)="v"
QUIT
+36 ;
+37 ; - if a sponsor DOB exists, be sure it's the same as the
+38 ; sponsor file DOB
+39 SET X3=$GET(^DPT(DFN,.312,IBX,3))
+40 IF X3
IF +X3'=Z("DOB")
QUIT
+41 ;
+42 SET DR=""
+43 ;IB*2*211
+44 ; IB*2.0*497 (vd)
IF $PIECE(IBY7,"^")=""
SET DR=DR_"7.01////"_Z("NAME")_";"
+45 IF $PIECE(X3,"^")=""
IF Z("DOB")
SET DR=DR_"3.01////"_Z("DOB")_";"
+46 IF $PIECE(X3,"^",2)=""
IF Z("BRAN")
SET DR=DR_"3.02////"_Z("BRAN")_";"
+47 IF $PIECE(X3,"^",3)=""
IF Z("RANK")]""
SET DR=DR_"3.03////"_Z("RANK")_";"
+48 IF $PIECE(X3,"^",5)=""
IF Z("SSN")]""
SET DR=DR_"3.05////"_Z("SSN")_";"
+49 ;
+50 if DR=""
QUIT
+51 IF $EXTRACT(DR,$LENGTH(DR))=";"
SET DR=$EXTRACT(DR,1,$LENGTH(DR)-1)
+52 ;
+53 SET DIE="^DPT(DFN,.312,"
SET DA(1)=DFN
SET DA=IBX
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+54 ;
POLQ QUIT
+1 ;
HELP ; Sponsor Delete Help
+1 WRITE !!,"Answering Yes will only remove this Sponsor from this Patient."
+2 WRITE !,"The Sponsor will remain in the Sponsor file and will be"
+3 WRITE !,"available for selection for other Patients."
+4 QUIT
+5 ;
SPTXT(IBTXT2,IBTXT3) ;
+1 ; Function to split IBTXT2 into 2 lines each <=80 chars.
+2 IF $LENGTH(IBTXT2)'>80
QUIT
+3 NEW ICNT,IBQUIT
+4 SET IBQUIT=0
+5 FOR ICNT=80:-1:1
Begin DoDot:1
+6 IF $EXTRACT(IBTXT2,ICNT)=" "
Begin DoDot:2
+7 SET IBQUIT=1
+8 SET IBTXT3=$EXTRACT(IBTXT2,ICNT+1,999)
+9 SET IBTXT2=$EXTRACT(IBTXT2,1,ICNT)
End DoDot:2
QUIT
End DoDot:1
if IBQUIT
QUIT
+10 QUIT
