IBCSC3 ;ALB/MJB - MCCR SCREEN 3 (PAYER/MAILING ADDRESS) ;27 MAY 88 10:15
;;2.0;INTEGRATED BILLING;**8,43,52,80,82,51,137,232,320,377,516,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
;MAP TO DGCRSC3
;
EN N IB,IBX,IBINS,Y,Z
I $D(DGRVRCAL) D ^IBCU6 K DGRVRCAL
D ^IBCSCU S IBSR=3,IBSR1="",IBV1="000" I IBV S IBV1="111"
D H^IBCSCU
D:$D(^DGCR(399,IBIFN,"AIC")) 3^IBCVA0
D:'$D(^DGCR(399,IBIFN,"AIC")) 123^IBCVA
D POL^IBCNSU41(DFN)
F I=0,"M","M1","U","U2" S IB(I)=$S($D(^DGCR(399,IBIFN,I)):(^(I)),1:"")
S IBOUTP=2,IBINDT=$S(+$G(IB("U")):+IB("U"),1:DT)
;
S X=" Rate Type : "_$S($P(IB(0),U,7)']"":IBU,$D(^DGCR(399.3,$P(IB(0),U,7),0)):$P(^(0),U),1:IBUN)
S Z=1,IBW=1 X IBWW W X
I +$P($G(^IBE(350.9,1,1)),U,22) W $J("",(42-$L(X))),"Form Type: ",$P($G(^IBE(353,+$P(IB(0),U,19),0)),U,1)
W !?4,"Responsible: ",$S($P(IB(0),U,11)']"":IBU,$P(IB(0),U,11)="p":"PATIENT",$P(IB(0),U,11)="i":"INSURER",1:"OTHER")
W ?45,"Payer Sequence: " S IBX=$P(IB(0),U,21) W $S(IBX="P":"Primary",IBX="S":"Secondary",IBX="T":"Tertiary",IBX="A":"Patient",1:"")
I $P(IB(0),U,11)="i" D
. W !?4,"Bill Payer : " S X=$G(^DGCR(399,IBIFN,"MP"))
. W $S(+X:$P($G(^DIC(36,+X,0)),U,1),$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)):"MRA NEEDED FROM MEDICARE",1:IBU)
. W ?45,"Transmit: " S Z=0,X=$$TXMT^IBCEF4(IBIFN,.Z)
. W $S(X:"Yes",1:"No-"_$S(Z=1:"Forced to print local",Z=2&($$WNRBILL^IBEFUNC(IBIFN)):"MRA not active",Z=2:"EDI not active",Z=3:"Rate typ transmit off",Z=4:"Ins. co transmit off",Z=5:"Failed RULE #"_$G(Z(0)),Z=6:"Invalid NDC code type",1:"??"))
I $P(IB(0),U,11)']"" G MAIL
I $P(IB(0),U,11)="p" G MAIL
I $P(IB(0),U,11)="o" W !?4,"Inst. Name : ",$S($P(IB("M"),U,11)']"":IBU,$D(^DIC(4,$P(IB("M"),U,11),0)):$P(^(0),U,1),1:"UNKNOWN INSTITUTION") G MAIL
I $P(IB(0),U,11)="i" I $D(IBDD)>1,$D(^DGCR(399,IBIFN,"AIC")) G SHW
D UP G LST:$D(IBDD)>1 W !?4,"Insurance : NO REIMBURSABLE INSURANCE INFORMATION ON FILE",!?17,"[Add Insurance Information by entering '1' at the prompt below]" G MAIL
;
LST N IBDTIN,IBICT
S IBDTIN=+$G(IB("U")),IBICT=0
W ! D HDR^IBCNS
S I=0 F S I=$O(IBDD("S",I)) Q:'I D Q:IBICT'<5
.S IBX=0 F S IBX=$O(IBDD("S",I,IBX)) Q:'IBX S IBINS=$G(IBDD(IBX,0)) I IBINS'="" S IBICT=IBICT+1 D:IBICT<5 D1^IBCNS I IBICT'<5 W !,?1,"**Patient has additional insurance - use ?INS to see the entire list" Q
G MAIL
LST1 W !?4,$S($D(^DIC(36,+IBDD(IBX,0),0)):$E($P(^(0),"^",1),1,20),1:"UNKNOWN") S X=$P(IBDD(IBX,0),"^",6) W ?26,$S(X="v":"VETERAN",X="s":"SPOUSE",1:"OTHER") S X=$P(IBDD(IBX,0),"^",16)
S X=$S(+X=1:"PATIENT",+X=2:"SPOUSE",+X=3:"CHILD",+X=8:"EMPLOYEE",+X=11:"ORGAN DONOR",+X=18:"PARENT",+X=15:"PLANTIFF",1:"UNKNOWN")
I X="UNKNOWN" S X1=$S($D(IBDD(IBX,0)):$P(IBDD(IBX,0),"^",6),1:""),X=$S(X1="v":"PATIENT",X1="s":"SPOUSE",1:X)
W ?37,X,?49 S Y=$P(IBDD(IBX,0),"^",8) X ^DD("DD") W Y,?64 S Y=$P(IBDD(IBX,0),"^",4) X ^DD("DD") W Y
Q
SHW I $D(IBDD) S I="" F S I=$O(IBDD(I)) Q:'I D SHW1
MAIL I $$BUFFER^IBCNBU1(DFN) W !!,?17,"*** Patient has Insurance Buffer entries ***"
;
S IB("M")=$S($D(^DGCR(399,IBIFN,"M")):^("M"),1:""),IB("M1")=$S($D(^DGCR(399,IBIFN,"M1")):^("M1"),1:""),IB(0)=^DGCR(399,IBIFN,0)
S Z=2,IBW=1 W ! X IBWW
N IBRAMS S IBRAMS=4.06
I $$FT^IBCEF(IBIFN)=3 S IBRAMS=4.08
S IB("RAFLAG",1)=$S($P(IB("M"),U,1)="":0,1:$$GET1^DIQ(36,$P(IB("M"),U,1),IBRAMS,"I"))
S IB("RAFLAG",2)=$S($P(IB("M"),U,2)="":0,1:$$GET1^DIQ(36,$P(IB("M"),U,2),IBRAMS,"I"))
S IB("RAFLAG",3)=$S($P(IB("M"),U,3)="":0,1:$$GET1^DIQ(36,$P(IB("M"),U,3),IBRAMS,"I"))
S X=0
I $P(IB("M1"),U,2)="",'IB("RAFLAG",1),$P(IB("M1"),U,3)="",'IB("RAFLAG",2),$P(IB("M1"),U,4)="",'IB("RAFLAG",3) S X=1
W " Billing Provider Secondary IDs: "
I X W IBUN ; no data found, unspecified not required
I 'X D ; data found, display below
. W !?5,"Primary Payer: ",$S($P(IB("M1"),U,2)]"":$P(IB("M1"),U,2),IB("RAFLAG",1):"ATT/REND ID",1:"")
. W !?5,"Secondary Payer: ",$S($P(IB("M1"),U,3)]"":$P(IB("M1"),U,3),IB("RAFLAG",2):"ATT/REND ID",1:"")
. W ?46,"Tertiary Payer: ",$S($P(IB("M1"),U,4)]"":$P(IB("M1"),U,4),IB("RAFLAG",3):"ATT/REND ID",1:"")
. Q
;
S Z=3,IBW=1 W ! X IBWW
W " Mailing Address : "
S X=+$G(^DGCR(399,IBIFN,"MP"))
I 'X,$$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN)) S X=+$$CURR^IBCEF2(IBIFN)
;JWS;IB*2.0*592 US1108 - Dental form #7
;IA# 5292
I X,+$G(^DIC(36,X,3)) S I=$P(^(3),U,$S($$FT^IBCEF(IBIFN)=2:2,$$FT^IBCEF(IBIFN)=7:15,1:4)) W ?56,"Electronic ID: ",$S(I'="":I,1:"<NONE>")
S X="" I IB("M")]"" F I=4:1:9 Q:X]"" S X=$P(IB("M"),"^",I)
I X']"" W !?4,"NO MAILING ADDRESS HAS BEEN SPECIFIED!",?45,$$UP1,!?4,"Send Bill to PAYER listed above." G ENDSCR
S X=IB("M") W !,?4,$S($P(X,"^",4)]"":$P(X,"^",4),1:"'MAIL TO' PERSON/PLACE UNSPECIFIED"),?45,$$UP1
W !?4,$S($P(X,"^",5)]"":$P(X,"^",5),1:"STREET ADDRESS UNSPECIFIED") W:$P(X,"^",6)]"" ", ",$P(X,"^",6)
W ! W:$P(IB("M1"),"^",1)]"" ?4,$P(IB("M1"),"^",1),", "
W ?4,$S($P(X,"^",7)]"":$P(X,"^",7),1:"CITY UNSPECIFIED"),", ",$S($D(^DIC(5,+$P(X,"^",8),0)):$P(^(0),"^",2),1:"STATE UNSPECIFIED")," ",$S($P(X,"^",9)]"":$P(X,"^",9),1:"ZIP UNSPECIFIED")
;
ENDSCR K IBADI,IBDD,IBOUTP,IBINDT,I,X,X1
G ^IBCSCP
;
SHW1 ; Display information for insurance I.
; MRD;IB*2.0*516 - Rearranged some fields to allow more characters
; to be displayed for Group #, Group Name, Policy #, Insured.
S X=IBDD(I,0),Z=$G(^DIC(36,+X,0))
W !!?4,"Ins ",I,": " W $E($S($P(Z,U,1)'="":$P(Z,U,1),1:IBU),1,16)
I $P(Z,U,2)="N" W ?30,"WILL NOT REIMBURSE"
W ?51,"Whose: ",$S($P(X,"^",6)="v":"VETERAN",$P(X,"^",6)="s":"SPOUSE",1:"OTHER")
W !?4,"Policy #: ",$E($S($P(X,"^",2)]"":$P(X,"^",2),1:IBU),1,34)
W ?51,"Rel to Insd: ",$E(IBIR(I),1,15)
W !?4,"Insured: ",$E($P(X,"^",17),1,35)
W ?51,"Insd Sex: ",$S($D(IBISEX(I)):IBISEX(I),1:IBU)
W !?4,"Grp #: ",$E($S($P(X,"^",3)]"":$P(X,"^",3),1:IBU),1,67)
W !?4,"Grp Nm: ",$E($S($P(X,"^",15)]"":$P(X,"^",15),1:IBU),1,66)
Q
;
UP K IBDD D ALL^IBCNS1(DFN,"IBDD",2,IBINDT,1)
I $D(IBDD("S",.5)) D ; At least 1 MCR WNR insurance policy exists
. ;try to put correct part (A for institution and B for facility)
. N Z,IBAB
. S IBAB=$S($$FT^IBCEF(IBIFN)=3:"A",1:"B")
. S Z=0 F S Z=$O(IBDD("S",.5,Z)) Q:'Z D
.. I $P($G(IBDD(Z,355.3)),U,14)=IBAB S IBDD("S",.1,Z,0)="" K IBDD("S",.5,Z)
Q
;
UP1() ;check if patient has medicare so can print a flag for the user
N IBDD,IBX,IBY S IBY="" D ALL^IBCNS1(DFN,"IBDD",2,IBINDT)
S IBX=0 F S IBX=$O(IBDD(IBX)) Q:'IBX I $P($G(IBDD(IBX,355.3)),U,9)=33 S IBY="(Patient has Medicare)"
Q IBY
;IBCSC3
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCSC3 6572 printed Nov 22, 2024@17:30:15 Page 2
IBCSC3 ;ALB/MJB - MCCR SCREEN 3 (PAYER/MAILING ADDRESS) ;27 MAY 88 10:15
+1 ;;2.0;INTEGRATED BILLING;**8,43,52,80,82,51,137,232,320,377,516,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRSC3
+5 ;
EN NEW IB,IBX,IBINS,Y,Z
+1 IF $DATA(DGRVRCAL)
DO ^IBCU6
KILL DGRVRCAL
+2 DO ^IBCSCU
SET IBSR=3
SET IBSR1=""
SET IBV1="000"
IF IBV
SET IBV1="111"
+3 DO H^IBCSCU
+4 if $DATA(^DGCR(399,IBIFN,"AIC"))
DO 3^IBCVA0
+5 if '$DATA(^DGCR(399,IBIFN,"AIC"))
DO 123^IBCVA
+6 DO POL^IBCNSU41(DFN)
+7 FOR I=0,"M","M1","U","U2"
SET IB(I)=$SELECT($DATA(^DGCR(399,IBIFN,I)):(^(I)),1:"")
+8 SET IBOUTP=2
SET IBINDT=$SELECT(+$GET(IB("U")):+IB("U"),1:DT)
+9 ;
+10 SET X=" Rate Type : "_$SELECT($PIECE(IB(0),U,7)']"":IBU,$DATA(^DGCR(399.3,$PIECE(IB(0),U,7),0)):$PIECE(^(0),U),1:IBUN)
+11 SET Z=1
SET IBW=1
XECUTE IBWW
WRITE X
+12 IF +$PIECE($GET(^IBE(350.9,1,1)),U,22)
WRITE $JUSTIFY("",(42-$LENGTH(X))),"Form Type: ",$PIECE($GET(^IBE(353,+$PIECE(IB(0),U,19),0)),U,1)
+13 WRITE !?4,"Responsible: ",$SELECT($PIECE(IB(0),U,11)']"":IBU,$PIECE(IB(0),U,11)="p":"PATIENT",$PIECE(IB(0),U,11)="i":"INSURER",1:"OTHER")
+14 WRITE ?45,"Payer Sequence: "
SET IBX=$PIECE(IB(0),U,21)
WRITE $SELECT(IBX="P":"Primary",IBX="S":"Secondary",IBX="T":"Tertiary",IBX="A":"Patient",1:"")
+15 IF $PIECE(IB(0),U,11)="i"
Begin DoDot:1
+16 WRITE !?4,"Bill Payer : "
SET X=$GET(^DGCR(399,IBIFN,"MP"))
+17 WRITE $SELECT(+X:$PIECE($GET(^DIC(36,+X,0)),U,1),$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)):"MRA NEEDED FROM MEDICARE",1:IBU)
+18 WRITE ?45,"Transmit: "
SET Z=0
SET X=$$TXMT^IBCEF4(IBIFN,.Z)
+19 WRITE $SELECT(X:"Yes",1:"No-"_$SELECT(Z=1:"Forced to print local",Z=2&($$WNRBILL^IBEFUNC(IBIFN)):"MRA not active",Z=2:"EDI not active",Z=3:"Rate typ transmit off",Z=4:"Ins. co transmit off",Z=5:"Failed RULE #"_...
... $GET(Z(0)),Z=6:"Invalid NDC code type",1:"??"))
End DoDot:1
+20 IF $PIECE(IB(0),U,11)']""
GOTO MAIL
+21 IF $PIECE(IB(0),U,11)="p"
GOTO MAIL
+22 IF $PIECE(IB(0),U,11)="o"
WRITE !?4,"Inst. Name : ",$SELECT($PIECE(IB("M"),U,11)']"":IBU,$DATA(^DIC(4,$PIECE(IB("M"),U,11),0)):$PIECE(^(0),U,1),1:"UNKNOWN INSTITUTION")
GOTO MAIL
+23 IF $PIECE(IB(0),U,11)="i"
IF $DATA(IBDD)>1
IF $DATA(^DGCR(399,IBIFN,"AIC"))
GOTO SHW
+24 DO UP
if $DATA(IBDD)>1
GOTO LST
WRITE !?4,"Insurance : NO REIMBURSABLE INSURANCE INFORMATION ON FILE",!?17,"[Add Insurance Information by entering '1' at the prompt below]"
GOTO MAIL
+25 ;
LST NEW IBDTIN,IBICT
+1 SET IBDTIN=+$GET(IB("U"))
SET IBICT=0
+2 WRITE !
DO HDR^IBCNS
+3 SET I=0
FOR
SET I=$ORDER(IBDD("S",I))
if 'I
QUIT
Begin DoDot:1
+4 SET IBX=0
FOR
SET IBX=$ORDER(IBDD("S",I,IBX))
if 'IBX
QUIT
SET IBINS=$GET(IBDD(IBX,0))
IF IBINS'=""
SET IBICT=IBICT+1
if IBICT<5
DO D1^IBCNS
IF IBICT'<5
WRITE !,?1,"**Patient has additional insurance - use ?INS to see the entire list"
QUIT
End DoDot:1
if IBICT'<5
QUIT
+5 GOTO MAIL
LST1 WRITE !?4,$SELECT($DATA(^DIC(36,+IBDD(IBX,0),0)):$EXTRACT($PIECE(^(0),"^",1),1,20),1:"UNKNOWN")
SET X=$PIECE(IBDD(IBX,0),"^",6)
WRITE ?26,$SELECT(X="v":"VETERAN",X="s":"SPOUSE",1:"OTHER")
SET X=$PIECE(IBDD(IBX,0),"^",16)
+1 SET X=$SELECT(+X=1:"PATIENT",+X=2:"SPOUSE",+X=3:"CHILD",+X=8:"EMPLOYEE",+X=11:"ORGAN DONOR",+X=18:"PARENT",+X=15:"PLANTIFF",1:"UNKNOWN")
+2 IF X="UNKNOWN"
SET X1=$SELECT($DATA(IBDD(IBX,0)):$PIECE(IBDD(IBX,0),"^",6),1:"")
SET X=$SELECT(X1="v":"PATIENT",X1="s":"SPOUSE",1:X)
+3 WRITE ?37,X,?49
SET Y=$PIECE(IBDD(IBX,0),"^",8)
XECUTE ^DD("DD")
WRITE Y,?64
SET Y=$PIECE(IBDD(IBX,0),"^",4)
XECUTE ^DD("DD")
WRITE Y
+4 QUIT
SHW IF $DATA(IBDD)
SET I=""
FOR
SET I=$ORDER(IBDD(I))
if 'I
QUIT
DO SHW1
MAIL IF $$BUFFER^IBCNBU1(DFN)
WRITE !!,?17,"*** Patient has Insurance Buffer entries ***"
+1 ;
+2 SET IB("M")=$SELECT($DATA(^DGCR(399,IBIFN,"M")):^("M"),1:"")
SET IB("M1")=$SELECT($DATA(^DGCR(399,IBIFN,"M1")):^("M1"),1:"")
SET IB(0)=^DGCR(399,IBIFN,0)
+3 SET Z=2
SET IBW=1
WRITE !
XECUTE IBWW
+4 NEW IBRAMS
SET IBRAMS=4.06
+5 IF $$FT^IBCEF(IBIFN)=3
SET IBRAMS=4.08
+6 SET IB("RAFLAG",1)=$SELECT($PIECE(IB("M"),U,1)="":0,1:$$GET1^DIQ(36,$PIECE(IB("M"),U,1),IBRAMS,"I"))
+7 SET IB("RAFLAG",2)=$SELECT($PIECE(IB("M"),U,2)="":0,1:$$GET1^DIQ(36,$PIECE(IB("M"),U,2),IBRAMS,"I"))
+8 SET IB("RAFLAG",3)=$SELECT($PIECE(IB("M"),U,3)="":0,1:$$GET1^DIQ(36,$PIECE(IB("M"),U,3),IBRAMS,"I"))
+9 SET X=0
+10 IF $PIECE(IB("M1"),U,2)=""
IF 'IB("RAFLAG",1)
IF $PIECE(IB("M1"),U,3)=""
IF 'IB("RAFLAG",2)
IF $PIECE(IB("M1"),U,4)=""
IF 'IB("RAFLAG",3)
SET X=1
+11 WRITE " Billing Provider Secondary IDs: "
+12 ; no data found, unspecified not required
IF X
WRITE IBUN
+13 ; data found, display below
IF 'X
Begin DoDot:1
+14 WRITE !?5,"Primary Payer: ",$SELECT($PIECE(IB("M1"),U,2)]"":$PIECE(IB("M1"),U,2),IB("RAFLAG",1):"ATT/REND ID",1:"")
+15 WRITE !?5,"Secondary Payer: ",$SELECT($PIECE(IB("M1"),U,3)]"":$PIECE(IB("M1"),U,3),IB("RAFLAG",2):"ATT/REND ID",1:"")
+16 WRITE ?46,"Tertiary Payer: ",$SELECT($PIECE(IB("M1"),U,4)]"":$PIECE(IB("M1"),U,4),IB("RAFLAG",3):"ATT/REND ID",1:"")
+17 QUIT
End DoDot:1
+18 ;
+19 SET Z=3
SET IBW=1
WRITE !
XECUTE IBWW
+20 WRITE " Mailing Address : "
+21 SET X=+$GET(^DGCR(399,IBIFN,"MP"))
+22 IF 'X
IF $$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN))
SET X=+$$CURR^IBCEF2(IBIFN)
+23 ;JWS;IB*2.0*592 US1108 - Dental form #7
+24 ;IA# 5292
+25 IF X
IF +$GET(^DIC(36,X,3))
SET I=$PIECE(^(3),U,$SELECT($$FT^IBCEF(IBIFN)=2:2,$$FT^IBCEF(IBIFN)=7:15,1:4))
WRITE ?56,"Electronic ID: ",$SELECT(I'="":I,1:"<NONE>")
+26 SET X=""
IF IB("M")]""
FOR I=4:1:9
if X]""
QUIT
SET X=$PIECE(IB("M"),"^",I)
+27 IF X']""
WRITE !?4,"NO MAILING ADDRESS HAS BEEN SPECIFIED!",?45,$$UP1,!?4,"Send Bill to PAYER listed above."
GOTO ENDSCR
+28 SET X=IB("M")
WRITE !,?4,$SELECT($PIECE(X,"^",4)]"":$PIECE(X,"^",4),1:"'MAIL TO' PERSON/PLACE UNSPECIFIED"),?45,$$UP1
+29 WRITE !?4,$SELECT($PIECE(X,"^",5)]"":$PIECE(X,"^",5),1:"STREET ADDRESS UNSPECIFIED")
if $PIECE(X,"^",6)]""
WRITE ", ",$PIECE(X,"^",6)
+30 WRITE !
if $PIECE(IB("M1"),"^",1)]""
WRITE ?4,$PIECE(IB("M1"),"^",1),", "
+31 WRITE ?4,$SELECT($PIECE(X,"^",7)]"":$PIECE(X,"^",7),1:"CITY UNSPECIFIED"),", ",$SELECT($DATA(^DIC(5,+$PIECE(X,"^",8),0)):$PIECE(^(0),"^",2),1:"STATE UNSPECIFIED")," ",$SELECT($PIECE(X,"^",9)]"":$PIECE(X,"^",9),1:"ZIP UNSPECIFIED")
+32 ;
ENDSCR KILL IBADI,IBDD,IBOUTP,IBINDT,I,X,X1
+1 GOTO ^IBCSCP
+2 ;
SHW1 ; Display information for insurance I.
+1 ; MRD;IB*2.0*516 - Rearranged some fields to allow more characters
+2 ; to be displayed for Group #, Group Name, Policy #, Insured.
+3 SET X=IBDD(I,0)
SET Z=$GET(^DIC(36,+X,0))
+4 WRITE !!?4,"Ins ",I,": "
WRITE $EXTRACT($SELECT($PIECE(Z,U,1)'="":$PIECE(Z,U,1),1:IBU),1,16)
+5 IF $PIECE(Z,U,2)="N"
WRITE ?30,"WILL NOT REIMBURSE"
+6 WRITE ?51,"Whose: ",$SELECT($PIECE(X,"^",6)="v":"VETERAN",$PIECE(X,"^",6)="s":"SPOUSE",1:"OTHER")
+7 WRITE !?4,"Policy #: ",$EXTRACT($SELECT($PIECE(X,"^",2)]"":$PIECE(X,"^",2),1:IBU),1,34)
+8 WRITE ?51,"Rel to Insd: ",$EXTRACT(IBIR(I),1,15)
+9 WRITE !?4,"Insured: ",$EXTRACT($PIECE(X,"^",17),1,35)
+10 WRITE ?51,"Insd Sex: ",$SELECT($DATA(IBISEX(I)):IBISEX(I),1:IBU)
+11 WRITE !?4,"Grp #: ",$EXTRACT($SELECT($PIECE(X,"^",3)]"":$PIECE(X,"^",3),1:IBU),1,67)
+12 WRITE !?4,"Grp Nm: ",$EXTRACT($SELECT($PIECE(X,"^",15)]"":$PIECE(X,"^",15),1:IBU),1,66)
+13 QUIT
+14 ;
UP KILL IBDD
DO ALL^IBCNS1(DFN,"IBDD",2,IBINDT,1)
+1 ; At least 1 MCR WNR insurance policy exists
IF $DATA(IBDD("S",.5))
Begin DoDot:1
+2 ;try to put correct part (A for institution and B for facility)
+3 NEW Z,IBAB
+4 SET IBAB=$SELECT($$FT^IBCEF(IBIFN)=3:"A",1:"B")
+5 SET Z=0
FOR
SET Z=$ORDER(IBDD("S",.5,Z))
if 'Z
QUIT
Begin DoDot:2
+6 IF $PIECE($GET(IBDD(Z,355.3)),U,14)=IBAB
SET IBDD("S",.1,Z,0)=""
KILL IBDD("S",.5,Z)
End DoDot:2
End DoDot:1
+7 QUIT
+8 ;
UP1() ;check if patient has medicare so can print a flag for the user
+1 NEW IBDD,IBX,IBY
SET IBY=""
DO ALL^IBCNS1(DFN,"IBDD",2,IBINDT)
+2 SET IBX=0
FOR
SET IBX=$ORDER(IBDD(IBX))
if 'IBX
QUIT
IF $PIECE($GET(IBDD(IBX,355.3)),U,9)=33
SET IBY="(Patient has Medicare)"
+3 QUIT IBY
+4 ;IBCSC3
