ABMDF35 ; IHS/SD/SDR - Set HCFA-1500 (02/12) Print Array ;
;;2.6;IHS 3P BILLING SYSTEM;**13**;NOV 12, 2009;Build 213
;
K ABMP,ABMF
S ABMP("EXP")=35
D TXST^ABMDFUTL
;
BDFN ;
S ABMY("N")=0
F S ABMY("N")=$O(ABMY(ABMY("N"))) Q:'ABMY("N") D
.S ABMP("BDFN")=""
.F S ABMP("BDFN")=$O(ABMY(ABMY("N"),ABMP("BDFN"))) Q:'ABMP("BDFN") D
..Q:'$D(^ABMDBILL(DUZ(2),ABMP("BDFN"),0))
..D ENT
..S DIE="^ABMDBILL(DUZ(2),"
..S DA=ABMP("BDFN")
..S 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")),^ABMDBILL(DUZ(2),"AC","A",ABMP("BDFN"))
D TXUPDT^ABMDFUTL
;
XIT ;
K ABM,ABMV,ABMF,ABMS,ABMR
Q
;
HCFA ;
D EMG^ABMDF35E ;sets EMG flag
F ABMS("I")=36:1:47 K ABMF(ABMS("I"))
F ABMS("I")=37:2:47 D Q:$G(ABM("QUIT"))
.I $D(ABMR) D
..S ABMS=0
..F S ABMS=$O(ABMS(ABMS)) Q:+ABMS=0 D
...S ABMLN=2
...D PROC^ABMDF35E
...S ABMLN=ABMLN+1
..S ABMLN=0,ABMPRT=0
.F ABMS("I")=37:2:47 D Q:$G(ABM("QUIT"))
..S ABMLN=$O(ABMR(ABMLN))
..I 'ABMLN S ABM("QUIT")=1 Q
..S ABMPRT=0
..I (($O(ABMR(ABMLN,9),-1))+(ABMS("I")))>49 Q
..S ABMLCNT=0
..F S ABMPRT=$O(ABMR(ABMLN,ABMPRT)) Q:+ABMPRT=0 D
...M ABMF($S(ABMPRT=1:(ABMS("I")-1),1:ABMS("I")))=ABMR(ABMLN,ABMPRT)
...S ABMLCNT=ABMLCNT+1
...K ABMR(ABMLN,ABMPRT)
..K ABMR(ABMLN)
I ABMS("I")=47,(+$O(ABMR(0))'=0) D ^ABMDF35X G HCFA
S $P(ABMF(49),U,7)=$P(ABMR("TOT"),U)
S $P(ABMF(49),U,8)=$P(ABMR("TOT"),U,2)
I +$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),7)),U,23)'=0 S $P(ABMF(49),U,8)=+$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),7)),U,23) ;abm*2.6*13 patient paid amount
I
K ABMR("MORE")
D ^ABMDF35X
Q
;
ENT ;EP for setting up export array
K ABMP("INS"),ABMP("CDFN")
S ABMPGCNT=1,ABMPCNT=1 ;page counter
D ^ABMDF35A,^ABMDF35B,^ABMDF35C,^ABMDF35D
;
;total number of pages (used for claim header)
S ABMPCNT=6
S ABMRPG=0
F S ABMRPG=$O(ABMR(ABMRPG)) Q:+ABMRPG=0 S ABMPCNT=+$G(ABMPCNT)+1
S ABMPGTOT=(ABMPCNT/6)
I $P(ABMPGTOT,".",2)>0 S ABMPGTOT=(ABMPGTOT\1)+1
;
I +$O(ABMR("")) S ABMR("MORE")="",ABMP("MORE")=""
;payment so flag to write (cont.)
K ABMTEST,ABMTEST1
S ABMTEST=$P($G(ABMP("B0")),U)
S ABMTEST1=$O(^ABMDBILL(DUZ(2),"B",ABMTEST),-1)
I ($E(ABMTEST,1,$L(ABMTEST)-1))=($E(ABMTEST1,1,$L(ABMTEST1)-1)) D
.I $D(^ABMDBILL(DUZ(2),$O(^ABMDBILL(DUZ(2),"B",ABMTEST1,"")),3,0)) S ABMP("PTOT")=1
I $P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,18)="C" S ABMP("PTOT")=1
K ABM("LTOT")
I $$MPP^ABMUTLP(ABMP("BDFN")) D
.S $P(ABMF(11),"^",2)="NONE"
.S $P(ABMF(13),"^",4,6)=""
.;S $P(ABMF(15),"^",7)="" ;abm*2.6*13 remove box 9B
.S $P(ABMF(15),"^",4)="" ;abm*2.6*13 remove box 9B
.;S $P(ABMF(17),"^",4)="" ;abm*2.6*13 remove box 9C
.S $P(ABMF(17),"^",3)="" ;abm*2.6*13 remove box 9C
D ^ABMDF35X
I +$O(ABMR("")) S ABMS=0 D HCFA
Q
;
ABMU ; EP
; Long Description
N I,J
S I=0
F J=1,2 S I=$O(ABMU(I)) Q:'+I D
.S:J=1 ABMF(ABMS("I")-1)=ABMU(I)
.S:J=2 $P(ABMF(ABMS("I")),"^",5)=ABMU(I)
.K ABMU(I)
S I=$O(ABMU(I)) I '+I K ABMU
Q
ABMDF35 ; IHS/SD/SDR - Set HCFA-1500 (02/12) Print Array ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;**13**;NOV 12, 2009;Build 213
+2 ;
+3 KILL ABMP,ABMF
+4 SET ABMP("EXP")=35
+5 DO TXST^ABMDFUTL
+6 ;
BDFN ;
+1 SET ABMY("N")=0
+2 FOR
SET ABMY("N")=$ORDER(ABMY(ABMY("N")))
IF 'ABMY("N")
QUIT
Begin DoDot:1
+3 SET ABMP("BDFN")=""
+4 FOR
SET ABMP("BDFN")=$ORDER(ABMY(ABMY("N"),ABMP("BDFN")))
IF 'ABMP("BDFN")
QUIT
Begin DoDot:2
+5 IF '$DATA(^ABMDBILL(DUZ(2),ABMP("BDFN"),0))
QUIT
+6 DO ENT
+7 SET DIE="^ABMDBILL(DUZ(2),"
+8 SET DA=ABMP("BDFN")
+9 SET DR=".04////B;.16////A;.17////"_ABMP("XMIT")
+10 DO ^ABMDDIE
+11 IF $DATA(ABM("DIE-FAIL"))
QUIT
+12 KILL ^ABMDBILL(DUZ(2),"AS",+^ABMDBILL(DUZ(2),ABMP("BDFN"),0),"A",ABMP("BDFN")),^ABMDBILL(DUZ(2),"AC","A",ABMP("BDFN"))
End DoDot:2
End DoDot:1
+13 DO TXUPDT^ABMDFUTL
+14 ;
XIT ;
+1 KILL ABM,ABMV,ABMF,ABMS,ABMR
+2 QUIT
+3 ;
HCFA ;
+1 ;sets EMG flag
DO EMG^ABMDF35E
+2 FOR ABMS("I")=36:1:47
KILL ABMF(ABMS("I"))
+3 FOR ABMS("I")=37:2:47
Begin DoDot:1
+4 IF $DATA(ABMR)
Begin DoDot:2
+5 SET ABMS=0
+6 FOR
SET ABMS=$ORDER(ABMS(ABMS))
IF +ABMS=0
QUIT
Begin DoDot:3
+7 SET ABMLN=2
+8 DO PROC^ABMDF35E
+9 SET ABMLN=ABMLN+1
End DoDot:3
+10 SET ABMLN=0
SET ABMPRT=0
End DoDot:2
+11 FOR ABMS("I")=37:2:47
Begin DoDot:2
+12 SET ABMLN=$ORDER(ABMR(ABMLN))
+13 IF 'ABMLN
SET ABM("QUIT")=1
QUIT
+14 SET ABMPRT=0
+15 IF (($ORDER(ABMR(ABMLN,9),-1))+(ABMS("I")))>49
QUIT
+16 SET ABMLCNT=0
+17 FOR
SET ABMPRT=$ORDER(ABMR(ABMLN,ABMPRT))
IF +ABMPRT=0
QUIT
Begin DoDot:3
+18 MERGE ABMF($SELECT(ABMPRT=1:(ABMS("I")-1),1:ABMS("I")))=ABMR(ABMLN,ABMPRT)
+19 SET ABMLCNT=ABMLCNT+1
+20 KILL ABMR(ABMLN,ABMPRT)
End DoDot:3
+21 KILL ABMR(ABMLN)
End DoDot:2
IF $GET(ABM("QUIT"))
QUIT
End DoDot:1
IF $GET(ABM("QUIT"))
QUIT
+22 IF ABMS("I")=47
IF (+$ORDER(ABMR(0))'=0)
DO ^ABMDF35X
GOTO HCFA
+23 SET $PIECE(ABMF(49),U,7)=$PIECE(ABMR("TOT"),U)
+24 SET $PIECE(ABMF(49),U,8)=$PIECE(ABMR("TOT"),U,2)
+25 ;abm*2.6*13 patient paid amount
IF +$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),7)),U,23)'=0
SET $PIECE(ABMF(49),U,8)=+$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),7)),U,23)
+26 IF $TEST
+27 KILL ABMR("MORE")
+28 DO ^ABMDF35X
+29 QUIT
+30 ;
ENT ;EP for setting up export array
+1 KILL ABMP("INS"),ABMP("CDFN")
+2 ;page counter
SET ABMPGCNT=1
SET ABMPCNT=1
+3 DO ^ABMDF35A
DO ^ABMDF35B
DO ^ABMDF35C
DO ^ABMDF35D
+4 ;
+5 ;total number of pages (used for claim header)
+6 SET ABMPCNT=6
+7 SET ABMRPG=0
+8 FOR
SET ABMRPG=$ORDER(ABMR(ABMRPG))
IF +ABMRPG=0
QUIT
SET ABMPCNT=+$GET(ABMPCNT)+1
+9 SET ABMPGTOT=(ABMPCNT/6)
+10 IF $PIECE(ABMPGTOT,".",2)>0
SET ABMPGTOT=(ABMPGTOT\1)+1
+11 ;
+12 IF +$ORDER(ABMR(""))
SET ABMR("MORE")=""
SET ABMP("MORE")=""
+13 ;payment so flag to write (cont.)
+14 KILL ABMTEST,ABMTEST1
+15 SET ABMTEST=$PIECE($GET(ABMP("B0")),U)
+16 SET ABMTEST1=$ORDER(^ABMDBILL(DUZ(2),"B",ABMTEST),-1)
+17 IF ($EXTRACT(ABMTEST,1,$LENGTH(ABMTEST)-1))=($EXTRACT(ABMTEST1,1,$LENGTH(ABMTEST1)-1))
Begin DoDot:1
+18 IF $DATA(^ABMDBILL(DUZ(2),$ORDER(^ABMDBILL(DUZ(2),"B",ABMTEST1,"")),3,0))
SET ABMP("PTOT")=1
End DoDot:1
+19 IF $PIECE($GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,18)="C"
SET ABMP("PTOT")=1
+20 KILL ABM("LTOT")
+21 IF $$MPP^ABMUTLP(ABMP("BDFN"))
Begin DoDot:1
+22 SET $PIECE(ABMF(11),"^",2)="NONE"
+23 SET $PIECE(ABMF(13),"^",4,6)=""
+24 ;S $P(ABMF(15),"^",7)="" ;abm*2.6*13 remove box 9B
+25 ;abm*2.6*13 remove box 9B
SET $PIECE(ABMF(15),"^",4)=""
+26 ;S $P(ABMF(17),"^",4)="" ;abm*2.6*13 remove box 9C
+27 ;abm*2.6*13 remove box 9C
SET $PIECE(ABMF(17),"^",3)=""
End DoDot:1
+28 DO ^ABMDF35X
+29 IF +$ORDER(ABMR(""))
SET ABMS=0
DO HCFA
+30 QUIT
+31 ;
ABMU ; EP
+1 ; Long Description
+2 NEW I,J
+3 SET I=0
+4 FOR J=1,2
SET I=$ORDER(ABMU(I))
IF '+I
QUIT
Begin DoDot:1
+5 IF J=1
SET ABMF(ABMS("I")-1)=ABMU(I)
+6 IF J=2
SET $PIECE(ABMF(ABMS("I")),"^",5)=ABMU(I)
+7 KILL ABMU(I)
End DoDot:1
+8 SET I=$ORDER(ABMU(I))
IF '+I
KILL ABMU
+9 QUIT
