ABMDF12A.m

ABMDF12A ; IHS/SD/SDR - ADA Dental Export -part 2 ;   

 ;;2.6;IHS 3P BILLING SYSTEM;**6,10,11**;NOV 12, 2009;Build 133

 ;Original;TMD;08/13/96 11:47 AM

 ;

 ; IHS/DSD/DMJ - 7/20/98 - NOIS XFA-0698-200102

 ;   Meds showing up on split bill for ADA & HCFA.

 ;   Modified to show meds on HCFA only.  Also add code so claim generator will not bomb

 ;   if auto approve is turned on and Y2K fix to print 4 digit year in 3 birthdate fields.

 ;

 ;IHS/DSD/DMJ - 5/5/1999 - NOIS PCB-0599-90008 Patch 1

 ;     Previous payments not printing in block #42

 ;     Payment by other plan, added a call to ABMERUTL and set 4th

 ;     piece of ABMF(58).

 ; IHS/ASDS/DMJ - 04/18/00 - V2.4 Patch 1 - NOIS HQW-0500-100040

 ;     Modified location code to check for satellite first.  If no

 ;     satellite use parent.

 ;

 ; IHS/ASDS/SDH - 04/10/2001 - V2.4 Patch 9 - NOIS NCA-0600-180055

 ;     Place provider number in box 1

 ;

 ; IHS/ASDS/SDH - 03/28/2001 - V2.4 Patch 9 - NOIS NEA-0301-180042

 ;     Correct ADA-94 form to print address of patient instead of 

 ;     NON-BENEFICIARY insurer.

 ;

 ; IHS/ASDS/SDH - 07/20/2001 - V2.4 Patch 9 - NOIS QAA-0601-130017

 ;     Modified code to print location of service as the site, not

 ;     where the bills are going.  This was a problem because of

 ;     payments going to PNC.  This affects form locator 40.

 ;

 ; IHS/ASDS/LSL - 08/20/2001 - V2.4 Patch 9 - NOIS HQW-0798-100082

 ;     For Policy holder information, if there is not an insurer in

 ;     "I" status in the insurer multiple of the bill, use the

 ;     active insurer.

 ;

 ; IHS/SD/SDR - V2.5 P2 - 4/17/02 - NOIS XXX-0302-200036 - Modified to append HRN to bill number

 ; IHS/SD/SDR - v2.5 p9 - IM14774 - Correction to block 1; shifted block 5 one to the left

 ; IHS/SD/SDR - v2.5 p9 - IM16991 - Added code for San Felipe VT 998

 ; IHS/SD/SDR - v2.5 p10 - IM20337 - Added code for page 9F

 ; IHS/SD/SDR - v2.5 p10 - IM21043 - Changed treatment address to physical address

 ;IHS/SD/SDR - abm*2.6*6 - HEAT27940 - Fix Today/Originate Date printing

 ;

 ; *********************************************************************

 ;

ENT ;EP for getting data

 S ABMP("B0")=^ABMDBILL(DUZ(2),ABMP("BDFN"),0),ABMP("INS")=$P(^(0),U,8)

 S ABMP("PDFN")=$P(ABMP("B0"),U,5),ABMP("LDFN")=$P(ABMP("B0"),U,3)

 S ABMP("VTYP")=$P(ABMP("B0"),U,7),ABMP("BTYP")=$P(ABMP("B0"),U,2)

 Q:'ABMP("PDFN")!'ABMP("LDFN")!'ABMP("INS")

 S ABMP("VDT")=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),7),U)

 ;

BADDR S ABM("J")=ABMP("BDFN"),ABM("I")=$P(^AUTNINS(ABMP("INS"),0),U)_"-"_ABMP("INS")

 S ABM("INS",ABM("I"),ABM("J"))=""

 ;I $P($G(^AUTNINS(ABMP("INS"),2)),U)="N" D  ;abm*2.6*10 HEAT73780

 I $$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMP("INS"),".211","I"),1,"I")="N" D  ;abm*2.6*10 HEAT73780

 .S ABM("INS",ABM("I"),ABM("J"))=ABMP("PDFN")

 S ABM("IDFN")=ABMP("INS") D BADDR^ABMDLBL1 G PAT:'$D(ABM("ADD"))

 S ABMF(2)="^^"_$P(ABM("ADD"),U,1),ABMF(3)="X^"_$P(ABM("ADD"),U,2),ABMF(4)="^^"_$P(ABM("ADD"),U,3)

 ;

