ABMDF26X ; IHS/ASDST/DMJ - ADA-99 FORM V2000 ;
;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
;Original;TMD;09/12/95 8:49 AM
;
; IHS/SD/SDR - v2.5 p8 - IM12857
; Created new export mode for ADA-99 v2000 format
;
MARG ;Set left and top margins
S U="^",(ABM("LM"),ABM("TM"),ABM("LN"))=0
I $D(^ABMDEXP(26,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 ;
;Loop thru line number array
S ABM("LN")=$O(ABMF(ABM("LN"))) I +ABM("LN")=0!(ABM("LN")>62) G XIT
;
;Set to correct format line
S ABM("FL")=ABM("LN")
I ABM("LN")>40,ABM("LN")<50 S ABM("FL")=41 ;Lines 41 thru 49 are same
I ABM("LN")>53,ABM("LN")<57 S ABM("FL")=54 ;Lines 54 thru 56 are same
;
;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")+0) W !
;
; Test Modes for setting Data Fields
G LOOP2:'$D(ABMF("TEST"))
F ABM("I")=1:1:$L(ABM("FMAT"),U) D
.I $P(ABM("TABS"),U,ABM("I"))]"" D
..S ABM("FLD")=""
..S $P(ABM("FLD"),"X",$P(ABM("FMAT"),U,ABM("I"))+1)=""
..I ABM("FLD")]"" D
...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
.I $P(ABM("TABS"),U,ABM("I"))]"" D
..S ABM("FLD")=$P(ABMF(ABM("LN")),U,ABM("I"))
..I ABM("FLD")]"" D
...W ?($P(ABM("TABS"),U,ABM("I"))+ABM("LM"))
...D FRMT
G LOOP
;
FRMT ;
;Write the field in the designated format
S ABM("LTH")=$P(ABM("FMAT"),U,ABM("I"))
I +ABM("LTH")=0 S ABM("LTH")=99
I ABM("LTH")["$" D Q
.S ABM("LTH")=$P(ABM("LTH"),"$")
.W $J($FN(+ABM("FLD"),",",2),ABM("LTH"))
I ABM("LTH")["D" D Q
.S ABM("LTH")=$P(ABM("LTH"),"D")
.W $E(ABM("FLD"),4,5),"/",$E(ABM("FLD"),6,7),"/",($E(ABM("FLD"),1,3)+1700)
I ABM("LTH")["L" D
.S ABM("LTH")=$P(ABM("LTH"),"L")
.F Q:$L(ABM("FLD"))=ABM("LTH")!($L(ABM("FLD"))>ABM("LTH")) D
..S ABM("FLD")="0"_ABM("FLD")
I ABM("LTH")["C" D
.S ABM("LTH")=$P(ABM("LTH"),"C")
.S ABM("FLD")=$J("",ABM("LTH")-$L(ABM("FLD"))\2)_ABM("FLD")
I ABM("LTH")["R" D
.S ABM("LTH")=$P(ABM("LTH"),"R")
.S ABM("RT")=ABM("LTH")-$L(ABM("FLD"))+1
.I ABM("RT")>1 D
..S ABM("BLNK")=""
..S $P(ABM("BLNK")," ",ABM("RT"))=""
..S ABM("FLD")=ABM("BLNK")_ABM("FLD")
W $E(ABM("FLD"),1,ABM("LTH"))
Q
;
TEST ;
S ABMF("TEST")=1
F ABM=0:ABMF("TEST"):62 S ABMF(ABM)=""
G MARG
;
XIT ;
I '$D(ABM("MORE")) K ABMF,ABM
E K ABM("MORE")
Q
TEXT ;;TABS;;FIELD LENGTH
; FORMAT ($-$ FORMAT,L-LNGTH REQ'D,C-CENTER,R-RIGHT,D-DATE)
1 ;;1;;1
3 ;;1^29;;1^42
4 ;;1^29;;1^42
5 ;;1^14;;1^12
6 ;;29^65^68;;34^2^10
8 ;;2^31^53^75;;27^19^19^2
10 ;;4^8^12^17^36^39^44^66;;2^2^4^17C^1^1^12^10
12 ;;3^5^9^12^16^46^63;;1^1^1^1^23^12^15
14 ;;2^15^33^43^52^55^59^70;;12^17^7^1^1^1^1^10
16 ;;2^43;;37^37
17 ;;2^30^44^48^52^59^61^67;;26^12^2^2^4^1^1^12
19 ;;2^25^29^46^64;;21^2^10^14^15
21 ;;3^7^11^21^25^28^36^38^42^47^55^62;;2^2^4^1^1^1^1^1^1^1^1^1
23 ;;46^64;;14^15
25 ;;4^28^44^64;;23^10D^21^10D
28 ;;2^36^52^64;;29^12^10^15
30 ;;2^36^52^62^66^69^72;;33^12^10D^1^1^1^1
31 ;;70^73;;1^2^1^1^1
32 ;;2^23^27^36^43^47;;19^2^6^1^2^1
34 ;;10^12^23^41^59^75;;1^1^14^15^10D^4
35 ;;24^26^45^52^58;;1^1^1^1^1
36 ;;13^47;;22^32
41 ;;0^2^4^9^14^20^30^38^41^61^71;;2^2^4^4^5^8^6^2^19^6$^9
50 ;;62;;6$
51 ;;62;;6$
52 ;;62;;6$
54 ;;13^62;;37^6$
55 ;;1^62;;45^6$
58 ;;48;;30
60 ;;1^19^34^48^68^73;;16^12^10D^17^2^7
ABMDF26X ; IHS/ASDST/DMJ - ADA-99 FORM V2000 ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
+2 ;Original;TMD;09/12/95 8:49 AM
+3 ;
+4 ; IHS/SD/SDR - v2.5 p8 - IM12857
+5 ; Created new export mode for ADA-99 v2000 format
+6 ;
MARG ;Set left and top margins
+1 SET U="^"
SET (ABM("LM"),ABM("TM"),ABM("LN"))=0
+2 IF $DATA(^ABMDEXP(26,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 ;
LOOP ;
+1 ;Loop thru line number array
+2 SET ABM("LN")=$ORDER(ABMF(ABM("LN")))
IF +ABM("LN")=0!(ABM("LN")>62)
GOTO XIT
+3 ;
+4 ;Set to correct format line
+5 SET ABM("FL")=ABM("LN")
+6 ;Lines 41 thru 49 are same
IF ABM("LN")>40
IF ABM("LN")<50
SET ABM("FL")=41
+7 ;Lines 54 thru 56 are same
IF ABM("LN")>53
IF ABM("LN")<57
SET ABM("FL")=54
+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")+0)
QUIT
WRITE !
+15 ;
+16 ; Test Modes for setting Data Fields
+17 IF '$DATA(ABMF("TEST"))
GOTO LOOP2
+18 FOR ABM("I")=1:1:$LENGTH(ABM("FMAT"),U)
Begin DoDot:1
+19 IF $PIECE(ABM("TABS"),U,ABM("I"))]""
Begin DoDot:2
+20 SET ABM("FLD")=""
+21 SET $PIECE(ABM("FLD"),"X",$PIECE(ABM("FMAT"),U,ABM("I"))+1)=""
+22 IF ABM("FLD")]""
Begin DoDot:3
+23 WRITE ?($PIECE(ABM("TABS"),U,ABM("I"))+ABM("LM"))
+24 DO FRMT
End DoDot:3
End DoDot:2
End DoDot:1
+25 GOTO LOOP
+26 ;
LOOP2 ;
+1 ;Loop thru the pieces of the line array
+2 FOR ABM("I")=1:1:$LENGTH(ABMF(ABM("LN")),U)
Begin DoDot:1
+3 IF $PIECE(ABM("TABS"),U,ABM("I"))]""
Begin DoDot:2
+4 SET ABM("FLD")=$PIECE(ABMF(ABM("LN")),U,ABM("I"))
+5 IF ABM("FLD")]""
Begin DoDot:3
+6 WRITE ?($PIECE(ABM("TABS"),U,ABM("I"))+ABM("LM"))
+7 DO FRMT
End DoDot:3
End DoDot:2
End DoDot:1
+8 GOTO LOOP
+9 ;
FRMT ;
+1 ;Write the field in the designated format
+2 SET ABM("LTH")=$PIECE(ABM("FMAT"),U,ABM("I"))
+3 IF +ABM("LTH")=0
SET ABM("LTH")=99
+4 IF ABM("LTH")["$"
Begin DoDot:1
+5 SET ABM("LTH")=$PIECE(ABM("LTH"),"$")
+6 WRITE $JUSTIFY($FNUMBER(+ABM("FLD"),",",2),ABM("LTH"))
End DoDot:1
QUIT
+7 IF ABM("LTH")["D"
Begin DoDot:1
+8 SET ABM("LTH")=$PIECE(ABM("LTH"),"D")
+9 WRITE $EXTRACT(ABM("FLD"),4,5),"/",$EXTRACT(ABM("FLD"),6,7),"/",($EXTRACT(ABM("FLD"),1,3)+1700)
End DoDot:1
QUIT
+10 IF ABM("LTH")["L"
Begin DoDot:1
+11 SET ABM("LTH")=$PIECE(ABM("LTH"),"L")
+12 FOR
IF $LENGTH(ABM("FLD"))=ABM("LTH")!($LENGTH(ABM("FLD"))>ABM("LTH"))
QUIT
Begin DoDot:2
+13 SET ABM("FLD")="0"_ABM("FLD")
End DoDot:2
End DoDot:1
+14 IF ABM("LTH")["C"
Begin DoDot:1
+15 SET ABM("LTH")=$PIECE(ABM("LTH"),"C")
+16 SET ABM("FLD")=$JUSTIFY("",ABM("LTH")-$LENGTH(ABM("FLD"))\2)_ABM("FLD")
End DoDot:1
+17 IF ABM("LTH")["R"
Begin DoDot:1
+18 SET ABM("LTH")=$PIECE(ABM("LTH"),"R")
+19 SET ABM("RT")=ABM("LTH")-$LENGTH(ABM("FLD"))+1
+20 IF ABM("RT")>1
Begin DoDot:2
+21 SET ABM("BLNK")=""
+22 SET $PIECE(ABM("BLNK")," ",ABM("RT"))=""
+23 SET ABM("FLD")=ABM("BLNK")_ABM("FLD")
End DoDot:2
End DoDot:1
+24 WRITE $EXTRACT(ABM("FLD"),1,ABM("LTH"))
+25 QUIT
+26 ;
TEST ;
+1 SET ABMF("TEST")=1
+2 FOR ABM=0:ABMF("TEST"):62
SET ABMF(ABM)=""
+3 GOTO MARG
+4 ;
XIT ;
+1 IF '$DATA(ABM("MORE"))
KILL ABMF,ABM
+2 IF '$TEST
KILL ABM("MORE")
+3 QUIT
TEXT ;;TABS;;FIELD LENGTH
+1 ; FORMAT ($-$ FORMAT,L-LNGTH REQ'D,C-CENTER,R-RIGHT,D-DATE)
1 ;;1;;1
3 ;;1^29;;1^42
4 ;;1^29;;1^42
5 ;;1^14;;1^12
6 ;;29^65^68;;34^2^10
8 ;;2^31^53^75;;27^19^19^2
10 ;;4^8^12^17^36^39^44^66;;2^2^4^17C^1^1^12^10
12 ;;3^5^9^12^16^46^63;;1^1^1^1^23^12^15
14 ;;2^15^33^43^52^55^59^70;;12^17^7^1^1^1^1^10
16 ;;2^43;;37^37
17 ;;2^30^44^48^52^59^61^67;;26^12^2^2^4^1^1^12
19 ;;2^25^29^46^64;;21^2^10^14^15
21 ;;3^7^11^21^25^28^36^38^42^47^55^62;;2^2^4^1^1^1^1^1^1^1^1^1
23 ;;46^64;;14^15
25 ;;4^28^44^64;;23^10D^21^10D
28 ;;2^36^52^64;;29^12^10^15
30 ;;2^36^52^62^66^69^72;;33^12^10D^1^1^1^1
31 ;;70^73;;1^2^1^1^1
32 ;;2^23^27^36^43^47;;19^2^6^1^2^1
34 ;;10^12^23^41^59^75;;1^1^14^15^10D^4
35 ;;24^26^45^52^58;;1^1^1^1^1
36 ;;13^47;;22^32
41 ;;0^2^4^9^14^20^30^38^41^61^71;;2^2^4^4^5^8^6^2^19^6$^9
50 ;;62;;6$
51 ;;62;;6$
52 ;;62;;6$
54 ;;13^62;;37^6$
55 ;;1^62;;45^6$
58 ;;48;;30
60 ;;1^19^34^48^68^73;;16^12^10D^17^2^7
