ABMDF14 ; IHS/ASDST/DMJ - Set HCFA-1500 Y2K Print Array ;
;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
;Original;TMD;
;
; IHS/DSD/LSL 03/21/98 - Modified logic in
; tab ABMU to kill ABMU array if no more
; numeric subscipts. solve problem of
; HCFA print same page w/no procedures
; continuous (Nois: HQW-0398-100121)
;
; IHS/SD/SDR - v2.5 p9 - IM16876
; (cont) removed from block 28/30 if payment
;
; IHS/SD/SDR - v2.5 p10 - IM20197
; Fix 2-line items so they won't split onto two pages
; (it was printing one line on one page and second line
; on second page)
;
; IHS/SD/SDR - v2.5 p12 - IM24880
; Made changes for number of line items printing per page
;
K ABMP,ABMF
S ABMP("EXP")=14
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^ABMDF14E
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^ABMDF14E
...S ABMLN=ABMLN+1
..S ABMLN=0,ABMPRT=0
.F ABMS("I")=37:1: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
...I +$O(ABMR(ABMLN,ABMPRT))'=0,($G(ABMF(ABMS("I")-1))=""),(ABMS("I")#2=1),ABMS("I")=37 S ABMS("I")=ABMS("I")-1
...M ABMF(ABMS("I"))=ABMR(ABMLN,ABMPRT)
...S ABMLCNT=ABMLCNT+1
...S ABMS("I")=ABMS("I")+1
...K ABMR(ABMLN,ABMPRT)
..K ABMR(ABMLN)
I ABMS("I")>47,(+$O(ABMR(0))'=0) D ^ABMDF14X G HCFA
S $P(ABMF(49),U,7)=$P(ABMR("TOT"),U)
S $P(ABMF(49),U,8)=$P(ABMR("TOT"),U,2)
S $P(ABMF(49),U,9)=$P(ABMR("TOT"),U,3)
K ABMR("MORE")
D ^ABMDF14X
Q
;
ENT ;EP for setting up export array
K ABMP("INS"),ABMP("CDFN")
D ^ABMDF14A,^ABMDF14B,^ABMDF14C,^ABMDF14D
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
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)=""
.S $P(ABMF(17),"^",4)=""
D ^ABMDF14X
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
ABMDF14 ; IHS/ASDST/DMJ - Set HCFA-1500 Y2K Print Array ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
+2 ;Original;TMD;
+3 ;
+4 ; IHS/DSD/LSL 03/21/98 - Modified logic in
+5 ; tab ABMU to kill ABMU array if no more
+6 ; numeric subscipts. solve problem of
+7 ; HCFA print same page w/no procedures
+8 ; continuous (Nois: HQW-0398-100121)
+9 ;
+10 ; IHS/SD/SDR - v2.5 p9 - IM16876
+11 ; (cont) removed from block 28/30 if payment
+12 ;
+13 ; IHS/SD/SDR - v2.5 p10 - IM20197
+14 ; Fix 2-line items so they won't split onto two pages
+15 ; (it was printing one line on one page and second line
+16 ; on second page)
+17 ;
+18 ; IHS/SD/SDR - v2.5 p12 - IM24880
+19 ; Made changes for number of line items printing per page
+20 ;
+21 KILL ABMP,ABMF
+22 SET ABMP("EXP")=14
+23 DO TXST^ABMDFUTL
+24 ;
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 DO EMG^ABMDF14E
+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^ABMDF14E
+9 SET ABMLN=ABMLN+1
End DoDot:3
+10 SET ABMLN=0
SET ABMPRT=0
End DoDot:2
+11 FOR ABMS("I")=37:1: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 IF +$ORDER(ABMR(ABMLN,ABMPRT))'=0
IF ($GET(ABMF(ABMS("I")-1))="")
IF (ABMS("I")#2=1)
IF ABMS("I")=37
SET ABMS("I")=ABMS("I")-1
+19 MERGE ABMF(ABMS("I"))=ABMR(ABMLN,ABMPRT)
+20 SET ABMLCNT=ABMLCNT+1
+21 SET ABMS("I")=ABMS("I")+1
+22 KILL ABMR(ABMLN,ABMPRT)
End DoDot:3
+23 KILL ABMR(ABMLN)
End DoDot:2
IF $GET(ABM("QUIT"))
QUIT
End DoDot:1
IF $GET(ABM("QUIT"))
QUIT
+24 IF ABMS("I")>47
IF (+$ORDER(ABMR(0))'=0)
DO ^ABMDF14X
GOTO HCFA
+25 SET $PIECE(ABMF(49),U,7)=$PIECE(ABMR("TOT"),U)
+26 SET $PIECE(ABMF(49),U,8)=$PIECE(ABMR("TOT"),U,2)
+27 SET $PIECE(ABMF(49),U,9)=$PIECE(ABMR("TOT"),U,3)
+28 KILL ABMR("MORE")
+29 DO ^ABMDF14X
+30 QUIT
+31 ;
ENT ;EP for setting up export array
+1 KILL ABMP("INS"),ABMP("CDFN")
+2 DO ^ABMDF14A
DO ^ABMDF14B
DO ^ABMDF14C
DO ^ABMDF14D
+3 IF +$ORDER(ABMR(""))
SET ABMR("MORE")=""
SET ABMP("MORE")=""
+4 ;payment so flag to write (cont.)
+5 KILL ABMTEST,ABMTEST1
+6 SET ABMTEST=$PIECE($GET(ABMP("B0")),U)
+7 SET ABMTEST1=$ORDER(^ABMDBILL(DUZ(2),"B",ABMTEST),-1)
+8 IF ($EXTRACT(ABMTEST,1,$LENGTH(ABMTEST)-1))=($EXTRACT(ABMTEST1,1,$LENGTH(ABMTEST1)-1))
Begin DoDot:1
+9 IF $DATA(^ABMDBILL(DUZ(2),$ORDER(^ABMDBILL(DUZ(2),"B",ABMTEST1,"")),3,0))
SET ABMP("PTOT")=1
End DoDot:1
+10 KILL ABM("LTOT")
+11 IF $$MPP^ABMUTLP(ABMP("BDFN"))
Begin DoDot:1
+12 SET $PIECE(ABMF(11),"^",2)="NONE"
+13 SET $PIECE(ABMF(13),"^",4,6)=""
+14 SET $PIECE(ABMF(15),"^",7)=""
+15 SET $PIECE(ABMF(17),"^",4)=""
End DoDot:1
+16 DO ^ABMDF14X
+17 IF +$ORDER(ABMR(""))
SET ABMS=0
DO HCFA
+18 QUIT
+19 ;
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