PAT S ABM("P0")=^DPT(ABMP("PDFN"),0)

 S ABMF(7)=$P(ABM("P0"),U)_U_U_U_U_$S($P(ABM("P0"),U,2)="M":"X"_U,1:U_"X")_U

 S ABMF(7)=ABMF(7)_$E($P(ABM("P0"),U,3),4,5)_U_$E($P(ABM("P0"),U,3),6,7)_U_($E($P(ABM("P0"),U,3),1,3)+1700)

 K ABM("P0")

 ;

 S (ABMV("X1"),ABMV("X2"),ABMV("X3"))=""

 D PAT^ABMDE1X,REMPL^ABMDE1X1,LOC^ABMDE1X1 K ABME

LOC S $P(ABMF(24),U)=$S($P(ABMV("X1"),U,2)]"":$P(ABMV("X1"),U,2),1:$P($P(ABMV("X1"),U),";",2))

 I DUZ(2)=1581,(ABMP("VTYP")=998) S $P(ABMF(24),U)="SAN FELIPE HS"

 S $P(ABMF(26),U)=$P(ABMV("X1"),U,3),$P(ABMF(28),U)=$P(ABMV("X1"),U,4)

 I DUZ(2)=1581,(ABMP("VTYP")=998) S $P(ABMF(26),U)="PO BOX 4339",$P(ABMF(28),U)="SAN FELIPE, NM 87001"

 S $P(ABMF(30),U)=$P(ABMV("X1"),U,6),$P(ABMF(30),U,3)=$P(ABMV("X1"),U,5)

 I DUZ(2)=1581,(ABMP("VTYP")=998) S $P(ABMF(30),U)=850210848

 S ABMLOC=$P(ABMP("B0"),U,3)

 S ABMV("X1")=$G(^AUTTLOC(ABMLOC,0))

 S $P(ABMF(61),U)=$P(ABMV("X1"),U,12)

 S $P(ABMF(61),U,2)=$P(ABMV("X1"),U,13)

 S ABML=$P(ABMV("X1"),U,14)

 S $P(ABMF(61),U,3)=$P(^DIC(5,ABML,0),U,2)

 S $P(ABMF(61),U,4)=$P(ABMV("X1"),U,15)

 I $P($G(^AUTNINS(ABMP("INS"),0)),U)["DELTA DENTAL" D

 .S $P(ABMF(26),U)=$P($G(^DIC(4,ABMP("LDFN"),1)),U)  ;address

 .S $P(ABMF(28),U)=$P($G(^DIC(4,ABMP("LDFN"),1)),U,3)  ;city

 .S ABMX("STATE")=$P($G(^DIC(4,ABMP("LDFN"),0)),U,2)  ;state

 .S $P(ABMF(28),U)=$P(ABMF(28),U)_", "_$P($G(^DIC(5,+ABMX("STATE"),0)),U,2)

 .S $P(ABMF(28),U)=$P(ABMF(28),U)_" "_$P($G(^DIC(4,ABMP("LDFN"),1)),U,4)  ;zip

 ;

INSNUM ;

 S ABM("INUM")=$P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,$P(ABMP("B0"),U,7),0)),U,8)

 S:ABM("INUM")="" ABM("INUM")=$P($G(^AUTNINS(ABMP("INS"),15,ABMP("LDFN"),0)),U,2)

 S $P(ABMF(30),U,2)=ABM("INUM")

 ;

PRV S ABM("X")=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),41,"C","A",0)) I ABM("X") D

 .D SELBILL^ABMDE4X

 .S $P(ABMF(4),U)=$G(ABM("PNUM"))

 .D PAYED^ABMERUTL

 .;S ABMF(58)=$P(ABM("A"),U)_U_ABM("PNUM")_U_DT_U_$G(ABMP("PAYED"))  ;abm*2.6*6 HEAT27940

 .S ABMF(58)=$P(ABM("A"),U)_U_ABM("PNUM")_U_U_$G(ABMP("PAYED"))  ;abm*2.6*6 HEAT27940

 .;S $P(ABMF(58),U,3)=$S($G(ABMP("PRINTDT"))="O":$P($G(^ABMDTXST(DUZ(2),$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),1)),U,7),0)),U),1:DT)  ;abm*2.6*6 HEAT27940  ;abm*2.6*11 HEAT81561

 .S $P(ABMF(58),U,3)=$S($G(ABMP("PRINTDT"))="O":$P($G(^ABMDTXST(DUZ(2),$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),1)),U,7),0)),U),$G(ABMP("PRINTDT"))="A":$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),1)),U,5),1:DT)  ;abm*2.6*6 HEAT27940  ;abm*2.6*11 HEAT81561

