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"
SET $PIECE(ABMF(21),U,3)="SIGNATURE ON FILE"
SET $PIECE(ABMF(21),U,4)=DT
+3 SET $PIECE(ABMF(32),U,2)="X"
XRAY SET $PIECE(ABMF(32),U,$SELECT($PIECE(ABM("B4"),U,3):7,1:6))="X"
+1 SET $PIECE(ABMF(32),U,8)=$PIECE(ABM("B4"),U,3)
ORTHO SET $PIECE(ABMF(32),U,$SELECT($PIECE(ABM("B4"),U,4):10,1:9))="X"
+1 IF $PIECE(ABM("B4"),U,4)
SET $PIECE(ABMF(32),U,11)=$PIECE(ABM("B4"),U,5)
PROTH SET $PIECE(ABMF(30),U,$SELECT($PIECE(ABM("B4"),U,6):5,1:4))="X"
+1 IF $PIECE(ABM("B4"),U,6)
SET $PIECE(ABMF(30),U,6)=$PIECE(ABM("B4"),U,7)
+2 SET $PIECE(ABMF(55),U)="Bill Number: "_$PIECE(ABMP("B0"),U)_$SELECT($PIECE($GET(^ABMDPARM(DUZ(2),1,2)),U,4)]"":"-"_$PIECE(^(2),U,4),1:"")
IF $PIECE($GET(^(3)),U,3)
IF $PIECE($GET(^AUPNPAT(ABMP("PDFN"),41,ABMP("LDFN"),0)),U,2)
SET $PIECE(ABMF(55),U)=$PIECE(ABMF(55),U)_" "_$PIECE(^(0),U,2)
+3 IF $DATA(^ABMDBILL(DUZ(2),ABMP("BDFN"),61,0))
Begin DoDot:1
+4 SET ABMIEN=0
+5 SET ABMLINE=51
+6 FOR
SET ABMIEN=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),61,ABMIEN))
IF +ABMIEN=0!(ABMLINE>54)
QUIT
Begin DoDot:2
+7 SET ABMF(ABMLINE)=$GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),61,ABMIEN,0))
+8 SET ABMLINE=ABMLINE+1
End DoDot:2
End DoDot:1
+9 ;
XIT KILL ABM,ABMV
+1 QUIT
