ABMDF27X ; IHS/ASDST/DMJ - New HCFA-1500 (08/05) Format ;
;;2.6;IHS Third Party Billing;**1,3,4,8,9,10,11,13,21**;NOV 12, 2009;Build 379
;
; Objective: Print designated form using data contained in the
; ABMF array.
;
; IHS/SD/SDR - v2.5 p12 - IM25017 - Changes for 1st line of block 24J provider number
; IHS/SD/SDR - v2.5 p12 - IM25331 - Put taxonomy code if NPI ONLY
; IHS/SD/SDR - v2.5 p12 - IM24829 - Make 24a 2-digit rather than 4 and TO format
; IHS/SD/SDR - v2.5 p13 - IM25899 - Alignment changes
; IHS/SD/SDR - v2.5 p13 - IM25365 - Changed for FL override
; IHS/SD/SDR - abm*2.6*1 - HEAT3077 - Change FL override to remove NPI from 24I
; IHS/SD/SDR - abm*2.6*3 - HEAT11389 - made correction to OVER to check line number
; IHS/SD/SDR - abm*2.6*4 HEAT12115 - allow 5+ DX codes
; IHS/SD/SDR - 2.6*9 - fixed FL override to use LDFN not DUZ(2)
;IHS/SD/SDR - 2.6*13 - HEAT117086 - changed it so T1015 will be top line for any D insurer type
;IHS/SD/SDR - 2.6*21 - HEAT205579 - Made T1015 print on first line for ARBOR HEALTH PLAN
;IHS/SD/SDR - 2.6*21 - NOHEAT1 - Fix for <UNDEF>LOOP+29^ABMDF27X
;
;
MARG ;Set left and top margins
S (ABM("LM"),ABM("TM"),ABM("LN"))=0
I $G(IOT)'="HFS" S ABM("TM")=$P(^ABMDEXP(27,0),U,3),ABM("LM")=$P(^(0),U,2)
W $$EN^ABMVDF("IOF")
I +ABM("TM") F ABM("I")=1:1:ABM("TM") W !
D:$G(ABMP("INS")) OVER
;
LOOP ;Loop thru line number array
S ABM("LN")=$O(ABMF(ABM("LN"))) I +ABM("LN")=0!(ABM("LN")>56) G XIT
;
;Check for invalid line numbers
F ABM("I")=2,4,6,8,10,12,14,16,18,20,21,22,24,28,30,32,34,35,48,55,56,57 I ABM("LN")=ABM("I") Q
I G LOOP
;
;Set to correct format line
S ABM("FL")=ABM("LN")
I ABM("LN")>35,(ABM("LN")<48),$L(ABMF(ABM("LN")),"^")<4 S ABM("FL")=36
I ABM("LN")>35,(ABM("LN")<48),$L(ABMF(ABM("LN")),"^")>3 S ABM("FL")=37
;
;Set tab & format variables
S ABM("TABS")=$P($T(@ABM("FL")),";;",2)
S ABM("FMAT")=$P($T(@ABM("FL")),";;",3)
;
;added NE Medicaid code for W0047 to print first
I $P(ABMF(17),U,4)["NEBRASKA MEDICAID",ABMP("VTYP")=131 D
.F ABMLOOP=37:2:47 D
..Q:'$D(ABMF(ABMLOOP))
..S ABMCHK=$TR($P(ABMF(ABMLOOP),U,5)," ","")
..I ABMCHK["W0047",ABMLOOP'=37 D
...S ABMF("TMP")=$G(ABMF(37))
...S ABMF(37)=$G(ABMF(ABMLOOP))
...S ABMF(ABMLOOP)=$G(ABMF("TMP"))
K ABMLOOP,ABMCHK,ABMF("TMP")
;
;start new code abm*2.6*11 HEAT97421
;I $P(ABMF(17),U,4)["IOWA MEDICAID" D ;abm*2.6*13 HEAT117086
;I ABMP("ITYPE")="D" D ;abm*2.6*13 HEAT117086 ;abm*2.6*21 IHS/SD/SDR NOHEAT1
I $G(ABMP("ITYPE"))="D"!($P($G(^AUTNINS(ABMP("INS"),0)),U)="ARBOR HEALTH PLAN") D ;abm*2.6*13 HEAT117086 ;abm*2.6*21 IHS/SD/SDR NOHEAT1 and HEAT205579
.F ABMLOOP=37:2:47 D
..Q:'$D(ABMF(ABMLOOP))
..S ABMCHK=$TR($P(ABMF(ABMLOOP),U,5)," ","")
..I ABMCHK["T1015",ABMLOOP'=37 D
...S ABMF("TMP")=$G(ABMF(37))
...S ABMF(37)=$G(ABMF(ABMLOOP))
...S ABMF(ABMLOOP)=$G(ABMF("TMP"))
K ABMLOOP,ABMCHK,ABMF("TMP")
;end new code HEAT97421
;
;Skip to req'd line
F Q:$Y-ABM("TM")>(ABM("LN")+5) W ! D
.Q:($Y-ABM("TM")<1)!($Y-ABM("TM")>5)
.Q:$D(ABMF("TEST"))
.I $Y-ABM("TM")=5 W ?1,"XXX",?32,"Page "_ABMPGCNT_" of "_ABMPGTOT,?76,"XXX" S ABMPGCNT=ABMPGCNT+1 Q
.Q:'$D(ABMP("INS")) K ABM("INS")
.I ($Y-ABM("TM"))=1 D
..S ABM("J")=ABMP("BDFN"),ABM("I")=$P(^AUTNINS(ABMP("INS"),0),U)_"-"_ABMP("INS")
..S ABM("INS",ABM("I"),ABM("J"))=$S(ABM("I")["NON-BENEFICIARY PATIENT":$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),0),"^",5),1:"")
..D BADDR^ABMDLBL1
..W ?34,"To: "
.Q:'$D(ABM("ADD"))
.W ?38,$E($P(ABM("ADD"),U,($Y-ABM("TM"))),1,39)
;
; Test Modes for setting Data Fields
G LOOP2:'$D(ABMF("TEST"))
F ABM("I")=1:1:$L(ABM("FMAT"),U) I $P(ABM("TABS"),U,ABM("I"))]"" S ABM("FLD")="",$P(ABM("FLD"),"X",$P(ABM("FMAT"),U,ABM("I"))+1)="" I ABM("FLD")]"" W ?($P(ABM("TABS"),U,ABM("I"))+ABM("LM")) D FRMT
G LOOP
;
LOOP2 ;Loop thru the pieces of the line array
F ABM("I")=1:1:$L(ABMF(ABM("LN")),U) D
.Q:'+$P(ABM("TABS"),U,ABM("I"))
.I ABM("LN")=29,(ABM("I")=4),ABMPGCNT>2 Q ;abm*2.6*10 HEAT65976
.I ABM("LN")>30,(ABM("LN")<34),(ABM("I")<3),($P(ABMF(17),U,4)["MAINE MEDICAID") D
..S $P(ABMF(ABM("LN")),U,ABM("I"))=$TR($P(ABMF(ABM("LN")),U,ABM("I")),".","")
.;if Maine Medicaid take commas of out box 24E
.I ABM("LN")>36,(ABM("LN")<48),(ABM("I")=6),($P(ABMF(17),U,4)["MAINE MEDICAID") D
..S $P(ABMF(ABM("LN")),U,ABM("I"))=$TR($P(ABMF(ABM("LN")),U,ABM("I")),",","")
.S ABM("FLD")=$P(ABMF(ABM("LN")),U,ABM("I"))
.I $G(ABMP("PTOT"))'=1,($D(ABMP("MORE"))),(ABM("LN")=49),(ABM("I")=7!(ABM("I")=9)) S ABM("FLD")=$G(ABM("LTOT"))
.I ABM("FLD")]"" W ?($P(ABM("TABS"),U,ABM("I"))+ABM("LM")) D FRMT
.;Put "cont" in total charges box if multi page.
.I $D(ABMR("MORE")),ABM("LN")=49,ABM("I")=7,$G(ABMP("PTOT"))=1 W ?52,"(CONT.)"
G LOOP
;
;Write the field in the designated format
FRMT S ABM("LTH")=$P(ABM("FMAT"),U,ABM("I")) I +ABM("LTH")=0 S ABM("LTH")=99
I $P(ABMF(17),U,4)="PHC MEDICAID",ABM("LTH")["$" S ABM("LTH")=$P(ABM("LTH"),"$") W $J($TR($FN(+ABM("FLD"),",",2),"."),ABM("LTH")) S:ABM("LN")'=49 ABM("LTOT")=+$G(ABM("LTOT"))+ABM("FLD") Q ;abm*2.6*11 IHS/SD/AML HEAT30524 PARTNERSHIP MCD
;I ABM("LTH")["$" S ABM("LTH")=$P(ABM("LTH"),"$") W $J($FN(+ABM("FLD"),",",2),ABM("LTH")) S:ABM("LN")'=49 ABM("LTOT")=+$G(ABM("LTOT"))+ABM("FLD") Q ;abm*2.6*10 HEAT65976
I ABM("LTH")["$" S ABM("LTH")=$P(ABM("LTH"),"$") W $J($FN(+ABM("FLD"),",",2),ABM("LTH")) S:(ABM("LN")'=49&(ABM("LN")'=29)) ABM("LTOT")=+$G(ABM("LTOT"))+ABM("FLD") Q ;abm*2.6*10 HEAT65976
;if Maine Medicaid take spaces out of dates
I $P(ABMF(17),U,4)["MAINE MEDICAID",(ABM("LTH")["D") S ABM("LTH")=$P(ABM("LTH"),"D") W $E(ABM("FLD"),4,5),$E(ABM("FLD"),6,7),$E(ABM("FLD"),1,3)+1700 Q
I ABM("LTH")["T" S ABM("LTH")=$P(ABM("LTH"),"T") W $E(ABM("FLD"),4,5)," ",$E(ABM("FLD"),6,7)," ",$E(ABM("FLD"),2,3) Q
I ABM("LTH")["D" S ABM("LTH")=$P(ABM("LTH"),"D") W $E(ABM("FLD"),4,5)," ",$E(ABM("FLD"),6,7)," ",$E(ABM("FLD"),1,3)+1700 Q
I ABM("LTH")["Y" S ABM("LTH")=$P(ABM("LTH"),"Y") W $E(ABM("FLD"),4,7),$E(ABM("FLD"),1,3)+1700 Q
I ABM("LTH")["L" S ABM("LTH")=$P(ABM("LTH"),"L") F Q:$L(ABM("FLD"))=ABM("LTH")!($L(ABM("FLD"))>ABM("LTH")) S ABM("FLD")="0"_ABM("FLD")
I ABM("LTH")["C" S ABM("LTH")=$P(ABM("LTH"),"C") S ABM("FLD")=$J("",ABM("LTH")-$L(ABM("FLD"))\2)_ABM("FLD")
I ABM("LTH")["R" S ABM("LTH")=$P(ABM("LTH"),"R") S ABM("RT")=ABM("LTH")-$L(ABM("FLD"))+1 I ABM("RT")>1 S ABM("BLNK")="",$P(ABM("BLNK")," ",ABM("RT"))="",ABM("FLD")=ABM("BLNK")_ABM("FLD")
W $E(ABM("FLD"),1,ABM("LTH"))
Q
;
TEST S ABMF("TEST")=1
F ABM=0:ABMF("TEST"):60 S ABMF(ABM)=""
G MARG
;
OVER ;GET OVRRIDE VALUES FROM 3P INSURER FILE
;S ABMOLN=0 F S ABMOLN=$O(^ABMNINS(DUZ(2),ABMP("INS"),2,"AOVR",27,ABMOLN)) Q:'ABMOLN D ;abm*2.6*9 HEAT51380
S ABMOLN=0 F S ABMOLN=$O(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",27,ABMOLN)) Q:'ABMOLN D ;abm*2.6*9 HEAT51380
.;S ABMOPC=0 F S ABMOPC=$O(^ABMNINS(DUZ(2),ABMP("INS"),2,"AOVR",27,ABMOLN,ABMOPC)) Q:'ABMOPC D ;abm*2.6*9 HEAT51380
.S ABMOPC=0 F S ABMOPC=$O(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",27,ABMOLN,ABMOPC)) Q:'ABMOPC D ;abm*2.6*9 HEAT51380
..K ABMOVTYP
..;I $D(^ABMNINS(DUZ(2),ABMP("INS"),2,"AOVR",27,ABMOLN,ABMOPC,0)) S ABMOVTYP=0 ;abm*2.6*9 HEAT51380
..I $D(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",27,ABMOLN,ABMOPC,0)) S ABMOVTYP=0 ;abm*2.6*9 HEAT51380
..;I $D(^ABMNINS(DUZ(2),ABMP("INS"),2,"AOVR",27,ABMOLN,ABMOPC,ABMP("VTYP"))) S ABMOVTYP=ABMP("VTYP") ;abm*2.6*9 HEAT51380
..I $D(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",27,ABMOLN,ABMOPC,ABMP("VTYP"))) S ABMOVTYP=ABMP("VTYP") ;abm*2.6*9 HEAT51380
..Q:'$D(ABMOVTYP)
..;S ABMVALUE=^ABMNINS(DUZ(2),ABMP("INS"),2,"AOVR",27,ABMOLN,ABMOPC,ABMOVTYP) ;abm*2.6*9 HEAT51380
..S ABMVALUE=^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",27,ABMOLN,ABMOPC,ABMOVTYP) ;abm*2.6*9 HEAT51380
..;I ABMOLN>35,ABMOLN<49 N I F I=36:2:47 D ;abm*2.6*1 HEAT3077
..;I ABMOLN>35,ABMOLN<49 N I F I=36:1:47 D ;abm*2.6*1 HEAT3077 ;abm*2.6*10 HEAT64983
..;I ABMOLN>35,ABMOLN<49 N I F I=36:1:47 D Q ;abm*2.6*1 HEAT3077 ;abm*2.6*10 HEAT64983 ;abm*2.6*11 HEAT104682
..I ABMOLN>35,ABMOLN<49 N I F I=36:1:47 D ;abm*2.6*11 HEAT104682
...Q:'$D(ABMF(I))
...Q:$L(ABMF(I),"^")<3
...;Q:((ABMF(I)#2)'=(ABMOLN#2)) ;abm*2.6*3 HEAT11389
...Q:((I#2)'=(ABMOLN#2)) ;abm*2.6*3 HEAT11389
...S $P(ABMF(I),"^",ABMOPC)=ABMVALUE
..;I ABMOLN>36,ABMOLN<49 Q ;abm*2.6*10 HEAT64983
..;S $P(ABMF(ABMOLN),"^",$S((ABMOLN=53):(ABMOPC-1),(ABMOLN=54):(ABMOPC+1),1:ABMOPC))=ABMVALUE ;abm*2.6*10 HEAT64983
..S $P(ABMF(ABMOLN),"^",$S((ABMOLN=53&ABMOPC=1):ABMOPC,(ABMOLN=53):(ABMOPC-1),(ABMOLN=54):(ABMOPC+1),1:ABMOPC))=ABMVALUE ;abm*2.6*10 HEAT64983
K ABMOLN,ABMOPC,ABMVALUE,ABMOVTYP
Q
XIT K ABM
I '$D(ABMR("MORE")) K ABMF
Q
TEXT ;;TABS;;FIELD LENGTH
; FORMAT ($-$ FORMAT,L-LNGTH REQ'D,C-CENTER,R-RIGHT,D-DATE)
1 ;;1^8^15^24^31^39^45^50;;1^1^1^1^1^1^1^29C
3 ;;1^31^42^47^50;;28^10D^1^1^29C
5 ;;1^33^38^42^47^50;;28^1^1^1^1^29C
7 ;;1^27^35^41^47^50^75;;24^3^1^1^1^23C^4
9 ;;1^14^35^41^47^50^64;;12^13^1^1^1^12C^13
11 ;;1^50;;28^29C
13 ;;1^35^41^53^68^75;;28^1^1^10D^1^1
15 ;;2^18^24^35^41^46^50;;10D^1^1^1^1^2^29C
17 ;;1^35^41^50;;28C^1^1^29C
19 ;;1^30^52^57;;28C^19C^1^1
23 ;;6^37^56;;24C^10D^23
25 ;;2^37^54^68;;10D^10D^10D^10D
26 ;;30;;19
27 ;;1^33^54^68;;26^10^10D^10D
29 ;;1^52^57^62;;48^1^1^8$
31 ;;3^13^29^38^50;;^10^10^9^10^29
;;3^30^50;;25^19^29 ;abm*2.6*4 HEAT12115 original 31
33 ;;3^13^29^38^50;;^10^10^9^10^29C
;;3^30^50;;25^19^29C ;abm*2.6*4 HEAT12115 original 33
36 ;;1^65^68;;61^2^12
;;1^63^65;;61^2^15 ;abm*2.6*8 HEAT14200 original 36
37 ;;1^10^19^22^23^45^50^59^63^65^68;;8T^8T^2R^1R^19^5^8$^4C^2R^2R^10
;;1^10^19^22^23^45^50^59^63^65^68;;8T^8T^2R^1R^19^7^8$^5R^2R^2R^10 ;abm*2.6*11 IHS/SD/AML HEAT97406 - Move Units to left
;;1^10^19^22^23^45^50^59^63^65^68;;8T^8T^2R^1R^19^7^8$^3R^2R^2R^10 ;abm*2.6*10 HEAT60484 original line 37
49 ;;1^17^19^23^38^43^51^61^71;;15^1^1^14C^1^1^9$^8$^8$
50 ;;65;;14
51 ;;23^50;;26^29
52 ;;1^23^50;;21^26^29
53 ;;1^23^50;;21^26^29
;;23^50;;26^29 ;original line 53 abm*2.6*10 HEAT64983
54 ;;12^23^33^50^62;;10D^10^14R^10C^17
ABMDF27X ; IHS/ASDST/DMJ - New HCFA-1500 (08/05) Format ;
+1 ;;2.6;IHS Third Party Billing;**1,3,4,8,9,10,11,13,21**;NOV 12, 2009;Build 379
+2 ;
+3 ; Objective: Print designated form using data contained in the
+4 ; ABMF array.
+5 ;
+6 ; IHS/SD/SDR - v2.5 p12 - IM25017 - Changes for 1st line of block 24J provider number
+7 ; IHS/SD/SDR - v2.5 p12 - IM25331 - Put taxonomy code if NPI ONLY
+8 ; IHS/SD/SDR - v2.5 p12 - IM24829 - Make 24a 2-digit rather than 4 and TO format
+9 ; IHS/SD/SDR - v2.5 p13 - IM25899 - Alignment changes
+10 ; IHS/SD/SDR - v2.5 p13 - IM25365 - Changed for FL override
+11 ; IHS/SD/SDR - abm*2.6*1 - HEAT3077 - Change FL override to remove NPI from 24I
+12 ; IHS/SD/SDR - abm*2.6*3 - HEAT11389 - made correction to OVER to check line number
+13 ; IHS/SD/SDR - abm*2.6*4 HEAT12115 - allow 5+ DX codes
+14 ; IHS/SD/SDR - 2.6*9 - fixed FL override to use LDFN not DUZ(2)
+15 ;IHS/SD/SDR - 2.6*13 - HEAT117086 - changed it so T1015 will be top line for any D insurer type
+16 ;IHS/SD/SDR - 2.6*21 - HEAT205579 - Made T1015 print on first line for ARBOR HEALTH PLAN
+17 ;IHS/SD/SDR - 2.6*21 - NOHEAT1 - Fix for <UNDEF>LOOP+29^ABMDF27X
+18 ;
+19 ;
MARG ;Set left and top margins
+1 SET (ABM("LM"),ABM("TM"),ABM("LN"))=0
+2 IF $GET(IOT)'="HFS"
SET ABM("TM")=$PIECE(^ABMDEXP(27,0),U,3)
SET ABM("LM")=$PIECE(^(0),U,2)
+3 WRITE $$EN^ABMVDF("IOF")
+4 IF +ABM("TM")
FOR ABM("I")=1:1:ABM("TM")
WRITE !
+5 IF $GET(ABMP("INS"))
DO OVER
+6 ;
LOOP ;Loop thru line number array
+1 SET ABM("LN")=$ORDER(ABMF(ABM("LN")))
IF +ABM("LN")=0!(ABM("LN")>56)
GOTO XIT
+2 ;
+3 ;Check for invalid line numbers
+4 FOR ABM("I")=2,4,6,8,10,12,14,16,18,20,21,22,24,28,30,32,34,35,48,55,56,57
IF ABM("LN")=ABM("I")
QUIT
+5 IF $TEST
GOTO LOOP
+6 ;
+7 ;Set to correct format line
+8 SET ABM("FL")=ABM("LN")
+9 IF ABM("LN")>35
IF (ABM("LN")<48)
IF $LENGTH(ABMF(ABM("LN")),"^")<4
SET ABM("FL")=36
+10 IF ABM("LN")>35
IF (ABM("LN")<48)
IF $LENGTH(ABMF(ABM("LN")),"^")>3
SET ABM("FL")=37
+11 ;
+12 ;Set tab & format variables
+13 SET ABM("TABS")=$PIECE($TEXT(@ABM("FL")),";;",2)
+14 SET ABM("FMAT")=$PIECE($TEXT(@ABM("FL")),";;",3)
+15 ;
+16 ;added NE Medicaid code for W0047 to print first
+17 IF $PIECE(ABMF(17),U,4)["NEBRASKA MEDICAID"
IF ABMP("VTYP")=131
Begin DoDot:1
+18 FOR ABMLOOP=37:2:47
Begin DoDot:2
+19 IF '$DATA(ABMF(ABMLOOP))
QUIT
+20 SET ABMCHK=$TRANSLATE($PIECE(ABMF(ABMLOOP),U,5)," ","")
+21 IF ABMCHK["W0047"
IF ABMLOOP'=37
Begin DoDot:3
+22 SET ABMF("TMP")=$GET(ABMF(37))
+23 SET ABMF(37)=$GET(ABMF(ABMLOOP))
+24 SET ABMF(ABMLOOP)=$GET(ABMF("TMP"))
End DoDot:3
End DoDot:2
End DoDot:1
+25 KILL ABMLOOP,ABMCHK,ABMF("TMP")
+26 ;
+27 ;start new code abm*2.6*11 HEAT97421
+28 ;I $P(ABMF(17),U,4)["IOWA MEDICAID" D ;abm*2.6*13 HEAT117086
+29 ;I ABMP("ITYPE")="D" D ;abm*2.6*13 HEAT117086 ;abm*2.6*21 IHS/SD/SDR NOHEAT1
+30 ;abm*2.6*13 HEAT117086 ;abm*2.6*21 IHS/SD/SDR NOHEAT1 and HEAT205579
IF $GET(ABMP("ITYPE"))="D"!($PIECE($GET(^AUTNINS(ABMP("INS"),0)),U)="ARBOR HEALTH PLAN")
Begin DoDot:1
+31 FOR ABMLOOP=37:2:47
Begin DoDot:2
+32 IF '$DATA(ABMF(ABMLOOP))
QUIT
+33 SET ABMCHK=$TRANSLATE($PIECE(ABMF(ABMLOOP),U,5)," ","")
+34 IF ABMCHK["T1015"
IF ABMLOOP'=37
Begin DoDot:3
+35 SET ABMF("TMP")=$GET(ABMF(37))
+36 SET ABMF(37)=$GET(ABMF(ABMLOOP))
+37 SET ABMF(ABMLOOP)=$GET(ABMF("TMP"))
End DoDot:3
End DoDot:2
End DoDot:1
+38 KILL ABMLOOP,ABMCHK,ABMF("TMP")
+39 ;end new code HEAT97421
+40 ;
+41 ;Skip to req'd line
+42 FOR
IF $Y-ABM("TM")>(ABM("LN")+5)
QUIT
WRITE !
Begin DoDot:1
+43 IF ($Y-ABM("TM")<1)!($Y-ABM("TM")>5)
QUIT
+44 IF $DATA(ABMF("TEST"))
QUIT
+45 IF $Y-ABM("TM")=5
WRITE ?1,"XXX",?32,"Page "_ABMPGCNT_" of "_ABMPGTOT,?76,"XXX"
SET ABMPGCNT=ABMPGCNT+1
QUIT
+46 IF '$DATA(ABMP("INS"))
QUIT
KILL ABM("INS")
+47 IF ($Y-ABM("TM"))=1
Begin DoDot:2
+48 SET ABM("J")=ABMP("BDFN")
SET ABM("I")=$PIECE(^AUTNINS(ABMP("INS"),0),U)_"-"_ABMP("INS")
+49 SET ABM("INS",ABM("I"),ABM("J"))=$SELECT(ABM("I")["NON-BENEFICIARY PATIENT":$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),0),"^",5),1:"")
+50 DO BADDR^ABMDLBL1
+51 WRITE ?34,"To: "
End DoDot:2
+52 IF '$DATA(ABM("ADD"))
QUIT
+53 WRITE ?38,$EXTRACT($PIECE(ABM("ADD"),U,($Y-ABM("TM"))),1,39)
End DoDot:1
+54 ;
+55 ; Test Modes for setting Data Fields
+56 IF '$DATA(ABMF("TEST"))
GOTO LOOP2
+57 FOR ABM("I")=1:1:$LENGTH(ABM("FMAT"),U)
IF $PIECE(ABM("TABS"),U,ABM("I"))]""
SET ABM("FLD")=""
SET $PIECE(ABM("FLD"),"X",$PIECE(ABM("FMAT"),U,ABM("I"))+1)=""
IF ABM("FLD")]""
WRITE ?($PIECE(ABM("TABS"),U,ABM("I"))+ABM("LM"))
DO FRMT
+58 GOTO LOOP
+59 ;
LOOP2 ;Loop thru the pieces of the line array
+1 FOR ABM("I")=1:1:$LENGTH(ABMF(ABM("LN")),U)
Begin DoDot:1
+2 IF '+$PIECE(ABM("TABS"),U,ABM("I"))
QUIT
+3 ;abm*2.6*10 HEAT65976
IF ABM("LN")=29
IF (ABM("I")=4)
IF ABMPGCNT>2
QUIT
+4 IF ABM("LN")>30
IF (ABM("LN")<34)
IF (ABM("I")<3)
IF ($PIECE(ABMF(17),U,4)["MAINE MEDICAID")
Begin DoDot:2
+5 SET $PIECE(ABMF(ABM("LN")),U,ABM("I"))=$TRANSLATE($PIECE(ABMF(ABM("LN")),U,ABM("I")),".","")
End DoDot:2
+6 ;if Maine Medicaid take commas of out box 24E
+7 IF ABM("LN")>36
IF (ABM("LN")<48)
IF (ABM("I")=6)
IF ($PIECE(ABMF(17),U,4)["MAINE MEDICAID")
Begin DoDot:2
+8 SET $PIECE(ABMF(ABM("LN")),U,ABM("I"))=$TRANSLATE($PIECE(ABMF(ABM("LN")),U,ABM("I")),",","")
End DoDot:2
+9 SET ABM("FLD")=$PIECE(ABMF(ABM("LN")),U,ABM("I"))
+10 IF $GET(ABMP("PTOT"))'=1
IF ($DATA(ABMP("MORE")))
IF (ABM("LN")=49)
IF (ABM("I")=7!(ABM("I")=9))
SET ABM("FLD")=$GET(ABM("LTOT"))
+11 IF ABM("FLD")]""
WRITE ?($PIECE(ABM("TABS"),U,ABM("I"))+ABM("LM"))
DO FRMT
+12 ;Put "cont" in total charges box if multi page.
+13 IF $DATA(ABMR("MORE"))
IF ABM("LN")=49
IF ABM("I")=7
IF $GET(ABMP("PTOT"))=1
WRITE ?52,"(CONT.)"
End DoDot:1
+14 GOTO LOOP
+15 ;
+16 ;Write the field in the designated format
FRMT SET ABM("LTH")=$PIECE(ABM("FMAT"),U,ABM("I"))
IF +ABM("LTH")=0
SET ABM("LTH")=99
+1 ;abm*2.6*11 IHS/SD/AML HEAT30524 PARTNERSHIP MCD
IF $PIECE(ABMF(17),U,4)="PHC MEDICAID"
IF ABM("LTH")["$"
SET ABM("LTH")=$PIECE(ABM("LTH"),"$")
WRITE $JUSTIFY($TRANSLATE($FNUMBER(+ABM("FLD"),",",2),"."),ABM("LTH"))
IF ABM("LN")'=49
SET ABM("LTOT")=+$GET(ABM("LTOT"))+ABM("FLD")
QUIT
+2 ;I ABM("LTH")["$" S ABM("LTH")=$P(ABM("LTH"),"$") W $J($FN(+ABM("FLD"),",",2),ABM("LTH")) S:ABM("LN")'=49 ABM("LTOT")=+$G(ABM("LTOT"))+ABM("FLD") Q ;abm*2.6*10 HEAT65976
+3 ;abm*2.6*10 HEAT65976
IF ABM("LTH")["$"
SET ABM("LTH")=$PIECE(ABM("LTH"),"$")
WRITE $JUSTIFY($FNUMBER(+ABM("FLD"),",",2),ABM("LTH"))
IF (ABM("LN")'=49&(ABM("LN")'=29))
SET ABM("LTOT")=+$GET(ABM("LTOT"))+ABM("FLD")
QUIT
+4 ;if Maine Medicaid take spaces out of dates
+5 IF $PIECE(ABMF(17),U,4)["MAINE MEDICAID"
IF (ABM("LTH")["D")
SET ABM("LTH")=$PIECE(ABM("LTH"),"D")
WRITE $EXTRACT(ABM("FLD"),4,5),$EXTRACT(ABM("FLD"),6,7),$EXTRACT(ABM("FLD"),1,3)+1700
QUIT
+6 IF ABM("LTH")["T"
SET ABM("LTH")=$PIECE(ABM("LTH"),"T")
WRITE $EXTRACT(ABM("FLD"),4,5)," ",$EXTRACT(ABM("FLD"),6,7)," ",$EXTRACT(ABM("FLD"),2,3)
QUIT
+7 IF ABM("LTH")["D"
SET ABM("LTH")=$PIECE(ABM("LTH"),"D")
WRITE $EXTRACT(ABM("FLD"),4,5)," ",$EXTRACT(ABM("FLD"),6,7)," ",$EXTRACT(ABM("FLD"),1,3)+1700
QUIT
+8 IF ABM("LTH")["Y"
SET ABM("LTH")=$PIECE(ABM("LTH"),"Y")
WRITE $EXTRACT(ABM("FLD"),4,7),$EXTRACT(ABM("FLD"),1,3)+1700
QUIT
+9 IF ABM("LTH")["L"
SET ABM("LTH")=$PIECE(ABM("LTH"),"L")
FOR
IF $LENGTH(ABM("FLD"))=ABM("LTH")!($LENGTH(ABM("FLD"))>ABM("LTH"))
QUIT
SET ABM("FLD")="0"_ABM("FLD")
+10 IF ABM("LTH")["C"
SET ABM("LTH")=$PIECE(ABM("LTH"),"C")
SET ABM("FLD")=$JUSTIFY("",ABM("LTH")-$LENGTH(ABM("FLD"))\2)_ABM("FLD")
+11 IF ABM("LTH")["R"
SET ABM("LTH")=$PIECE(ABM("LTH"),"R")
SET ABM("RT")=ABM("LTH")-$LENGTH(ABM("FLD"))+1
IF ABM("RT")>1
SET ABM("BLNK")=""
SET $PIECE(ABM("BLNK")," ",ABM("RT"))=""
SET ABM("FLD")=ABM("BLNK")_ABM("FLD")
+12 WRITE $EXTRACT(ABM("FLD"),1,ABM("LTH"))
+13 QUIT
+14 ;
TEST SET ABMF("TEST")=1
+1 FOR ABM=0:ABMF("TEST"):60
SET ABMF(ABM)=""
+2 GOTO MARG
+3 ;
OVER ;GET OVRRIDE VALUES FROM 3P INSURER FILE
+1 ;S ABMOLN=0 F S ABMOLN=$O(^ABMNINS(DUZ(2),ABMP("INS"),2,"AOVR",27,ABMOLN)) Q:'ABMOLN D ;abm*2.6*9 HEAT51380
+2 ;abm*2.6*9 HEAT51380
SET ABMOLN=0
FOR
SET ABMOLN=$ORDER(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",27,ABMOLN))
IF 'ABMOLN
QUIT
Begin DoDot:1
+3 ;S ABMOPC=0 F S ABMOPC=$O(^ABMNINS(DUZ(2),ABMP("INS"),2,"AOVR",27,ABMOLN,ABMOPC)) Q:'ABMOPC D ;abm*2.6*9 HEAT51380
+4 ;abm*2.6*9 HEAT51380
SET ABMOPC=0
FOR
SET ABMOPC=$ORDER(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",27,ABMOLN,ABMOPC))
IF 'ABMOPC
QUIT
Begin DoDot:2
+5 KILL ABMOVTYP
+6 ;I $D(^ABMNINS(DUZ(2),ABMP("INS"),2,"AOVR",27,ABMOLN,ABMOPC,0)) S ABMOVTYP=0 ;abm*2.6*9 HEAT51380
+7 ;abm*2.6*9 HEAT51380
IF $DATA(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",27,ABMOLN,ABMOPC,0))
SET ABMOVTYP=0
+8 ;I $D(^ABMNINS(DUZ(2),ABMP("INS"),2,"AOVR",27,ABMOLN,ABMOPC,ABMP("VTYP"))) S ABMOVTYP=ABMP("VTYP") ;abm*2.6*9 HEAT51380
+9 ;abm*2.6*9 HEAT51380
IF $DATA(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",27,ABMOLN,ABMOPC,ABMP("VTYP")))
SET ABMOVTYP=ABMP("VTYP")
+10 IF '$DATA(ABMOVTYP)
QUIT
+11 ;S ABMVALUE=^ABMNINS(DUZ(2),ABMP("INS"),2,"AOVR",27,ABMOLN,ABMOPC,ABMOVTYP) ;abm*2.6*9 HEAT51380
+12 ;abm*2.6*9 HEAT51380
SET ABMVALUE=^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",27,ABMOLN,ABMOPC,ABMOVTYP)
+13 ;I ABMOLN>35,ABMOLN<49 N I F I=36:2:47 D ;abm*2.6*1 HEAT3077
+14 ;I ABMOLN>35,ABMOLN<49 N I F I=36:1:47 D ;abm*2.6*1 HEAT3077 ;abm*2.6*10 HEAT64983
+15 ;I ABMOLN>35,ABMOLN<49 N I F I=36:1:47 D Q ;abm*2.6*1 HEAT3077 ;abm*2.6*10 HEAT64983 ;abm*2.6*11 HEAT104682
+16 ;abm*2.6*11 HEAT104682
IF ABMOLN>35
IF ABMOLN<49
NEW I
FOR I=36:1:47
Begin DoDot:3
+17 IF '$DATA(ABMF(I))
QUIT
+18 IF $LENGTH(ABMF(I),"^")<3
QUIT
+19 ;Q:((ABMF(I)#2)'=(ABMOLN#2)) ;abm*2.6*3 HEAT11389
+20 ;abm*2.6*3 HEAT11389
IF ((I#2)'=(ABMOLN#2))
QUIT
+21 SET $PIECE(ABMF(I),"^",ABMOPC)=ABMVALUE
End DoDot:3
+22 ;I ABMOLN>36,ABMOLN<49 Q ;abm*2.6*10 HEAT64983
+23 ;S $P(ABMF(ABMOLN),"^",$S((ABMOLN=53):(ABMOPC-1),(ABMOLN=54):(ABMOPC+1),1:ABMOPC))=ABMVALUE ;abm*2.6*10 HEAT64983
+24 ;abm*2.6*10 HEAT64983
SET $PIECE(ABMF(ABMOLN),"^",$SELECT((ABMOLN=53&ABMOPC=1):ABMOPC,(ABMOLN=53):(ABMOPC-1),(ABMOLN=54):(ABMOPC+1),1:ABMOPC))=ABMVALUE
End DoDot:2
End DoDot:1
+25 KILL ABMOLN,ABMOPC,ABMVALUE,ABMOVTYP
+26 QUIT
XIT KILL ABM
+1 IF '$DATA(ABMR("MORE"))
KILL ABMF
+2 QUIT
TEXT ;;TABS;;FIELD LENGTH
+1 ; FORMAT ($-$ FORMAT,L-LNGTH REQ'D,C-CENTER,R-RIGHT,D-DATE)
1 ;;1^8^15^24^31^39^45^50;;1^1^1^1^1^1^1^29C
3 ;;1^31^42^47^50;;28^10D^1^1^29C
5 ;;1^33^38^42^47^50;;28^1^1^1^1^29C
7 ;;1^27^35^41^47^50^75;;24^3^1^1^1^23C^4
9 ;;1^14^35^41^47^50^64;;12^13^1^1^1^12C^13
11 ;;1^50;;28^29C
13 ;;1^35^41^53^68^75;;28^1^1^10D^1^1
15 ;;2^18^24^35^41^46^50;;10D^1^1^1^1^2^29C
17 ;;1^35^41^50;;28C^1^1^29C
19 ;;1^30^52^57;;28C^19C^1^1
23 ;;6^37^56;;24C^10D^23
25 ;;2^37^54^68;;10D^10D^10D^10D
26 ;;30;;19
27 ;;1^33^54^68;;26^10^10D^10D
29 ;;1^52^57^62;;48^1^1^8$
31 ;;3^13^29^38^50;;^10^10^9^10^29
+1 ;;3^30^50;;25^19^29 ;abm*2.6*4 HEAT12115 original 31
33 ;;3^13^29^38^50;;^10^10^9^10^29C
+1 ;;3^30^50;;25^19^29C ;abm*2.6*4 HEAT12115 original 33
36 ;;1^65^68;;61^2^12
+1 ;;1^63^65;;61^2^15 ;abm*2.6*8 HEAT14200 original 36
37 ;;1^10^19^22^23^45^50^59^63^65^68;;8T^8T^2R^1R^19^5^8$^4C^2R^2R^10
+1 ;;1^10^19^22^23^45^50^59^63^65^68;;8T^8T^2R^1R^19^7^8$^5R^2R^2R^10 ;abm*2.6*11 IHS/SD/AML HEAT97406 - Move Units to left
+2 ;;1^10^19^22^23^45^50^59^63^65^68;;8T^8T^2R^1R^19^7^8$^3R^2R^2R^10 ;abm*2.6*10 HEAT60484 original line 37
49 ;;1^17^19^23^38^43^51^61^71;;15^1^1^14C^1^1^9$^8$^8$
50 ;;65;;14
51 ;;23^50;;26^29
52 ;;1^23^50;;21^26^29
53 ;;1^23^50;;21^26^29
+1 ;;23^50;;26^29 ;original line 53 abm*2.6*10 HEAT64983
54 ;;12^23^33^50^62;;10D^10^14R^10C^17