POL ;POLICY INFORMATION

 N I S I=0 F  S I=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,I)) Q:'I  D

 .I $P(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,I,0),"^",3)="I" S ABM("XIEN")=I

 S:$G(ABM("XIEN"))="" ABM("XIEN")=+$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,"B",ABMP("INS"),0))

 S Y=ABMP("INS"),ABMP("GL")="^ABMDBILL(DUZ(2),"_ABMP("BDFN")_","

 D SEL^ABMDE2X

 I ABM("ADD")["NON-BEN" D

 .S ABM("ADD")=ABMV("X2")

 .S ABMF(2)="^^"_$P($P(ABM("ADD"),U),";",2)

 .S ABMF(3)="^"_$P(ABM("ADD"),U,3)

 .S ABMF(4)="^^"_$P(ABM("ADD"),U,4)

 S $P(ABMF(9),U)=$P($P(ABMV("X2"),U),";",2)

 S $P(ABMF(10),U)=$P(ABMV("X2"),U,3)

 S $P(ABMF(11),U)=$P(ABMV("X2"),U,4)

 S $P(ABMF(11),U,2)=$P(ABMV("X1"),U,4)

 S $P(ABMF(11),U,3)=$E($P(ABMV("X2"),U,7),4,5)

 S $P(ABMF(11),U,4)=$E($P(ABMV("X2"),U,7),6,7)

 S $P(ABMF(11),U,5)=($E($P(ABMV("X2"),U,7),1,3)+1700)

EMPL S $P(ABMF(9),U,2)=$P(ABMV("X3"),U),$P(ABMF(10),U,3)=$P(ABMV("X3"),U,2),$P(ABMF(11),U,6)=$P(ABMV("X3"),U,3)

 S $P(ABMF(10),U,4)=$P(ABMV("X3"),U,6),$P(ABMF(11),U,7)=$P(ABMV("X3"),U,7)

REL G INS:'$P(ABMV("X2"),U,2)

 S ABM=+$P($G(^AUTTRLSH(+$P(ABMV("X2"),U,2),0)),U,2)

 I ABM,ABM<8,ABM'=2 S $P(ABMF(6),U,$S(ABM=1:1,1:2))="X"

 E  S $P(ABMF(7),U,$S(ABM=2:2,1:3))="X"

INS ;

 S ABM("I")=0

 F  S ABM("I")=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,"C",ABM("I"))) Q:'ABM("I")  S ABM=$O(^(ABM("I"),0)) D

 .S ABM=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM,0),U)

 .I ABM'=ABMP("INS") D  Q

 ..I "U"[$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM,0)),U,3) Q

 ..S Y=ABM

 ..S ABMP("GL")="^ABMDBILL(DUZ(2),"_ABMP("BDFN")_","

 ..D SEL^ABMDE2X

 ..S $P(ABMF(13),U,3)=$P(^AUTNINS(ABM,0),U)

 ..S $P(ABMF(14),U)=$P(^AUTNINS(ABM,0),U,2)

 ..S $P(ABMF(15),U,3)=$$CSZ^ABMDUTL($P(^AUTNINS(ABM,0),U,3,5))

 ..S $P(ABMF(14),U,2)=$P(ABMV("X3"),U,6)

 ..S $P(ABMF(15),U,4)=$P(ABMV("X3"),U,7)

 ..S $P(ABMF(13),U,5)=$P(ABMV("X3"),U)

 ..S $P(ABMF(14),U,3)=$P(ABMV("X3"),U,2)

 ..S $P(ABMF(15),U,5)=$P(ABMV("X3"),U,3)

 ..S $P(ABMF(18),U)=$P($P(ABMV("X2"),U),";",2)

 ..S $P(ABMF(18),U,2)=$P(ABMV("X1"),U,4)

 ..S $P(ABMF(18),U,3)=$E($P(ABMV("X2"),U,7),4,5)

 ..S $P(ABMF(18),U,4)=$E($P(ABMV("X2"),U,7),6,7)

 ..S $P(ABMF(18),U,5)=($E($P(ABMV("X2"),U,7),1,3)+1700)

 ..I $P(ABMV("X2"),U,2) D

 ...S ABMREL=+$P($G(^AUTTRLSH(+$P(ABMV("X2"),U,2),0)),U,2)

 ...I ABMREL,ABMREL<8,ABMREL'=2 S $P(ABMF(17),U,$S(ABMREL=1:2,1:3))="X"

 ...E  S $P(ABMF(18),U,$S(ABMREL=2:6,1:7))="X"

 ..I $P($G(^AUTNINS(ABM,2)),U,5)="O" S $P(ABMF(13),U)="X"

 ..E  S $P(ABMF(15),U)="X"

 S:$P($G(ABMF(13)),U)="" $P(ABMF(13),U,2)="X"

 S:$P($G(ABMF(15)),U)="" $P(ABMF(15),U,2)="X"

 ;

