ABMDF2X ; IHS/ASDST/DMJ - PRINT HCFA 1500 ;
;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
;Original;TMD;
;
MARG ;Set left and top margins
S U="^",(ABM("LM"),ABM("TM"),ABM("LN"))=0
I $D(^ABMDEXP(2,0)) S ABM("TM")=$P(^(0),U,3),ABM("LM")=$P(^(0),U,2)
W $$EN^ABMVDF("IOF")
I +ABM("TM") F ABM("I")=1:1:ABM("TM") W !
;
;Loop thru line number array
LOOP 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,3,5,11,18,21,22,24,26,28,30,35,49 I ABM("LN")=ABM("I") Q
I G LOOP
;
;Set to correct format line
S ABM("FL")=$S(ABM("LN")=8:9,ABM("LN")=15:7,ABM("LN")=32:31,ABM("LN")>37&(ABM("LN")<49)&(ABM("LN")#2=1):37,ABM("LN")>37&(ABM("LN")<49)&(ABM("LN")#2=0):38,1:ABM("LN"))
;
;Set tab & format variables
S ABM("TABS")=$P($T(@ABM("FL")),";;",2)
S ABM("FMAT")=$P($T(@ABM("FL")),";;",3)
;
;Skip to req'd line
F Q:$Y-ABM("TM")>(ABM("LN")+3) W ! D
.Q:($Y-ABM("TM")<1)!($Y-ABM("TM")>4)
.I $Y-ABM("TM")=4 W "** Send PAYMENT to PROVIDER in Block 31 **"
.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:"")
..S ABM("IDFN")=ABMP("INS") D BADDR^ABMDLBL1
..W "To:"
.Q:'$D(ABM("ADD"))
.W ?4,$P(ABM("ADD"),U,($Y-ABM("TM")))
;
; 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
;
;Loop thru the pieces of the line array
LOOP2 F ABM("I")=1:1:$L(ABMF(ABM("LN")),U) I $P(ABM("TABS"),U,ABM("I"))]"" S ABM("FLD")=$P(ABMF(ABM("LN")),U,ABM("I")) I ABM("FLD")]"" W ?($P(ABM("TABS"),U,ABM("I"))+ABM("LM")) D FRMT
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 ABM("LTH")["$" S ABM("LTH")=$P(ABM("LTH"),"$") W $J($FN(+ABM("FLD"),",",2),ABM("LTH")) 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")) 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
;
XIT K ABM I '$D(ABMR("MORE")) K ABMF
Q
TEXT ;;TABS;;FIELD LENGTH/FORMAT ($-$ FORMAT,L-LNGTH REQ'D,C-CENTER,R-RIGHT)
1 ;;1^13^26^39^52^65;;1^1^1^1^1^1
4 ;;0^32^38^44^50;;29^2^2^2^27C
6 ;;0^37^42^50;;29^1^1^27C
7 ;;0;;29
9 ;;0^50;;29^27C
10 ;;7^32^37^42^47^55;;21^1^1^1^1^1
12 ;;0^50;;29^27
13 ;;0^37^42^50;;29^1^1^27
14 ;;0^58;;29^18
16 ;;0^37^42^55^61;;29^1^1^1^1
17 ;;0^55^68;;29^1^9C
19 ;;50;;27C
20 ;;4^39;;31^10
23 ;;0^30^50^72;;11^19C^17C^1
25 ;;0^17^34^53^68;;12^11^14^10^9
27 ;;0^54^69;;48^9^8
29 ;;0^53^55^63;;48^1^1^9$
31 ;;1^69^72;;48^1^1
33 ;;1;;48
34 ;;1^62;;48^15
36 ;;22;;3
37 ;;0^13^18^27^47^53^62^66^69;;12^3C^8C^20^6C^8$^3R^2R^9C
38 ;;0^13^18^27^47^53^62^66^69;;12R^3C^8C^20^6C^8$^3R^2R^9C
50 ;;0^49^62^71;;29^12$^8R^8C
51 ;;0^37^42;;29^1^1
52 ;;0^50;;29^27
53 ;;0^31^50;;29^18C^27
54 ;;3^50;;24^27
55 ;;50;;27
56 ;;0^31^53;;29C^18C^24C
ABMDF2X ; IHS/ASDST/DMJ - PRINT HCFA 1500 ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
+2 ;Original;TMD;
+3 ;
MARG ;Set left and top margins
+1 SET U="^"
SET (ABM("LM"),ABM("TM"),ABM("LN"))=0
+2 IF $DATA(^ABMDEXP(2,0))
SET ABM("TM")=$PIECE(^(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 ;
+6 ;Loop thru line number array
LOOP SET ABM("LN")=$ORDER(ABMF(ABM("LN")))
IF +ABM("LN")=0!(ABM("LN")>56)
GOTO XIT
+1 ;
+2 ;Check for invalid line numbers
+3 FOR ABM("I")=2,3,5,11,18,21,22,24,26,28,30,35,49
IF ABM("LN")=ABM("I")
QUIT
+4 IF $TEST
GOTO LOOP
+5 ;
+6 ;Set to correct format line
+7 SET ABM("FL")=$SELECT(ABM("LN")=8:9,ABM("LN")=15:7,ABM("LN")=32:31,ABM("LN")>37&(ABM("LN")<49)&(ABM("LN")#2=1):37,ABM("LN")>37&(ABM("LN")<49)&(ABM("LN")#2=0):38,1:ABM("LN"))
+8 ;
+9 ;Set tab & format variables
+10 SET ABM("TABS")=$PIECE($TEXT(@ABM("FL")),";;",2)
+11 SET ABM("FMAT")=$PIECE($TEXT(@ABM("FL")),";;",3)
+12 ;
+13 ;Skip to req'd line
+14 FOR
IF $Y-ABM("TM")>(ABM("LN")+3)
QUIT
WRITE !
Begin DoDot:1
+15 IF ($Y-ABM("TM")<1)!($Y-ABM("TM")>4)
QUIT
+16 IF $Y-ABM("TM")=4
WRITE "** Send PAYMENT to PROVIDER in Block 31 **"
+17 IF '$DATA(ABMP("INS"))
QUIT
KILL ABM("INS")
+18 IF ($Y-ABM("TM"))=1
Begin DoDot:2
+19 SET ABM("J")=ABMP("BDFN")
SET ABM("I")=$PIECE(^AUTNINS(ABMP("INS"),0),U)_"-"_ABMP("INS")
+20 SET ABM("INS",ABM("I"),ABM("J"))=$SELECT(ABM("I")["NON-BENEFICIARY PATIENT":$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),0),"^",5),1:"")
+21 SET ABM("IDFN")=ABMP("INS")
DO BADDR^ABMDLBL1
+22 WRITE "To:"
End DoDot:2
+23 IF '$DATA(ABM("ADD"))
QUIT
+24 WRITE ?4,$PIECE(ABM("ADD"),U,($Y-ABM("TM")))
End DoDot:1
+25 ;
+26 ; Test Modes for setting Data Fields
+27 IF '$DATA(ABMF("TEST"))
GOTO LOOP2
+28 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
+29 GOTO LOOP
+30 ;
+31 ;Loop thru the pieces of the line array
LOOP2 FOR ABM("I")=1:1:$LENGTH(ABMF(ABM("LN")),U)
IF $PIECE(ABM("TABS"),U,ABM("I"))]""
SET ABM("FLD")=$PIECE(ABMF(ABM("LN")),U,ABM("I"))
IF ABM("FLD")]""
WRITE ?($PIECE(ABM("TABS"),U,ABM("I"))+ABM("LM"))
DO FRMT
+1 GOTO LOOP
+2 ;
+3 ;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 IF ABM("LTH")["$"
SET ABM("LTH")=$PIECE(ABM("LTH"),"$")
WRITE $JUSTIFY($FNUMBER(+ABM("FLD"),",",2),ABM("LTH"))
QUIT
+2 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")
+3 IF ABM("LTH")["C"
SET ABM("LTH")=$PIECE(ABM("LTH"),"C")
SET ABM("FLD")=$JUSTIFY("",ABM("LTH")-$LENGTH(ABM("FLD"))\2)_ABM("FLD")
+4 IF ABM("LTH")["R"
SET ABM("LTH")=$PIECE(ABM("LTH"),"R")
SET ABM("RT")=ABM("LTH")-$LENGTH(ABM("FLD"))
IF ABM("RT")>1
SET ABM("BLNK")=""
SET $PIECE(ABM("BLNK")," ",ABM("RT"))=""
SET ABM("FLD")=ABM("BLNK")_ABM("FLD")
+5 WRITE $EXTRACT(ABM("FLD"),1,ABM("LTH"))
+6 QUIT
+7 ;
TEST SET ABMF("TEST")=1
+1 FOR ABM=0:ABMF("TEST"):60
SET ABMF(ABM)=""
+2 GOTO MARG
+3 ;
XIT KILL ABM
IF '$DATA(ABMR("MORE"))
KILL ABMF
+1 QUIT
TEXT ;;TABS;;FIELD LENGTH/FORMAT ($-$ FORMAT,L-LNGTH REQ'D,C-CENTER,R-RIGHT)
1 ;;1^13^26^39^52^65;;1^1^1^1^1^1
4 ;;0^32^38^44^50;;29^2^2^2^27C
6 ;;0^37^42^50;;29^1^1^27C
7 ;;0;;29
9 ;;0^50;;29^27C
10 ;;7^32^37^42^47^55;;21^1^1^1^1^1
12 ;;0^50;;29^27
13 ;;0^37^42^50;;29^1^1^27
14 ;;0^58;;29^18
16 ;;0^37^42^55^61;;29^1^1^1^1
17 ;;0^55^68;;29^1^9C
19 ;;50;;27C
20 ;;4^39;;31^10
23 ;;0^30^50^72;;11^19C^17C^1
25 ;;0^17^34^53^68;;12^11^14^10^9
27 ;;0^54^69;;48^9^8
29 ;;0^53^55^63;;48^1^1^9$
31 ;;1^69^72;;48^1^1
33 ;;1;;48
34 ;;1^62;;48^15
36 ;;22;;3
37 ;;0^13^18^27^47^53^62^66^69;;12^3C^8C^20^6C^8$^3R^2R^9C
38 ;;0^13^18^27^47^53^62^66^69;;12R^3C^8C^20^6C^8$^3R^2R^9C
50 ;;0^49^62^71;;29^12$^8R^8C
51 ;;0^37^42;;29^1^1
52 ;;0^50;;29^27
53 ;;0^31^50;;29^18C^27
54 ;;3^50;;24^27
55 ;;50;;27
56 ;;0^31^53;;29C^18C^24C
