ABMDF1 ; IHS/ASDST/DMJ - Set UB82 Print Array ;
;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
;Original;TMD;
;
K ABMP S U="^",ABMP("XMIT")=0,ABMP("EXP")=1,ABMY("TOT")="0^0^0"
BDFN S ABMY("N")=0 F S ABMY("N")=$O(ABMY(ABMY("N"))) Q:'ABMY("N") D
.S ABMP("BDFN")=0 F S ABMP("BDFN")=$O(ABMY(ABMY("N"),ABMP("BDFN"))) Q:'ABMP("BDFN") D
..Q:'$D(^ABMDBILL(DUZ(2),ABMP("BDFN"),0))
..D ENT,^ABMDF1X
..S $P(ABMY("TOT"),U)=$P(ABMY("TOT"),U)+1
..D:$D(ABMR)=10 UB82
XMIT ..I ABMP("XMIT")=0 S ABM("XM")="" F S ABM("XM")=$O(^ABMDTXST(DUZ(2),"B",DT,ABM("XM"))) Q:'ABM("XM") D Q:ABMP("XMIT")
...Q:'$D(^ABMDTXST(DUZ(2),ABM("XM"),0)) Q:$P(^(0),U,2)'=ABMP("EXP")
...I $D(ABMY("TYP")),$P(^ABMDTXST(DUZ(2),ABM("XM"),0),U,3)=ABMY("TYP") S ABMP("XMIT")=ABM("XM")
...I $D(ABMY("INS")),$P(^ABMDTXST(DUZ(2),ABM("XM"),0),U,4)=ABMY("INS") S ABMP("XMIT")=ABM("XM")
..I '+ABMP("XMIT") S DIC="^ABMDTXST(DUZ(2),",DIC(0)="L",X=DT,DIC("DR")=".02////1;.07////1;.08////1;"_$S($D(ABMY("TYP")):".03////"_ABMY("TYP"),$D(ABMY("INS")):".04////"_$P(ABMY("INS"),U),1:".03////A")_";.05////"_DUZ
..I K DD,DO D FILE^DICN S ABMP("XMIT")=+Y
..S DIE="^ABMDBILL(DUZ(2),",DA=ABMP("BDFN"),DR=".04////B;.16////A;.17////"_ABMP("XMIT") D ^ABMDDIE Q:$D(ABM("DIE-FAIL"))
..K ^ABMDBILL(DUZ(2),"AS",+^ABMDBILL(DUZ(2),ABMP("BDFN"),0),"A",ABMP("BDFN"))
..S ABM=ABMP("BDFN"),ABM("L")=ABMP("XMIT") K ABMP S ABMP("XMIT")=ABM("L"),ABMP("BDFN")=ABM
G XIT
;
UB82 ;EP for printing export array
S ABMR="" F ABMR("I")=17:1:39 S ABMR=$O(ABMR(ABMR)) Q:'ABMR D
.S ABMF(ABMR("I"))=ABMR(ABMR)
.K ABMR(ABMR)
.Q
I ABMR("I")=39,+ABMR D ^ABMDF1X G UB82
F ABMR("I")=ABMR("I"):1:48 K ABMF(ABMR("I"))
I ABMR("I")<39 S ABMF(ABMR("I")+1)=ABMR("TOT")
E S ABMF(39)=ABMR("TOT")
D ^ABMDF1X
Q
;
ENT ;EP for setting up export array
K ABMF,ABM,ABMU,ABMR,ABMS
S:'$D(ABMY("TOT")) ABMY("TOT")="0^0^0"
S ABMP("B0")=^ABMDBILL(DUZ(2),ABMP("BDFN"),0),ABMP("INS")=$P(ABMP("B0"),U,8) Q:'ABMP("INS")
S ABMP("PDFN")=$P(ABMP("B0"),U,5),ABMP("LDFN")=$P(ABMP("B0"),U,3),ABMP("VTYP")=$P(ABMP("B0"),U,7) Q:'ABMP("PDFN")!('+ABMP("LDFN"))
S ABMP("VDT")=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),7),U)
S (ABMV("X1"),ABMV("X2"),ABMV("X3"))=""
D PAT^ABMDE1X,REMPL^ABMDE1X1,LOC^ABMDE1X1 K ABME
;
LOC S ABMF(1)=$P($P(ABMV("X1"),U),";",2)
I $P(ABMV("X1"),U,2)]"" S ABMF(2)=$P(ABMV("X1"),U,2),ABMF(3)=$P(ABMV("X1"),U,3),ABMF(4)=$P(ABMV("X1"),U,4)
E S ABMF(2)=$P(ABMV("X1"),U,3),ABMF(3)=$P(ABMV("X1"),U,4),ABMF(4)=$P(ABMV("X1"),U,5)
BNUM S $P(ABMF(2),U,3)=$P(ABMP("B0"),U,1)_$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(2),U,3)=$P(ABMF(2),U,3)_" "_$P(^(0),U,2)
BTYPE S $P(ABMF(2),U,4)=$S($P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,11):$P($G(^ABMDCODE($P(^(0),U,11),0)),U),1:$P(ABMP("B0"),U,2))
INSNUM S ABM("INUM")=$P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,8)
S:ABM("INUM")="" ABM("INUM")=$P($G(^AUTNINS(ABMP("INS"),15,ABMP("LDFN"),0)),U,2)
S $P(ABMF(4),U,$S($P($G(^AUTNINS(ABMP("INS"),2)),U)="D":5,1:2))=ABM("INUM")
TAX S $P(ABMF(4),U,3)=$P(ABMV("X1"),U,6)
;
; Line 6
PNODES S ABM("P0")=^DPT(ABMP("PDFN"),0)
SSN I $P(ABM("P0"),U,9)]"" S $P(ABMF(12),U,12)=$S($P(ABM("P0"),U,9)'["-":$E($P(ABM("P0"),U,9),1,3)_"-"_$E($P(ABM("P0"),U,9),4,5)_"-"_$E($P(ABM("P0"),U,9),6,9),1:$P(ABM("P0"),U,9))
NAME S ABMF(6)=$P(ABM("P0"),U)
ADDRESS S $P(ABMF(6),U,2)=$P(ABMV("X2"),U,3)_" "_$P(ABMV("X2"),U,4)
;
; Line 8
DOB S ABMF(8)=$P(ABMV("X2"),U,6)
SEX S $P(ABMF(8),U,2)=$P(ABMV("X2"),U,2)
MS S $P(ABMF(8),U,3)=$P(ABMV("X2"),U,7)
K ABM("P0")
;
G ^ABMDF1A
;
XIT K ABM,ABMV,ABMF
Q
ABMDF1 ; IHS/ASDST/DMJ - Set UB82 Print Array ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
+2 ;Original;TMD;
+3 ;
+4 KILL ABMP
SET U="^"
SET ABMP("XMIT")=0
SET ABMP("EXP")=1
SET ABMY("TOT")="0^0^0"
BDFN SET ABMY("N")=0
FOR
SET ABMY("N")=$ORDER(ABMY(ABMY("N")))
IF 'ABMY("N")
QUIT
Begin DoDot:1
+1 SET ABMP("BDFN")=0
FOR
SET ABMP("BDFN")=$ORDER(ABMY(ABMY("N"),ABMP("BDFN")))
IF 'ABMP("BDFN")
QUIT
Begin DoDot:2
+2 IF '$DATA(^ABMDBILL(DUZ(2),ABMP("BDFN"),0))
QUIT
+3 DO ENT
DO ^ABMDF1X
+4 SET $PIECE(ABMY("TOT"),U)=$PIECE(ABMY("TOT"),U)+1
+5 IF $DATA(ABMR)=10
DO UB82
XMIT IF ABMP("XMIT")=0
SET ABM("XM")=""
FOR
SET ABM("XM")=$ORDER(^ABMDTXST(DUZ(2),"B",DT,ABM("XM")))
IF 'ABM("XM")
QUIT
Begin DoDot:3
+1 IF '$DATA(^ABMDTXST(DUZ(2),ABM("XM"),0))
QUIT
IF $PIECE(^(0),U,2)'=ABMP("EXP")
QUIT
+2 IF $DATA(ABMY("TYP"))
IF $PIECE(^ABMDTXST(DUZ(2),ABM("XM"),0),U,3)=ABMY("TYP")
SET ABMP("XMIT")=ABM("XM")
+3 IF $DATA(ABMY("INS"))
IF $PIECE(^ABMDTXST(DUZ(2),ABM("XM"),0),U,4)=ABMY("INS")
SET ABMP("XMIT")=ABM("XM")
End DoDot:3
IF ABMP("XMIT")
QUIT
+4 IF '+ABMP("XMIT")
SET DIC="^ABMDTXST(DUZ(2),"
SET DIC(0)="L"
SET X=DT
SET DIC("DR")=".02////1;.07////1;.08////1;"_$SELECT($DATA(ABMY("TYP")):".03////"_ABMY("TYP"),$DATA(ABMY("INS")):".04////"_$PIECE(ABMY("INS"),U),1:".03////A")_";.05////"_DUZ
+5 IF $TEST
KILL DD,DO
DO FILE^DICN
SET ABMP("XMIT")=+Y
+6 SET DIE="^ABMDBILL(DUZ(2),"
SET DA=ABMP("BDFN")
SET DR=".04////B;.16////A;.17////"_ABMP("XMIT")
DO ^ABMDDIE
IF $DATA(ABM("DIE-FAIL"))
QUIT
+7 KILL ^ABMDBILL(DUZ(2),"AS",+^ABMDBILL(DUZ(2),ABMP("BDFN"),0),"A",ABMP("BDFN"))
+8 SET ABM=ABMP("BDFN")
SET ABM("L")=ABMP("XMIT")
KILL ABMP
SET ABMP("XMIT")=ABM("L")
SET ABMP("BDFN")=ABM
End DoDot:2
End DoDot:1
+9 GOTO XIT
+10 ;
UB82 ;EP for printing export array
+1 SET ABMR=""
FOR ABMR("I")=17:1:39
SET ABMR=$ORDER(ABMR(ABMR))
IF 'ABMR
QUIT
Begin DoDot:1
+2 SET ABMF(ABMR("I"))=ABMR(ABMR)
+3 KILL ABMR(ABMR)
+4 QUIT
End DoDot:1
+5 IF ABMR("I")=39
IF +ABMR
DO ^ABMDF1X
GOTO UB82
+6 FOR ABMR("I")=ABMR("I"):1:48
KILL ABMF(ABMR("I"))
+7 IF ABMR("I")<39
SET ABMF(ABMR("I")+1)=ABMR("TOT")
+8 IF '$TEST
SET ABMF(39)=ABMR("TOT")
+9 DO ^ABMDF1X
+10 QUIT
+11 ;
ENT ;EP for setting up export array
+1 KILL ABMF,ABM,ABMU,ABMR,ABMS
+2 IF '$DATA(ABMY("TOT"))
SET ABMY("TOT")="0^0^0"
+3 SET ABMP("B0")=^ABMDBILL(DUZ(2),ABMP("BDFN"),0)
SET ABMP("INS")=$PIECE(ABMP("B0"),U,8)
IF 'ABMP("INS")
QUIT
+4 SET ABMP("PDFN")=$PIECE(ABMP("B0"),U,5)
SET ABMP("LDFN")=$PIECE(ABMP("B0"),U,3)
SET ABMP("VTYP")=$PIECE(ABMP("B0"),U,7)
IF 'ABMP("PDFN")!('+ABMP("LDFN"))
QUIT
+5 SET ABMP("VDT")=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),7),U)
+6 SET (ABMV("X1"),ABMV("X2"),ABMV("X3"))=""
+7 DO PAT^ABMDE1X
DO REMPL^ABMDE1X1
DO LOC^ABMDE1X1
KILL ABME
+8 ;
LOC SET ABMF(1)=$PIECE($PIECE(ABMV("X1"),U),";",2)
+1 IF $PIECE(ABMV("X1"),U,2)]""
SET ABMF(2)=$PIECE(ABMV("X1"),U,2)
SET ABMF(3)=$PIECE(ABMV("X1"),U,3)
SET ABMF(4)=$PIECE(ABMV("X1"),U,4)
+2 IF '$TEST
SET ABMF(2)=$PIECE(ABMV("X1"),U,3)
SET ABMF(3)=$PIECE(ABMV("X1"),U,4)
SET ABMF(4)=$PIECE(ABMV("X1"),U,5)
BNUM SET $PIECE(ABMF(2),U,3)=$PIECE(ABMP("B0"),U,1)_$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(2),U,3)=$PIECE(ABMF(2),U,3)_" "_$PIECE(^(0),U,2)
BTYPE SET $PIECE(ABMF(2),U,4)=$SELECT($PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,11):$PIECE($GET(^ABMDCODE($PIECE(^(0),U,11),0)),U),1:$PIECE(ABMP("B0"),U,2))
INSNUM SET ABM("INUM")=$PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,8)
+1 IF ABM("INUM")=""
SET ABM("INUM")=$PIECE($GET(^AUTNINS(ABMP("INS"),15,ABMP("LDFN"),0)),U,2)
+2 SET $PIECE(ABMF(4),U,$SELECT($PIECE($GET(^AUTNINS(ABMP("INS"),2)),U)="D":5,1:2))=ABM("INUM")
TAX SET $PIECE(ABMF(4),U,3)=$PIECE(ABMV("X1"),U,6)
+1 ;
+2 ; Line 6
PNODES SET ABM("P0")=^DPT(ABMP("PDFN"),0)
SSN IF $PIECE(ABM("P0"),U,9)]""
SET $PIECE(ABMF(12),U,12)=$SELECT($PIECE(ABM("P0"),U,9)'["-":$EXTRACT($PIECE(ABM("P0"),U,9),1,3)_"-"_$EXTRACT($PIECE(ABM("P0"),U,9),4,5)_"-"_$EXTRACT($PIECE(ABM("P0"),U,9),6,9),1:$PIECE(ABM("P0"),U,9))
NAME SET ABMF(6)=$PIECE(ABM("P0"),U)
ADDRESS SET $PIECE(ABMF(6),U,2)=$PIECE(ABMV("X2"),U,3)_" "_$PIECE(ABMV("X2"),U,4)
+1 ;
+2 ; Line 8
DOB SET ABMF(8)=$PIECE(ABMV("X2"),U,6)
SEX SET $PIECE(ABMF(8),U,2)=$PIECE(ABMV("X2"),U,2)
MS SET $PIECE(ABMF(8),U,3)=$PIECE(ABMV("X2"),U,7)
+1 KILL ABM("P0")
+2 ;
+3 GOTO ^ABMDF1A
+4 ;
XIT KILL ABM,ABMV,ABMF
+1 QUIT