BNODES I $D(^ABMDBILL(DUZ(2),ABMP("BDFN"),0)) S ABM("B4")=$G(^(4)),ABM("B7")=$G(^(7)),ABM("B8")=$G(^(8)),ABM("B9")=$G(^(9))

 I $P(ABM("B9"),U)]"" S $P(ABMF(24),U,3)="X"

 E  S $P(ABMF(24),U,2)="X"

 ;

ACCD S $P(ABMF(26),U,$S('$P(ABM("B8"),U,3):2,"12"[$P(ABM("B8"),U,3):3,1:2))="X"

 S $P(ABMF(28),U,$S("12"[$P(ABM("B8"),U,3):2,1:3))="X"

FSYM S $P(ABMF(32),U)=$P(ABM("B8"),U,6)

 I $P(ABM("B7"),U,4)="Y" S ABMF(21)="SIGNATURE ON FILE"_U_DT

 I $P(ABM("B7"),U,5)="Y" S $P(ABMF(21),U,3)="SIGNATURE ON FILE",$P(ABMF(21),U,4)=DT

 S $P(ABMF(32),U,2)="X"

XRAY S $P(ABMF(32),U,$S($P(ABM("B4"),U,3):7,1:6))="X"

 S $P(ABMF(32),U,8)=$P(ABM("B4"),U,3)

ORTHO S $P(ABMF(32),U,$S($P(ABM("B4"),U,4):10,1:9))="X"

 I $P(ABM("B4"),U,4) S $P(ABMF(32),U,11)=$P(ABM("B4"),U,5)

PROTH S $P(ABMF(30),U,$S($P(ABM("B4"),U,6):5,1:4))="X"

 I $P(ABM("B4"),U,6) S $P(ABMF(30),U,6)=$P(ABM("B4"),U,7)

 S $P(ABMF(55),U)="Bill Number: "_$P(ABMP("B0"),U)_$S($P($G(^ABMDPARM(DUZ(2),1,2)),U,4)]"":"-"_$P(^(2),U,4),1:"") I $P($G(^(3)),U,3),$P($G(^AUPNPAT(ABMP("PDFN"),41,ABMP("LDFN"),0)),U,2) S $P(ABMF(55),U)=$P(ABMF(55),U)_" "_$P(^(0),U,2)

 I $D(^ABMDBILL(DUZ(2),ABMP("BDFN"),61,0)) D

 .S ABMIEN=0

 .S ABMLINE=51

 .F  S ABMIEN=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),61,ABMIEN)) Q:+ABMIEN=0!(ABMLINE>54)  D

 ..S ABMF(ABMLINE)=$G(^ABMDBILL(DUZ(2),ABMP("BDFN"),61,ABMIEN,0))

 ..S ABMLINE=ABMLINE+1

 ;

XIT K ABM,ABMV

 Q

