ABMDF28S.m

ABMDF28S ; IHS/SD/SDR - PRINT UB-04 ;  

 ;;2.6;IHS 3P BILLING SYSTEM;**21,23,27**;NOV 12, 2009;Build 486

 ;new routine abm*2.6*21

 ;IHS/SD/SDR-2.6*21 HEAT240744 - Added routine to resort line items for dialysis billing for Medi-Cal.  All Z6004 CPTs should be reported as 1 line item

 ; with all dates, total units for all Z6004s, and a total $$.

 ;IHS/SD/SDR 2.6*23 HEAT247169 If there's an NDC on the line item add it to the description

 ;IHS/SD/SDR 2.6*23 HEAT347035 Make T1015 print on the top line for Medi-Cal

 ;IHS/SD/AML,SDR 2.6*27 CR8897 Change for Medi-Cal from-thru billing

 ;

COMPILE ;EP

 K I,J,K

 ;make sure Z6004 codes are in chronological order

 S I=0

 F  S I=$O(ABMRV(I)) Q:'I  D

 .S J=-1

 .F  S J=$O(ABMRV(I,J)) Q:J=""  D

 ..I J'="Z6004" Q  ;looking for Z6004 specifically

 ..S K=0

 ..F  S K=$O(ABMRV(I,J,K)) Q:'K  D

 ...S ABMRTMP($P(ABMRV(I,J,K),U,10),I,J,K)=$G(ABMRV(I,J,K))

 ...K ABMRV(I,J,K)

 ;

 S ABMSDT=0

 S L=1

 F  S ABMSDT=$O(ABMRTMP(ABMSDT)) Q:'ABMSDT  D

 .S I=0

 .F  S I=$O(ABMRTMP(ABMSDT,I)) Q:'I  D

 ..S J=-1

 ..F  S J=$O(ABMRTMP(ABMSDT,I,J)) Q:J=""  D

 ...S K=0

 ...F  S K=$O(ABMRTMP(ABMSDT,I,J,K)) Q:'K  D

 ....S ABMRV(I,J,L)=$G(ABMRTMP(ABMSDT,I,J,K))

 ....S L=L+1

 ;

 ;now merge Z6004 entries into 1

 S ABMN=1

 S ABMI=1

 S I=0

 F  S I=$O(ABMRV(I)) Q:'I  D

 .S J=-1

 .F  S J=$O(ABMRV(I,J)) Q:J=""  D

 ..I J'="Z6004" Q  ;looking for Z6004 specifically

 ..S K=0

 ..F  S K=$O(ABMRV(I,J,K)) Q:'K  D

 ...I ABMN=1 D

 ....S ABMSLN=K  ;keep track of 1st line with Z6004

 ....S ABMSDT=$P(ABMRV(I,J,K),U,10)  ;save date from 1st line

 ....S ABMSMNTH=$P($$SDT^ABMDUTL(ABMSDT),"/")

 ....S ABMN=2

 ...I ABMN'=1 D

 ....I $P(ABMRV(I,J,K),U,27)>ABMSDT S $P(ABMRV(I,J,ABMSLN),U,27)=$P(ABMRV(I,J,K),U,27)

 ....I +$P(ABMRV(I,J,ABMSLN),U,27)=0!($P(ABMRV(I,J,K),U,10)>$P(ABMRV(I,J,ABMSLN),U,27)) S $P(ABMRV(I,J,ABMSLN),U,27)=$P(ABMRV(I,J,K),U,10)  ;default to later start date if do SERVICE DATE TO

 ....S ABMSUNIT=+$G(ABMSUNIT)+$P(ABMRV(I,J,K),U,5)  ;accumulate units

 ....S ABMSCHG=+$G(ABMSCHG)+$P(ABMRV(I,J,K),U,6)  ;accumulate chgs

 ....S ABMSDT2=$P($$SDT^ABMDUTL($P(ABMRV(I,J,K),U,10)),"/",1,2)

 ....I (+$G(ABMRV(I,J,ABMSLN,1))'=0)&(ABMSMNTH=$P(ABMSDT2,"/")) S ABMSDT2=$P(ABMSDT2,"/",2)

 ....E  S ABMSMNTH=$P(ABMSDT2,"/")

 ....I $G(ABMRV(I,J,ABMSLN,1))'="" S ABMSDT2=","_ABMSDT2

 ....I ($L($G(ABMRV(I,J,ABMSLN,ABMI)))+$L(ABMSDT2))>21 S ABMRV(I,J,ABMSLN,ABMI)=ABMRV(I,J,ABMSLN,ABMI)_",",ABMI=ABMI+1,ABMSDT2=$P(ABMSDT2,",",2)

 ....S ABMRV(I,J,ABMSLN,ABMI)=$G(ABMRV(I,J,ABMSLN,ABMI))_ABMSDT2

 ...I ABMSLN'=K K ABMRV(I,J,K)

 ..S $P(ABMRV(I,J,ABMSLN),U,5)=ABMSUNIT

 ..S $P(ABMRV(I,J,ABMSLN),U,6)=ABMSCHG

 Q

 ;

Z6004PRT ;EP

 S ABMIJ=0

 F  S ABMIJ=$O(ABMRV(I,J,L,ABMIJ)) Q:'ABMIJ  D

 .S ABMCTR=ABMCTR+1

 .W !

 .S ABMDE="LAB "_$G(ABMRV(I,J,L,ABMIJ))_"^5^25"

 .D WRT^ABMDF28W  ;#43

 ;S ABMDE=J_"^30^14"  ;abm*2.6*27 IHS/SD/SDR CR8897

 S ABMDE=$P(ABMRV(I,J,L),U,2)_"^30^14"  ;abm*2.6*27 IHS/SD/SDR CR8897

 D WRT^ABMDF28W

 S ABMDE=$$MDY^ABMDUTL($P(ABMRV(I,J,L),U,27))_"^45^6"

 D WRT^ABMDF28W  ;#45

 S ABMDE=$P(ABMRV(I,J,L),U,5)_"^52^7R"  ;Tot units/item

 D WRT^ABMDF28W  ;#46

 S ABMDE=$FN($P(ABMRV(I,J,L),U,6),"T",2)

 S ABMDE=$TR(ABMDE,".")_"^61^9R"  ;Tot chg per item

 D WRT^ABMDF28W  ;#47

 Q

 ;

2LNMDS ;EP

 ;start new abm*2.6*9 HEAT18507

 S I=0

 F  S I=$O(ABMRV(I)) Q:'I  D

 .S J=-1

 .F  S J=$O(ABMRV(I,J)) Q:J=""  D

 ..S K=0

 ..F  S K=$O(ABMRV(I,J,K)) Q:'K  D

 ...Q:$P(ABMRV(I,J,K),U,9)=""

 ...S L=K+.5

 ...S $P(ABMRV(I,J,L),U,9)=$P($P(ABMRV(I,J,K),U,9)," ",2,$L(ABMRV(I,J,K)," "))

 ...S $P(ABMRV(I,J,K),U,9)=$P($P(ABMRV(I,J,K),U,9)," ")

 ...S K=L

 ;end new HEAT18507

 ;

PGCNT ;EP

 ;cnt lines for page numbering

 S ABMLCNT=0

 F  S I=$O(ABMRV(I)) Q:'I  D

 .I 'ABMITMZ S ABMLCNT=ABMLCNT+1 Q

 .S J=-1

 .F  S J=$O(ABMRV(I,J)) Q:J=""  D

 ..S L=0

 ..F  S L=$O(ABMRV(I,J,L)) Q:+L=0  D

 ...;S ABMLCNT=ABMLCNT+1  ;abm*2.6*21 IHS/SD/SDR HEAT240744

 ...;start new abm*2.6*21 IHS/SD/SDR HEAT240744

 ...S ABMIJ=0

 ...F  S ABMIJ=$O(ABMRV(I,J,L,ABMIJ)) Q:'ABMIJ  D

 ....S ABMLCNT=ABMLCNT+1

 ....S ABMDE="LAB "_$G(ABMRV(I,J,L,ABMIJ))_"^5^25"

 ;end new abm*2.6*21 IHS/SD/SDR HEAT240744

 S ABMPGTOT=ABMLCNT/22  ;# pages

 I $P(ABMPGTOT,".",2)>0 S ABMPGTOT=(ABMPGTOT\1)+1

 K ABMLCNT

 Q

 ;start new abm*2.6*21 HEAT205579

T1015 ;EP

 ;start old abm*2.6*23 IHS/SD/SDR HEAT347035

 ;I (($P($G(^AUTNINS(ABMP("INS"),0)),U)="ARBOR HEALTH PLAN")&($D(ABMRV))) D

 ;.S ABMIS=$O(ABMRV(0))

 ;.S ABMJS=$O(ABMRV(ABMIS,""))

 ;.S ABMKS=$O(ABMRV(ABMIS,ABMJS,""))

 ;.S ABMI=0

 ;.F  S ABMI=$O(ABMRV(ABMI)) Q:'ABMI  D

 ;..S ABMJ=""

 ;..F  S ABMJ=$O(ABMRV(ABMI,ABMJ)) Q:$G(ABMJ)=""  D

 ;...S ABMK=""

 ;...F  S ABMK=$O(ABMRV(ABMI,ABMJ,ABMK)) Q:'ABMK  D

 ;....I $P($G(ABMRV(ABMI,ABMJ,ABMK)),U,2)'="T1015" Q

 ;....S ABMTMP("TMP")=$G(ABMRV(ABMIS,ABMJS,ABMKS))

 ;....S ABMRV(ABMIS,ABMJS,ABMKS)=$G(ABMRV(ABMI,ABMJ,ABMK))

 ;....S ABMRV(ABMI,ABMJ,ABMK)=$G(ABMTMP("TMP"))

 ;end old start new abm*2.6*23 IHS/SD/SDR HEAT347035

 ;I ($D(ABMRV))&(($P($G(^AUTNINS(ABMP("INS"),0)),U)="ARBOR HEALTH PLAN")!($$RCID^ABMUTLP(ABMP("INS"))["61044")) D  ;abm*2.6*27 IHS/SD/SDR CR8897

 I ($D(ABMRV))&(($P($G(^AUTNINS(ABMP("INS"),0)),U)="ARBOR HEALTH PLAN")!($$RCID^ABMUTLP(ABMP("INS"))["61044")!($G(ABMP("ITYPE"))="D")) D  ;abm*2.6*27 IHS/SD/SDR CR8897

 .S ABMF=0

 .S (ABMIS,ABMJS,ABMKS)=1

 .S ABMI=0

 .F  S ABMI=$O(ABMRV(ABMI)) Q:'ABMI  D

 ..S ABMJ=""

 ..F  S ABMJ=$O(ABMRV(ABMI,ABMJ)) Q:$G(ABMJ)=""  D

 ...S ABMK=""

 ...F  S ABMK=$O(ABMRV(ABMI,ABMJ,ABMK)) Q:'ABMK  D

 ....M ABMTMP(ABMIS,ABMJS,ABMKS)=ABMRV(ABMI,ABMJ,ABMK)

 ....S ABMIS=ABMIS+1,ABMJS=ABMJS+1,ABMKS=ABMKS+1

 ....I $P($G(ABMRV(ABMI,ABMJ,ABMK)),U,2)'="T1015" S ABMF=1 Q

 .I ABMF=0 Q  ;no T1015 on claim

 .K ABMRV

 .M ABMRV=ABMTMP

 .S ABMI=0

 .F  S ABMI=$O(ABMRV(ABMI)) Q:'ABMI  D

 ..S ABMJ=""

 ..F  S ABMJ=$O(ABMRV(ABMI,ABMJ)) Q:$G(ABMJ)=""  D

 ...S ABMK=""

 ...F  S ABMK=$O(ABMRV(ABMI,ABMJ,ABMK)) Q:$G(ABMK)=""  D

 ....I $P($G(ABMRV(ABMI,ABMJ,ABMK)),U,2)'="T1015" Q

 ....S ABMTMP("TMP")=$G(ABMRV(ABMI,ABMJ,ABMK))

 ....S ABMRV(ABMI,ABMJ,ABMK)=$G(ABMRV(1,1,1))

 ....S ABMRV(1,1,1)=$G(ABMTMP("TMP"))

 ;end new abm*2.6*23 IHS/SD/SDR HEAT347035

 Q

 ;end new abm*2.6*21 HEAT205579

 ;start new abm*2.6*23 IHS/SD/SDR HEAT247169

NDC ;EP

 K I,J,L

 S I=0

 F  S I=$O(ABMRV(I)) Q:'I  D

 .S J=" "

 .F  S J=$O(ABMRV(I,J)) Q:($G(J)="")  D

 ..S L=0

 ..F  S L=$O(ABMRV(I,J,L)) Q:'L  D

 ...I $P($G(ABMRV(I,J,L)),U,19)'="" S $P(ABMRV(I,J,L),U,9)=$P(ABMRV(I,J,L),U,19)_" "_$P(ABMRV(I,J,L),U,9)

 Q

 ;end new abm*2.6*23 IHS/SD/SDR HEAT247169

 ;start new abm*2.6*27 IHS/SD/AML,SDR HEAT314802/CR8897

CALYRTC ;EP

 ;S ABMDE=$P(ABMRV(I,J,L),U,2)_"^30^14"

 ;D WRT^ABMDF28W

 ;S ABMDE=$$MDY^ABMDUTL($P(ABMRV(I,J,L),U,10))_"^45^6"

 ;D WRT^ABMDF28W  ;#45

 ;S ABMDE=$P(ABMRV(I,J,L),U,5)_"^52^7R"  ;Tot units/item

 ;D WRT^ABMDF28W  ;#46

 ;S ABMDE=$FN($P(ABMRV(I,J,L),U,6),"T",2)

 ;S ABMDE=$TR(ABMDE,".")_"^61^9R"  ;Tot chg per item

 ;D WRT^ABMDF28W  ;#47

 S ABMDE=$$MDY^ABMDUTL($P(ABMRV(I,J,L),U,10))_"^45^6"

 D WRT^ABMDF28W  ;#45

 W !

 S ABMIPADT=$P($$MDT^ABMDUTL($P(ABMRV(I,J,L),U,10)),"-",2)_" "_$P($$MDT^ABMDUTL($P(ABMRV(I,J,L),U,10)),"-",1)

 S ABMIPDDT=$P($$MDT^ABMDUTL($P(ABMRV(I,J,L),U,27)),"-",2)_" "_$P($$MDT^ABMDUTL($P(ABMRV(I,J,L),U,27)),"-",1)_","_$P($$MDT^ABMDUTL($P(ABMRV(I,J,L),U,27)),"-",3)

 S ABMDE=ABMIPADT_"-"_ABMIPDDT_"^5^24"

 D WRT^ABMDF28W

 S ABMDE=$P(ABMRV(I,J,L),U,2)_"^30^14"

 D WRT^ABMDF28W

 S ABMDE=$$MDY^ABMDUTL($P(ABMRV(I,J,L),U,27))_"^45^6"

 D WRT^ABMDF28W  ;#45

 S ABMDE=$P(ABMRV(I,J,L),U,5)_"^52^7R"  ;Tot units/item

 D WRT^ABMDF28W  ;#46

 S ABMDE=$FN($P(ABMRV(I,J,L),U,6),"T",2)

 S ABMDE=$TR(ABMDE,".")_"^61^9R"  ;Tot chg per item

 D WRT^ABMDF28W  ;#47

 S ABMCTR=ABMCTR+1  ;account for second line printing so lower part of form prints correctly

 Q

23CMPL ;EP

 D 23CHK Q:ABMCPTM  ;don't do if multiple CPTs on claim

 K ABMRTMP

 ; 

 N I,J,K

 ;make sure 23 codes are in chronological order

 S I=0

 F  S I=$O(ABMRV(I)) Q:'I  D

 .S J=-1

 .F  S J=$O(ABMRV(I,J)) Q:J=""  D

 ..;I J'["23" Q  ;looking for 23 specifically  ;removed-it could be any code but should be only code left on claim; all others are deleted

 ..S K=0

 ..F  S K=$O(ABMRV(I,J,K)) Q:'K  D

 ...S ABMRTMP($P(ABMRV(I,J,K),U,10),I,J,K)=$G(ABMRV(I,J,K))

 ...K ABMRV(I,J,K)

 ;

 S ABMSDT=0

 S L=1

 F  S ABMSDT=$O(ABMRTMP(ABMSDT)) Q:'ABMSDT  D

 .S I=0

 .F  S I=$O(ABMRTMP(ABMSDT,I)) Q:'I  D

 ..S J=-1

 ..F  S J=$O(ABMRTMP(ABMSDT,I,J)) Q:J=""  D

 ...S K=0

 ...F  S K=$O(ABMRTMP(ABMSDT,I,J,K)) Q:'K  D

 ....S ABMRV(I,J,L)=$G(ABMRTMP(ABMSDT,I,J,K))

 ....S L=L+1

 ;

 ;now merge all same rev code/CPT entries into 1 with all dates on second line

 S ABMN=1

 S ABMI=1

 K ABMSUNIT,ABMSCHG

 K ABMSDT,ABMSDT2

 K ABMSLN

 S I=0

 F  S I=$O(ABMRV(I)) Q:'I  D

 .S J=-1

 .F  S J=$O(ABMRV(I,J)) Q:J=""  D

 ..S K=0

 ..F  S K=$O(ABMRV(I,J,K)) Q:'K  D

 ...I ABMN=1 D

 ....S ABMSLN=K  ;keep track of 1st line

 ....S ABMSDT=$P(ABMRV(I,J,K),U,10)  ;save date from 1st line

 ....S ABMSMNTH=$P($$SDT^ABMDUTL(ABMSDT),"/")

 ....S ABMN=2

 ...I ABMN'=1 D

 ....I $P(ABMRV(I,J,K),U,27)>ABMSDT S $P(ABMRV(I,J,ABMSLN),U,27)=$P(ABMRV(I,J,K),U,27)

 ....I +$P(ABMRV(I,J,ABMSLN),U,27)=0!($P(ABMRV(I,J,K),U,10)>$P(ABMRV(I,J,ABMSLN),U,27)) S $P(ABMRV(I,J,ABMSLN),U,27)=$P(ABMRV(I,J,K),U,10)  ;default to later start date if do SERVICE DATE TO

 ....S ABMSUNIT=+$G(ABMSUNIT)+$P(ABMRV(I,J,K),U,5)  ;accumulate units

 ....S ABMSCHG=+$G(ABMSCHG)+$P(ABMRV(I,J,K),U,6)  ;accumulate chgs

 ....S ABMSDT2=$P($$SDT^ABMDUTL($P(ABMRV(I,J,K),U,10)),"/",1,2)

 ....;I (+$G(ABMRV(I,J,ABMSLN,1))'=0)&(ABMSMNTH=$P(ABMSDT2,"/")) S ABMSDT2=$P(ABMSDT2,"/",2)

 ....;E  S ABMSMNTH=$P(ABMSDT2,"/")

 ....I $G(ABMRV(I,J,ABMSLN,1))'="" S ABMSDT2=","_ABMSDT2

 ....I ($L($G(ABMRV(I,J,ABMSLN,ABMI)))+$L(ABMSDT2))>21 S ABMRV(I,J,ABMSLN,ABMI)=ABMRV(I,J,ABMSLN,ABMI)_",",ABMI=ABMI+1,ABMSDT2=$P(ABMSDT2,",",2)

 ....S ABMRV(I,J,ABMSLN,ABMI)=$G(ABMRV(I,J,ABMSLN,ABMI))_ABMSDT2

 ...I ABMSLN'=K K ABMRV(I,J,K)

 ..S $P(ABMRV(I,J,ABMSLN),U,5)=ABMSUNIT

 ..S $P(ABMRV(I,J,ABMSLN),U,6)=ABMSCHG

 Q

23CHK ;EP

 ;first check if there are multiple CPTs on claim; don't do the rest of this linetag if there is

 N I,J

 S ABMSV=""

 S I=0,ABMCPTM=0

 F  S I=$O(ABMRV(I)) Q:'I  D

 .S J=-1

 .F  S J=$O(ABMRV(I,J)) Q:J=""  D

 ..I ABMSV'="",J'=ABMSV S ABMCPTM=1

 ..S ABMSV=J

 Q

 ;

23PRT ;EP

 D 23CHK Q:ABMCPTM=1

 S ABMIJ=0

 F  S ABMIJ=$O(ABMRV(I,J,L,ABMIJ)) Q:'ABMIJ  D

 .S ABMCTR=ABMCTR+1

 .S ABMDE=$$MDY^ABMDUTL($P(ABMRV(I,J,L),U,10))_"^45^6"

 .I ABMIJ=1 D WRT^ABMDF28W  ;#45

 .W !

 .S ABMDE=$G(ABMRV(I,J,L,ABMIJ))_"^5^25"

 .D WRT^ABMDF28W  ;#43

 .I ABMIJ=$O(ABMRV(I,J,L,99),-1) D

 ..S ABMDE=$P(ABMRV(I,J,L),U,2)_"^30^14"

 ..;

 ..S ABMMODL=$S($P(ABMRV(I,J,L),U,3)]"":$P(ABMRV(I,J,L),U,3),1:"")

 ..S ABMMODL=ABMMODL_$S($P(ABMRV(I,J,L),U,4)]"":$P(ABMRV(I,J,L),U,4),1:"")

 ..S ABMMODL=ABMMODL_$S($P(ABMRV(I,J,L),U,12)]"":$P(ABMRV(I,J,L),U,12),1:"")

 ..S ABMDE=$S($L($P(ABMRV(I,J,L),U,2))>3:$P(ABMRV(I,J,L),U,2)_" "_ABMMODL_"^30^14",$P(ABMRV(I,J,L),U,8)&(+$P(ABMRV(I,J,L),U,2)'=0):$J($P(ABMRV(I,J,L),U,8),1,2)_"^30^14R",+ABMMODL:$J(ABMMODL,1,2)_"^30^14",1:"")

 ..;

 ..D WRT^ABMDF28W  ;#44

 ..S ABMDE=$$MDY^ABMDUTL($P(ABMRV(I,J,L),U,27))_"^45^6"

 ..D WRT^ABMDF28W  ;#45

 ..S ABMDE=$P(ABMRV(I,J,L),U,5)_"^52^7R"  ;Tot units/item

 ..D WRT^ABMDF28W  ;#46

 ..S ABMDE=$FN($P(ABMRV(I,J,L),U,6),"T",2)

 ..S ABMDE=$TR(ABMDE,".")_"^61^9R"  ;Tot chg per item

 ..D WRT^ABMDF28W  ;#47

 Q

 ;end new abm*2.6*27 IHS/SD/AML,SDR HEAT314802/CR8897

ABMDF28S  ; IHS/SD/SDR - PRINT UB-04 ;  

 +1       ;;2.6;IHS 3P BILLING SYSTEM;**21,23,27**;NOV 12, 2009;Build 486

 +2       ;new routine abm*2.6*21

 +3       ;IHS/SD/SDR-2.6*21 HEAT240744 - Added routine to resort line items for dialysis billing for Medi-Cal.  All Z6004 CPTs should be reported as 1 line item

 +4       ; with all dates, total units for all Z6004s, and a total $$.

 +5       ;IHS/SD/SDR 2.6*23 HEAT247169 If there's an NDC on the line item add it to the description

 +6       ;IHS/SD/SDR 2.6*23 HEAT347035 Make T1015 print on the top line for Medi-Cal

 +7       ;IHS/SD/AML,SDR 2.6*27 CR8897 Change for Medi-Cal from-thru billing

 +8       ;

COMPILE   ;EP

 +1        KILL I,J,K

 +2       ;make sure Z6004 codes are in chronological order

 +3        SET I=0

 +4        FOR 

               SET I=$ORDER(ABMRV(I))

               IF 'I

                   QUIT 

               Begin DoDot:1

 +5                SET J=-1

 +6                FOR 

                       SET J=$ORDER(ABMRV(I,J))

                       IF J=""

                           QUIT 

                       Begin DoDot:2

 +7       ;looking for Z6004 specifically

                           IF J'="Z6004"

                               QUIT 

 +8                        SET K=0

 +9                        FOR 

                               SET K=$ORDER(ABMRV(I,J,K))

                               IF 'K

                                   QUIT 

                               Begin DoDot:3

 +10                               SET ABMRTMP($PIECE(ABMRV(I,J,K),U,10),I,J,K)=$GET(ABMRV(I,J,K))

 +11                               KILL ABMRV(I,J,K)

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +12      ;

 +13       SET ABMSDT=0

 +14       SET L=1

 +15       FOR 

               SET ABMSDT=$ORDER(ABMRTMP(ABMSDT))

               IF 'ABMSDT

                   QUIT 

               Begin DoDot:1

 +16               SET I=0

 +17               FOR 

                       SET I=$ORDER(ABMRTMP(ABMSDT,I))

                       IF 'I

                           QUIT 

                       Begin DoDot:2

 +18                       SET J=-1

 +19                       FOR 

                               SET J=$ORDER(ABMRTMP(ABMSDT,I,J))

                               IF J=""

                                   QUIT 

                               Begin DoDot:3

 +20                               SET K=0

 +21                               FOR 

                                       SET K=$ORDER(ABMRTMP(ABMSDT,I,J,K))

                                       IF 'K

                                           QUIT 

                                       Begin DoDot:4

 +22                                       SET ABMRV(I,J,L)=$GET(ABMRTMP(ABMSDT,I,J,K))

 +23                                       SET L=L+1

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +24      ;

 +25      ;now merge Z6004 entries into 1

 +26       SET ABMN=1

 +27       SET ABMI=1

 +28       SET I=0

 +29       FOR 

               SET I=$ORDER(ABMRV(I))

               IF 'I

                   QUIT 

               Begin DoDot:1

 +30               SET J=-1

 +31               FOR 

                       SET J=$ORDER(ABMRV(I,J))

                       IF J=""

                           QUIT 

                       Begin DoDot:2

 +32      ;looking for Z6004 specifically

                           IF J'="Z6004"

                               QUIT 

 +33                       SET K=0

 +34                       FOR 

                               SET K=$ORDER(ABMRV(I,J,K))

                               IF 'K

                                   QUIT 

                               Begin DoDot:3

 +35                               IF ABMN=1

                                       Begin DoDot:4

 +36      ;keep track of 1st line with Z6004

                                           SET ABMSLN=K

 +37      ;save date from 1st line

                                           SET ABMSDT=$PIECE(ABMRV(I,J,K),U,10)

 +38                                       SET ABMSMNTH=$PIECE($$SDT^ABMDUTL(ABMSDT),"/")

 +39                                       SET ABMN=2

                                       End DoDot:4

 +40                               IF ABMN'=1

                                       Begin DoDot:4

 +41                                       IF $PIECE(ABMRV(I,J,K),U,27)>ABMSDT

                                               SET $PIECE(ABMRV(I,J,ABMSLN),U,27)=$PIECE(ABMRV(I,J,K),U,27)

 +42      ;default to later start date if do SERVICE DATE TO

                                           IF +$PIECE(ABMRV(I,J,ABMSLN),U,27)=0!($PIECE(ABMRV(I,J,K),U,10)>$PIECE(ABMRV(I,J,ABMSLN),U,27))

                                               SET $PIECE(ABMRV(I,J,ABMSLN),U,27)=$PIECE(ABMRV(I,J,K),U,10)

 +43      ;accumulate units

                                           SET ABMSUNIT=+$GET(ABMSUNIT)+$PIECE(ABMRV(I,J,K),U,5)

 +44      ;accumulate chgs

                                           SET ABMSCHG=+$GET(ABMSCHG)+$PIECE(ABMRV(I,J,K),U,6)

 +45                                       SET ABMSDT2=$PIECE($$SDT^ABMDUTL($PIECE(ABMRV(I,J,K),U,10)),"/",1,2)

 +46                                       IF (+$GET(ABMRV(I,J,ABMSLN,1))'=0)&(ABMSMNTH=$PIECE(ABMSDT2,"/"))

                                               SET ABMSDT2=$PIECE(ABMSDT2,"/",2)

 +47                                      IF '$TEST

                                               SET ABMSMNTH=$PIECE(ABMSDT2,"/")

 +48                                       IF $GET(ABMRV(I,J,ABMSLN,1))'=""

                                               SET ABMSDT2=","_ABMSDT2

 +49                                       IF ($LENGTH($GET(ABMRV(I,J,ABMSLN,ABMI)))+$LENGTH(ABMSDT2))>21

                                               SET ABMRV(I,J,ABMSLN,ABMI)=ABMRV(I,J,ABMSLN,ABMI)_","

                                               SET ABMI=ABMI+1

                                               SET ABMSDT2=$PIECE(ABMSDT2,",",2)

 +50                                       SET ABMRV(I,J,ABMSLN,ABMI)=$GET(ABMRV(I,J,ABMSLN,ABMI))_ABMSDT2

                                       End DoDot:4

 +51                               IF ABMSLN'=K

                                       KILL ABMRV(I,J,K)

                               End DoDot:3

 +52                       SET $PIECE(ABMRV(I,J,ABMSLN),U,5)=ABMSUNIT

 +53                       SET $PIECE(ABMRV(I,J,ABMSLN),U,6)=ABMSCHG

                       End DoDot:2

               End DoDot:1

 +54       QUIT 

 +55      ;

Z6004PRT  ;EP

 +1        SET ABMIJ=0

 +2        FOR 

               SET ABMIJ=$ORDER(ABMRV(I,J,L,ABMIJ))

               IF 'ABMIJ

                   QUIT 

               Begin DoDot:1

 +3                SET ABMCTR=ABMCTR+1

 +4                WRITE !

 +5                SET ABMDE="LAB "_$GET(ABMRV(I,J,L,ABMIJ))_"^5^25"

 +6       ;#43

                   DO WRT^ABMDF28W

               End DoDot:1

 +7       ;S ABMDE=J_"^30^14"  ;abm*2.6*27 IHS/SD/SDR CR8897

 +8       ;abm*2.6*27 IHS/SD/SDR CR8897

           SET ABMDE=$PIECE(ABMRV(I,J,L),U,2)_"^30^14"

 +9        DO WRT^ABMDF28W

 +10       SET ABMDE=$$MDY^ABMDUTL($PIECE(ABMRV(I,J,L),U,27))_"^45^6"

 +11      ;#45

           DO WRT^ABMDF28W

 +12      ;Tot units/item

           SET ABMDE=$PIECE(ABMRV(I,J,L),U,5)_"^52^7R"

 +13      ;#46

           DO WRT^ABMDF28W

 +14       SET ABMDE=$FNUMBER($PIECE(ABMRV(I,J,L),U,6),"T",2)

 +15      ;Tot chg per item

           SET ABMDE=$TRANSLATE(ABMDE,".")_"^61^9R"

 +16      ;#47

           DO WRT^ABMDF28W

 +17       QUIT 

 +18      ;

2LNMDS    ;EP

 +1       ;start new abm*2.6*9 HEAT18507

 +2        SET I=0

 +3        FOR 

               SET I=$ORDER(ABMRV(I))

               IF 'I

                   QUIT 

               Begin DoDot:1

 +4                SET J=-1

 +5                FOR 

                       SET J=$ORDER(ABMRV(I,J))

                       IF J=""

                           QUIT 

                       Begin DoDot:2

 +6                        SET K=0

 +7                        FOR 

                               SET K=$ORDER(ABMRV(I,J,K))

                               IF 'K

                                   QUIT 

                               Begin DoDot:3

 +8                                IF $PIECE(ABMRV(I,J,K),U,9)=""

                                       QUIT 

 +9                                SET L=K+.5

 +10                               SET $PIECE(ABMRV(I,J,L),U,9)=$PIECE($PIECE(ABMRV(I,J,K),U,9)," ",2,$LENGTH(ABMRV(I,J,K)," "))

 +11                               SET $PIECE(ABMRV(I,J,K),U,9)=$PIECE($PIECE(ABMRV(I,J,K),U,9)," ")

 +12                               SET K=L

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +13      ;end new HEAT18507

 +14      ;

PGCNT     ;EP

 +1       ;cnt lines for page numbering

 +2        SET ABMLCNT=0

 +3        FOR 

               SET I=$ORDER(ABMRV(I))

               IF 'I

                   QUIT 

               Begin DoDot:1

 +4                IF 'ABMITMZ

                       SET ABMLCNT=ABMLCNT+1

                       QUIT 

 +5                SET J=-1

 +6                FOR 

                       SET J=$ORDER(ABMRV(I,J))

                       IF J=""

                           QUIT 

                       Begin DoDot:2

 +7                        SET L=0

 +8                        FOR 

                               SET L=$ORDER(ABMRV(I,J,L))

                               IF +L=0

                                   QUIT 

                               Begin DoDot:3

 +9       ;S ABMLCNT=ABMLCNT+1  ;abm*2.6*21 IHS/SD/SDR HEAT240744

 +10      ;start new abm*2.6*21 IHS/SD/SDR HEAT240744

 +11                               SET ABMIJ=0

 +12                               FOR 

                                       SET ABMIJ=$ORDER(ABMRV(I,J,L,ABMIJ))

                                       IF 'ABMIJ

                                           QUIT 

                                       Begin DoDot:4

 +13                                       SET ABMLCNT=ABMLCNT+1

 +14                                       SET ABMDE="LAB "_$GET(ABMRV(I,J,L,ABMIJ))_"^5^25"

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +15      ;end new abm*2.6*21 IHS/SD/SDR HEAT240744

 +16      ;# pages

           SET ABMPGTOT=ABMLCNT/22

 +17       IF $PIECE(ABMPGTOT,".",2)>0

               SET ABMPGTOT=(ABMPGTOT\1)+1

 +18       KILL ABMLCNT

 +19       QUIT 

 +20      ;start new abm*2.6*21 HEAT205579

T1015     ;EP

 +1       ;start old abm*2.6*23 IHS/SD/SDR HEAT347035

 +2       ;I (($P($G(^AUTNINS(ABMP("INS"),0)),U)="ARBOR HEALTH PLAN")&($D(ABMRV))) D

 +3       ;.S ABMIS=$O(ABMRV(0))

 +4       ;.S ABMJS=$O(ABMRV(ABMIS,""))

 +5       ;.S ABMKS=$O(ABMRV(ABMIS,ABMJS,""))

 +6       ;.S ABMI=0

 +7       ;.F  S ABMI=$O(ABMRV(ABMI)) Q:'ABMI  D

 +8       ;..S ABMJ=""

 +9       ;..F  S ABMJ=$O(ABMRV(ABMI,ABMJ)) Q:$G(ABMJ)=""  D

 +10      ;...S ABMK=""

 +11      ;...F  S ABMK=$O(ABMRV(ABMI,ABMJ,ABMK)) Q:'ABMK  D

 +12      ;....I $P($G(ABMRV(ABMI,ABMJ,ABMK)),U,2)'="T1015" Q

 +13      ;....S ABMTMP("TMP")=$G(ABMRV(ABMIS,ABMJS,ABMKS))

 +14      ;....S ABMRV(ABMIS,ABMJS,ABMKS)=$G(ABMRV(ABMI,ABMJ,ABMK))

 +15      ;....S ABMRV(ABMI,ABMJ,ABMK)=$G(ABMTMP("TMP"))

 +16      ;end old start new abm*2.6*23 IHS/SD/SDR HEAT347035

 +17      ;I ($D(ABMRV))&(($P($G(^AUTNINS(ABMP("INS"),0)),U)="ARBOR HEALTH PLAN")!($$RCID^ABMUTLP(ABMP("INS"))["61044")) D  ;abm*2.6*27 IHS/SD/SDR CR8897

 +18      ;abm*2.6*27 IHS/SD/SDR CR8897

           IF ($DATA(ABMRV))&(($PIECE($GET(^AUTNINS(ABMP("INS"),0)),U)="ARBOR HEALTH PLAN")!($$RCID^ABMUTLP(ABMP("INS"))["61044")!($GET(ABMP("ITYPE"))="D"))

               Begin DoDot:1

 +19               SET ABMF=0

 +20               SET (ABMIS,ABMJS,ABMKS)=1

 +21               SET ABMI=0

 +22               FOR 

                       SET ABMI=$ORDER(ABMRV(ABMI))

                       IF 'ABMI

                           QUIT 

                       Begin DoDot:2

 +23                       SET ABMJ=""

 +24                       FOR 

                               SET ABMJ=$ORDER(ABMRV(ABMI,ABMJ))

                               IF $GET(ABMJ)=""

                                   QUIT 

                               Begin DoDot:3

 +25                               SET ABMK=""

 +26                               FOR 

                                       SET ABMK=$ORDER(ABMRV(ABMI,ABMJ,ABMK))