ABMDF12A  ; IHS/SD/SDR - ADA Dental Export -part 2 ;   

 +1       ;;2.6;IHS 3P BILLING SYSTEM;**6,10,11**;NOV 12, 2009;Build 133

 +2       ;Original;TMD;08/13/96 11:47 AM

 +3       ;

 +4       ; IHS/DSD/DMJ - 7/20/98 - NOIS XFA-0698-200102

 +5       ;   Meds showing up on split bill for ADA & HCFA.

 +6       ;   Modified to show meds on HCFA only.  Also add code so claim generator will not bomb

 +7       ;   if auto approve is turned on and Y2K fix to print 4 digit year in 3 birthdate fields.

 +8       ;

 +9       ;IHS/DSD/DMJ - 5/5/1999 - NOIS PCB-0599-90008 Patch 1

 +10      ;     Previous payments not printing in block #42

 +11      ;     Payment by other plan, added a call to ABMERUTL and set 4th

 +12      ;     piece of ABMF(58).

 +13      ; IHS/ASDS/DMJ - 04/18/00 - V2.4 Patch 1 - NOIS HQW-0500-100040

 +14      ;     Modified location code to check for satellite first.  If no

 +15      ;     satellite use parent.

 +16      ;

 +17      ; IHS/ASDS/SDH - 04/10/2001 - V2.4 Patch 9 - NOIS NCA-0600-180055

 +18      ;     Place provider number in box 1

 +19      ;

 +20      ; IHS/ASDS/SDH - 03/28/2001 - V2.4 Patch 9 - NOIS NEA-0301-180042

 +21      ;     Correct ADA-94 form to print address of patient instead of 

 +22      ;     NON-BENEFICIARY insurer.

 +23      ;

 +24      ; IHS/ASDS/SDH - 07/20/2001 - V2.4 Patch 9 - NOIS QAA-0601-130017

 +25      ;     Modified code to print location of service as the site, not

 +26      ;     where the bills are going.  This was a problem because of

 +27      ;     payments going to PNC.  This affects form locator 40.

 +28      ;

 +29      ; IHS/ASDS/LSL - 08/20/2001 - V2.4 Patch 9 - NOIS HQW-0798-100082

 +30      ;     For Policy holder information, if there is not an insurer in

 +31      ;     "I" status in the insurer multiple of the bill, use the

 +32      ;     active insurer.

 +33      ;

 +34      ; IHS/SD/SDR - V2.5 P2 - 4/17/02 - NOIS XXX-0302-200036 - Modified to append HRN to bill number

 +35      ; IHS/SD/SDR - v2.5 p9 - IM14774 - Correction to block 1; shifted block 5 one to the left

 +36      ; IHS/SD/SDR - v2.5 p9 - IM16991 - Added code for San Felipe VT 998

 +37      ; IHS/SD/SDR - v2.5 p10 - IM20337 - Added code for page 9F

 +38      ; IHS/SD/SDR - v2.5 p10 - IM21043 - Changed treatment address to physical address

 +39      ;IHS/SD/SDR - abm*2.6*6 - HEAT27940 - Fix Today/Originate Date printing

 +40      ;

 +41      ; *********************************************************************

 +42      ;

ENT       ;EP for getting data

 +1        SET ABMP("B0")=^ABMDBILL(DUZ(2),ABMP("BDFN"),0)

           SET ABMP("INS")=$PIECE(^(0),U,8)

 +2        SET ABMP("PDFN")=$PIECE(ABMP("B0"),U,5)

           SET ABMP("LDFN")=$PIECE(ABMP("B0"),U,3)

 +3        SET ABMP("VTYP")=$PIECE(ABMP("B0"),U,7)

           SET ABMP("BTYP")=$PIECE(ABMP("B0"),U,2)

 +4        IF 'ABMP("PDFN")!'ABMP("LDFN")!'ABMP("INS")

               QUIT 

 +5        SET ABMP("VDT")=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),7),U)

 +6       ;

BADDR      SET ABM("J")=ABMP("BDFN")

           SET ABM("I")=$PIECE(^AUTNINS(ABMP("INS"),0),U)_"-"_ABMP("INS")

 +1        SET ABM("INS",ABM("I"),ABM("J"))=""

 +2       ;I $P($G(^AUTNINS(ABMP("INS"),2)),U)="N" D  ;abm*2.6*10 HEAT73780

 +3       ;abm*2.6*10 HEAT73780

           IF $$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMP("INS"),".211","I"),1,"I")="N"

               Begin DoDot:1

 +4                SET ABM("INS",ABM("I"),ABM("J"))=ABMP("PDFN")

               End DoDot:1

 +5        SET ABM("IDFN")=ABMP("INS")

           DO BADDR^ABMDLBL1

           IF '$DATA(ABM("ADD"))

               GOTO PAT

 +6        SET ABMF(2)="^^"_$PIECE(ABM("ADD"),U,1)

           SET ABMF(3)="X^"_$PIECE(ABM("ADD"),U,2)

           SET ABMF(4)="^^"_$PIECE(ABM("ADD"),U,3)

 +7       ;

PAT        SET ABM("P0")=^DPT(ABMP("PDFN"),0)

 +1        SET ABMF(7)=$PIECE(ABM("P0"),U)_U_U_U_U_$SELECT($PIECE(ABM("P0"),U,2)="M":"X"_U,1:U_"X")_U

 +2        SET ABMF(7)=ABMF(7)_$EXTRACT($PIECE(ABM("P0"),U,3),4,5)_U_$EXTRACT($PIECE(ABM("P0"),U,3),6,7)_U_($EXTRACT($PIECE(ABM("P0"),U,3),1,3)+1700)

 +3        KILL ABM("P0")

 +4       ;

 +5        SET (ABMV("X1"),ABMV("X2"),ABMV("X3"))=""

 +6        DO PAT^ABMDE1X

           DO REMPL^ABMDE1X1

           DO LOC^ABMDE1X1

           KILL ABME

LOC        SET $PIECE(ABMF(24),U)=$SELECT($PIECE(ABMV("X1"),U,2)]"":$PIECE(ABMV("X1"),U,2),1:$PIECE($PIECE(ABMV("X1"),U),";",2))

 +1        IF DUZ(2)=1581

               IF (ABMP("VTYP")=998)

                   SET $PIECE(ABMF(24),U)="SAN FELIPE HS"

 +2        SET $PIECE(ABMF(26),U)=$PIECE(ABMV("X1"),U,3)

           SET $PIECE(ABMF(28),U)=$PIECE(ABMV("X1"),U,4)

 +3        IF DUZ(2)=1581

               IF (ABMP("VTYP")=998)

                   SET $PIECE(ABMF(26),U)="PO BOX 4339"

                   SET $PIECE(ABMF(28),U)="SAN FELIPE, NM 87001"

 +4        SET $PIECE(ABMF(30),U)=$PIECE(ABMV("X1"),U,6)

           SET $PIECE(ABMF(30),U,3)=$PIECE(ABMV("X1"),U,5)

 +5        IF DUZ(2)=1581

               IF (ABMP("VTYP")=998)

                   SET $PIECE(ABMF(30),U)=850210848

 +6        SET ABMLOC=$PIECE(ABMP("B0"),U,3)

 +7        SET ABMV("X1")=$GET(^AUTTLOC(ABMLOC,0))

 +8        SET $PIECE(ABMF(61),U)=$PIECE(ABMV("X1"),U,12)

 +9        SET $PIECE(ABMF(61),U,2)=$PIECE(ABMV("X1"),U,13)

 +10       SET ABML=$PIECE(ABMV("X1"),U,14)

 +11       SET $PIECE(ABMF(61),U,3)=$PIECE(^DIC(5,ABML,0),U,2)

 +12       SET $PIECE(ABMF(61),U,4)=$PIECE(ABMV("X1"),U,15)

 +13       IF $PIECE($GET(^AUTNINS(ABMP("INS"),0)),U)["DELTA DENTAL"

               Begin DoDot:1

 +14      ;address

                   SET $PIECE(ABMF(26),U)=$PIECE($GET(^DIC(4,ABMP("LDFN"),1)),U)

 +15      ;city

                   SET $PIECE(ABMF(28),U)=$PIECE($GET(^DIC(4,ABMP("LDFN"),1)),U,3)

 +16      ;state

                   SET ABMX("STATE")=$PIECE($GET(^DIC(4,ABMP("LDFN"),0)),U,2)

 +17               SET $PIECE(ABMF(28),U)=$PIECE(ABMF(28),U)_", "_$PIECE($GET(^DIC(5,+ABMX("STATE"),0)),U,2)

 +18      ;zip

                   SET $PIECE(ABMF(28),U)=$PIECE(ABMF(28),U)_" "_$PIECE($GET(^DIC(4,ABMP("LDFN"),1)),U,4)

               End DoDot:1

 +19      ;

INSNUM    ;

 +1        SET ABM("INUM")=$PIECE($GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,$PIECE(ABMP("B0"),U,7),0)),U,8)

 +2        IF ABM("INUM")=""

               SET ABM("INUM")=$PIECE($GET(^AUTNINS(ABMP("INS"),15,ABMP("LDFN"),0)),U,2)

 +3        SET $PIECE(ABMF(30),U,2)=ABM("INUM")

 +4       ;

PRV        SET ABM("X")=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),41,"C","A",0))

           IF ABM("X")

               Begin DoDot:1

 +1                DO SELBILL^ABMDE4X

 +2                SET $PIECE(ABMF(4),U)=$GET(ABM("PNUM"))

 +3                DO PAYED^ABMERUTL

 +4       ;S ABMF(58)=$P(ABM("A"),U)_U_ABM("PNUM")_U_DT_U_$G(ABMP("PAYED"))  ;abm*2.6*6 HEAT27940

 +5       ;abm*2.6*6 HEAT27940

                   SET ABMF(58)=$PIECE(ABM("A"),U)_U_ABM("PNUM")_U_U_$GET(ABMP("PAYED"))

 +6       ;S $P(ABMF(58),U,3)=$S($G(ABMP("PRINTDT"))="O":$P($G(^ABMDTXST(DUZ(2),$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),1)),U,7),0)),U),1:DT)  ;abm*2.6*6 HEAT27940  ;abm*2.6*11 HEAT81561

 +7       ;abm*2.6*6 HEAT27940  ;abm*2.6*11 HEAT81561

                   SET $PIECE(ABMF(58),U,3)=$SELECT($GET(ABMP("PRINTDT"))="O":$PIECE($GET(^ABMDTXST(DUZ(2),$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),1)),U,7),0)),U),$GET(ABMP("PRINTDT"))="A":$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),1)),U,5),1:DT)

               End DoDot:1

POL       ;POLICY INFORMATION

 +1        NEW I

           SET I=0

           FOR 

               SET I=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,I))

               IF 'I

                   QUIT 

               Begin DoDot:1

 +2                IF $PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,I,0),"^",3)="I"

                       SET ABM("XIEN")=I

               End DoDot:1

 +3        IF $GET(ABM("XIEN"))=""

               SET ABM("XIEN")=+$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,"B",ABMP("INS"),0))

 +4        SET Y=ABMP("INS")

           SET ABMP("GL")="^ABMDBILL(DUZ(2),"_ABMP("BDFN")_","

 +5        DO SEL^ABMDE2X

 +6        IF ABM("ADD")["NON-BEN"

               Begin DoDot:1

 +7                SET ABM("ADD")=ABMV("X2")

 +8                SET ABMF(2)="^^"_$PIECE($PIECE(ABM("ADD"),U),";",2)

 +9                SET ABMF(3)="^"_$PIECE(ABM("ADD"),U,3)

 +10               SET ABMF(4)="^^"_$PIECE(ABM("ADD"),U,4)

               End DoDot:1

 +11       SET $PIECE(ABMF(9),U)=$PIECE($PIECE(ABMV("X2"),U),";",2)

 +12       SET $PIECE(ABMF(10),U)=$PIECE(ABMV("X2"),U,3)

 +13       SET $PIECE(ABMF(11),U)=$PIECE(ABMV("X2"),U,4)

 +14       SET $PIECE(ABMF(11),U,2)=$PIECE(ABMV("X1"),U,4)

 +15       SET $PIECE(ABMF(11),U,3)=$EXTRACT($PIECE(ABMV("X2"),U,7),4,5)

 +16       SET $PIECE(ABMF(11),U,4)=$EXTRACT($PIECE(ABMV("X2"),U,7),6,7)

 +17       SET $PIECE(ABMF(11),U,5)=($EXTRACT($PIECE(ABMV("X2"),U,7),1,3)+1700)

EMPL       SET $PIECE(ABMF(9),U,2)=$PIECE(ABMV("X3"),U)

           SET $PIECE(ABMF(10),U,3)=$PIECE(ABMV("X3"),U,2)

           SET $PIECE(ABMF(11),U,6)=$PIECE(ABMV("X3"),U,3)

 +1        SET $PIECE(ABMF(10),U,4)=$PIECE(ABMV("X3"),U,6)

           SET $PIECE(ABMF(11),U,7)=$PIECE(ABMV("X3"),U,7)

REL        IF '$PIECE(ABMV("X2"),U,2)

               GOTO INS

 +1        SET ABM=+$PIECE($GET(^AUTTRLSH(+$PIECE(ABMV("X2"),U,2),0)),U,2)

 +2        IF ABM

               IF ABM<8

                   IF ABM'=2

                       SET $PIECE(ABMF(6),U,$SELECT(ABM=1:1,1:2))="X"

 +3       IF '$TEST

               SET $PIECE(ABMF(7),U,$SELECT(ABM=2:2,1:3))="X"

INS       ;

 +1        SET ABM("I")=0

 +2        FOR 

               SET ABM("I")=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,"C",ABM("I")))

               IF 'ABM("I")

                   QUIT 

               SET ABM=$ORDER(^(ABM("I"),0))

               Begin DoDot:1

 +3                SET ABM=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM,0),U)

 +4                IF ABM'=ABMP("INS")

                       Begin DoDot:2

 +5                        IF "U"[$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM,0)),U,3)

                               QUIT 

 +6                        SET Y=ABM

 +7                        SET ABMP("GL")="^ABMDBILL(DUZ(2),"_ABMP("BDFN")_","

 +8                        DO SEL^ABMDE2X

 +9                        SET $PIECE(ABMF(13),U,3)=$PIECE(^AUTNINS(ABM,0),U)

 +10                       SET $PIECE(ABMF(14),U)=$PIECE(^AUTNINS(ABM,0),U,2)

 +11                       SET $PIECE(ABMF(15),U,3)=$$CSZ^ABMDUTL($PIECE(^AUTNINS(ABM,0),U,3,5))

 +12                       SET $PIECE(ABMF(14),U,2)=$PIECE(ABMV("X3"),U,6)

 +13                       SET $PIECE(ABMF(15),U,4)=$PIECE(ABMV("X3"),U,7)

 +14                       SET $PIECE(ABMF(13),U,5)=$PIECE(ABMV("X3"),U)

 +15                       SET $PIECE(ABMF(14),U,3)=$PIECE(ABMV("X3"),U,2)

 +16                       SET $PIECE(ABMF(15),U,5)=$PIECE(ABMV("X3"),U,3)

 +17                       SET $PIECE(ABMF(18),U)=$PIECE($PIECE(ABMV("X2"),U),";",2)

 +18                       SET $PIECE(ABMF(18),U,2)=$PIECE(ABMV("X1"),U,4)

 +19                       SET $PIECE(ABMF(18),U,3)=$EXTRACT($PIECE(ABMV("X2"),U,7),4,5)

 +20                       SET $PIECE(ABMF(18),U,4)=$EXTRACT($PIECE(ABMV("X2"),U,7),6,7)

 +21                       SET $PIECE(ABMF(18),U,5)=($EXTRACT($PIECE(ABMV("X2"),U,7),1,3)+1700)

 +22                       IF $PIECE(ABMV("X2"),U,2)

                               Begin DoDot:3

 +23                               SET ABMREL=+$PIECE($GET(^AUTTRLSH(+$PIECE(ABMV("X2"),U,2),0)),U,2)

 +24                               IF ABMREL

                                       IF ABMREL<8

                                           IF ABMREL'=2

                                               SET $PIECE(ABMF(17),U,$SELECT(ABMREL=1:2,1:3))="X"

 +25                              IF '$TEST

                                       SET $PIECE(ABMF(18),U,$SELECT(ABMREL=2:6,1:7))="X"

                               End DoDot:3

 +26                       IF $PIECE($GET(^AUTNINS(ABM,2)),U,5)="O"

                               SET $PIECE(ABMF(13),U)="X"

 +27                      IF '$TEST

                               SET $PIECE(ABMF(15),U)="X"

                       End DoDot:2

                       QUIT 

               End DoDot:1

 +28       IF $PIECE($GET(ABMF(13)),U)=""

               SET $PIECE(ABMF(13),U,2)="X"

 +29       IF $PIECE($GET(ABMF(15)),U)=""

               SET $PIECE(ABMF(15),U,2)="X"

 +30      ;

BNODES     IF $DATA(^ABMDBILL(DUZ(2),ABMP("BDFN"),0))

               SET ABM("B4")=$GET(^(4))

               SET ABM("B7")=$GET(^(7))

               SET ABM("B8")=$GET(^(8))

               SET ABM("B9")=$GET(^(9))

 +1        IF $PIECE(ABM("B9"),U)]""

               SET $PIECE(ABMF(24),U,3)="X"

 +2       IF '$TEST

               SET $PIECE(ABMF(24),U,2)="X"

 +3       ;

ACCD       SET $PIECE(ABMF(26),U,$SELECT('$PIECE(ABM("B8"),U,3):2,"12"[$PIECE(ABM("B8"),U,3):3,1:2))="X"

 +1        SET $PIECE(ABMF(28),U,$SELECT("12"[$PIECE(ABM("B8"),U,3):2,1:3))="X"

FSYM       SET $PIECE(ABMF(32),U)=$PIECE(ABM("B8"),U,6)

 +1        IF $PIECE(ABM("B7"),U,4)="Y"

               SET ABMF(21)="SIGNATURE ON FILE"_U_DT

 +2        IF $PIECE(ABM("B7"),U,5)="Y"