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))
IF 'ABMK
QUIT
Begin DoDot:4
+27 MERGE ABMTMP(ABMIS,ABMJS,ABMKS)=ABMRV(ABMI,ABMJ,ABMK)
+28 SET ABMIS=ABMIS+1
SET ABMJS=ABMJS+1
SET ABMKS=ABMKS+1
+29 IF $PIECE($GET(ABMRV(ABMI,ABMJ,ABMK)),U,2)'="T1015"
SET ABMF=1
QUIT
End DoDot:4
End DoDot:3
End DoDot:2
+30 ;no T1015 on claim
IF ABMF=0
QUIT
+31 KILL ABMRV
+32 MERGE ABMRV=ABMTMP
+33 SET ABMI=0
+34 FOR
SET ABMI=$ORDER(ABMRV(ABMI))
IF 'ABMI
QUIT
Begin DoDot:2
+35 SET ABMJ=""
+36 FOR
SET ABMJ=$ORDER(ABMRV(ABMI,ABMJ))
IF $GET(ABMJ)=""
QUIT
Begin DoDot:3
+37 SET ABMK=""
+38 FOR
SET ABMK=$ORDER(ABMRV(ABMI,ABMJ,ABMK))
IF $GET(ABMK)=""
QUIT
Begin DoDot:4
+39 IF $PIECE($GET(ABMRV(ABMI,ABMJ,ABMK)),U,2)'="T1015"
QUIT
+40 SET ABMTMP("TMP")=$GET(ABMRV(ABMI,ABMJ,ABMK))
+41 SET ABMRV(ABMI,ABMJ,ABMK)=$GET(ABMRV(1,1,1))
+42 SET ABMRV(1,1,1)=$GET(ABMTMP("TMP"))
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+43 ;end new abm*2.6*23 IHS/SD/SDR HEAT347035
+44 QUIT
+45 ;end new abm*2.6*21 HEAT205579
+46 ;start new abm*2.6*23 IHS/SD/SDR HEAT247169
NDC ;EP
+1 KILL I,J,L
+2 SET I=0
+3 FOR
SET I=$ORDER(ABMRV(I))
IF 'I
QUIT
Begin DoDot:1
+4 SET J=" "
+5 FOR
SET J=$ORDER(ABMRV(I,J))
IF ($GET(J)="")
QUIT
Begin DoDot:2
+6 SET L=0
+7 FOR
SET L=$ORDER(ABMRV(I,J,L))
IF 'L
QUIT
Begin DoDot:3
+8 IF $PIECE($GET(ABMRV(I,J,L)),U,19)'=""
SET $PIECE(ABMRV(I,J,L),U,9)=$PIECE(ABMRV(I,J,L),U,19)_" "_$PIECE(ABMRV(I,J,L),U,9)
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;end new abm*2.6*23 IHS/SD/SDR HEAT247169
+11 ;start new abm*2.6*27 IHS/SD/AML,SDR HEAT314802/CR8897
CALYRTC ;EP
+1 ;S ABMDE=$P(ABMRV(I,J,L),U,2)_"^30^14"
+2 ;D WRT^ABMDF28W
+3 ;S ABMDE=$$MDY^ABMDUTL($P(ABMRV(I,J,L),U,10))_"^45^6"
+4 ;D WRT^ABMDF28W ;#45
+5 ;S ABMDE=$P(ABMRV(I,J,L),U,5)_"^52^7R" ;Tot units/item
+6 ;D WRT^ABMDF28W ;#46
+7 ;S ABMDE=$FN($P(ABMRV(I,J,L),U,6),"T",2)
+8 ;S ABMDE=$TR(ABMDE,".")_"^61^9R" ;Tot chg per item
+9 ;D WRT^ABMDF28W ;#47
+10 SET ABMDE=$$MDY^ABMDUTL($PIECE(ABMRV(I,J,L),U,10))_"^45^6"
+11 ;#45
DO WRT^ABMDF28W
+12 WRITE !
+13 SET ABMIPADT=$PIECE($$MDT^ABMDUTL($PIECE(ABMRV(I,J,L),U,10)),"-",2)_" "_$PIECE($$MDT^ABMDUTL($PIECE(ABMRV(I,J,L),U,10)),"-",1)
+14 SET ABMIPDDT=$PIECE($$MDT^ABMDUTL($PIECE(ABMRV(I,J,L),U,27)),"-",2)_" "_$PIECE($$MDT^ABMDUTL($PIECE(ABMRV(I,J,L),U,27)),"-",1)_","_$PIECE($$MDT^ABMDUTL($PIECE(ABMRV(I,J,L),U,27)),"-",3)
+15 SET ABMDE=ABMIPADT_"-"_ABMIPDDT_"^5^24"
+16 DO WRT^ABMDF28W
+17 SET ABMDE=$PIECE(ABMRV(I,J,L),U,2)_"^30^14"
+18 DO WRT^ABMDF28W
+19 SET ABMDE=$$MDY^ABMDUTL($PIECE(ABMRV(I,J,L),U,27))_"^45^6"
+20 ;#45
DO WRT^ABMDF28W
+21 ;Tot units/item
SET ABMDE=$PIECE(ABMRV(I,J,L),U,5)_"^52^7R"
+22 ;#46
DO WRT^ABMDF28W
+23 SET ABMDE=$FNUMBER($PIECE(ABMRV(I,J,L),U,6),"T",2)
+24 ;Tot chg per item
SET ABMDE=$TRANSLATE(ABMDE,".")_"^61^9R"
+25 ;#47
DO WRT^ABMDF28W
+26 ;account for second line printing so lower part of form prints correctly
SET ABMCTR=ABMCTR+1
+27 QUIT
23CMPL ;EP
+1 ;don't do if multiple CPTs on claim
DO 23CHK
IF ABMCPTM
QUIT
+2 KILL ABMRTMP
+3 ;
+4 NEW I,J,K
+5 ;make sure 23 codes are in chronological order
+6 SET I=0
+7 FOR
SET I=$ORDER(ABMRV(I))
IF 'I
QUIT
Begin DoDot:1
+8 SET J=-1
+9 FOR
SET J=$ORDER(ABMRV(I,J))
IF J=""
QUIT
Begin DoDot:2
+10 ;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
+11 SET K=0
+12 FOR
SET K=$ORDER(ABMRV(I,J,K))
IF 'K
QUIT
Begin DoDot:3
+13 SET ABMRTMP($PIECE(ABMRV(I,J,K),U,10),I,J,K)=$GET(ABMRV(I,J,K))
+14 KILL ABMRV(I,J,K)
End DoDot:3
End DoDot:2
End DoDot:1
+15 ;
+16 SET ABMSDT=0
+17 SET L=1
+18 FOR
SET ABMSDT=$ORDER(ABMRTMP(ABMSDT))
IF 'ABMSDT
QUIT
Begin DoDot:1
+19 SET I=0
+20 FOR
SET I=$ORDER(ABMRTMP(ABMSDT,I))
IF 'I
QUIT
Begin DoDot:2
+21 SET J=-1
+22 FOR
SET J=$ORDER(ABMRTMP(ABMSDT,I,J))
IF J=""
QUIT
Begin DoDot:3
+23 SET K=0
+24 FOR
SET K=$ORDER(ABMRTMP(ABMSDT,I,J,K))
IF 'K
QUIT
Begin DoDot:4
+25 SET ABMRV(I,J,L)=$GET(ABMRTMP(ABMSDT,I,J,K))
+26 SET L=L+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+27 ;
+28 ;now merge all same rev code/CPT entries into 1 with all dates on second line
+29 SET ABMN=1
+30 SET ABMI=1
+31 KILL ABMSUNIT,ABMSCHG
+32 KILL ABMSDT,ABMSDT2
+33 KILL ABMSLN
+34 SET I=0
+35 FOR
SET I=$ORDER(ABMRV(I))
IF 'I
QUIT
Begin DoDot:1
+36 SET J=-1
+37 FOR
SET J=$ORDER(ABMRV(I,J))
IF J=""
QUIT
Begin DoDot:2
+38 SET K=0
+39 FOR
SET K=$ORDER(ABMRV(I,J,K))
IF 'K
QUIT
Begin DoDot:3
+40 IF ABMN=1
Begin DoDot:4
+41 ;keep track of 1st line
SET ABMSLN=K
+42 ;save date from 1st line
SET ABMSDT=$PIECE(ABMRV(I,J,K),U,10)
+43 SET ABMSMNTH=$PIECE($$SDT^ABMDUTL(ABMSDT),"/")
+44 SET ABMN=2
End DoDot:4
+45 IF ABMN'=1
Begin DoDot:4
+46 IF $PIECE(ABMRV(I,J,K),U,27)>ABMSDT
SET $PIECE(ABMRV(I,J,ABMSLN),U,27)=$PIECE(ABMRV(I,J,K),U,27)
+47 ;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)
+48 ;accumulate units
SET ABMSUNIT=+$GET(ABMSUNIT)+$PIECE(ABMRV(I,J,K),U,5)
+49 ;accumulate chgs
SET ABMSCHG=+$GET(ABMSCHG)+$PIECE(ABMRV(I,J,K),U,6)
+50 SET ABMSDT2=$PIECE($$SDT^ABMDUTL($PIECE(ABMRV(I,J,K),U,10)),"/",1,2)
+51 ;I (+$G(ABMRV(I,J,ABMSLN,1))'=0)&(ABMSMNTH=$P(ABMSDT2,"/")) S ABMSDT2=$P(ABMSDT2,"/",2)
+52 ;E S ABMSMNTH=$P(ABMSDT2,"/")
+53 IF $GET(ABMRV(I,J,ABMSLN,1))'=""
SET ABMSDT2=","_ABMSDT2
+54 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)
+55 SET ABMRV(I,J,ABMSLN,ABMI)=$GET(ABMRV(I,J,ABMSLN,ABMI))_ABMSDT2
End DoDot:4
+56 IF ABMSLN'=K
KILL ABMRV(I,J,K)
End DoDot:3
+57 SET $PIECE(ABMRV(I,J,ABMSLN),U,5)=ABMSUNIT
+58 SET $PIECE(ABMRV(I,J,ABMSLN),U,6)=ABMSCHG
End DoDot:2
End DoDot:1
+59 QUIT
23CHK ;EP
+1 ;first check if there are multiple CPTs on claim; don't do the rest of this linetag if there is
+2 NEW I,J
+3 SET ABMSV=""
+4 SET I=0
SET ABMCPTM=0
+5 FOR
SET I=$ORDER(ABMRV(I))
IF 'I
QUIT
Begin DoDot:1
+6 SET J=-1
+7 FOR
SET J=$ORDER(ABMRV(I,J))
IF J=""
QUIT
Begin DoDot:2
+8 IF ABMSV'=""
IF J'=ABMSV
SET ABMCPTM=1
+9 SET ABMSV=J
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
23PRT ;EP
+1 DO 23CHK
IF ABMCPTM=1
QUIT
+2 SET ABMIJ=0
+3 FOR
SET ABMIJ=$ORDER(ABMRV(I,J,L,ABMIJ))
IF 'ABMIJ
QUIT
Begin DoDot:1
+4 SET ABMCTR=ABMCTR+1
+5 SET ABMDE=$$MDY^ABMDUTL($PIECE(ABMRV(I,J,L),U,10))_"^45^6"
+6 ;#45
IF ABMIJ=1
DO WRT^ABMDF28W
+7 WRITE !
+8 SET ABMDE=$GET(ABMRV(I,J,L,ABMIJ))_"^5^25"
+9 ;#43
DO WRT^ABMDF28W
+10 IF ABMIJ=$ORDER(ABMRV(I,J,L,99),-1)
Begin DoDot:2
+11 SET ABMDE=$PIECE(ABMRV(I,J,L),U,2)_"^30^14"
+12 ;
+13 SET ABMMODL=$SELECT($PIECE(ABMRV(I,J,L),U,3)]"":$PIECE(ABMRV(I,J,L),U,3),1:"")
+14 SET ABMMODL=ABMMODL_$SELECT($PIECE(ABMRV(I,J,L),U,4)]"":$PIECE(ABMRV(I,J,L),U,4),1:"")
+15 SET ABMMODL=ABMMODL_$SELECT($PIECE(ABMRV(I,J,L),U,12)]"":$PIECE(ABMRV(I,J,L),U,12),1:"")
+16 SET ABMDE=$SELECT($LENGTH($PIECE(ABMRV(I,J,L),U,2))>3:$PIECE(ABMRV(I,J,L),U,2)_" "_ABMMODL_"^30^14",$PIECE(ABMRV(I,J,L),U,8)&(+$PIECE(ABMRV(I,J,L),U,2)'=0):$JUSTIFY($PIECE(ABMRV(I,J,L),U,8),1,2)_"^30^14R",+ABMMODL:$JUSTIFY(ABMMO
DL,1,2)_"^30^14",1:"")
+17 ;
+18 ;#44
DO WRT^ABMDF28W
+19 SET ABMDE=$$MDY^ABMDUTL($PIECE(ABMRV(I,J,L),U,27))_"^45^6"
+20 ;#45
DO WRT^ABMDF28W
+21 ;Tot units/item
SET ABMDE=$PIECE(ABMRV(I,J,L),U,5)_"^52^7R"
+22 ;#46
DO WRT^ABMDF28W
+23 SET ABMDE=$FNUMBER($PIECE(ABMRV(I,J,L),U,6),"T",2)
+24 ;Tot chg per item
SET ABMDE=$TRANSLATE(ABMDE,".")_"^61^9R"
+25 ;#47
DO WRT^ABMDF28W
End DoDot:2
End DoDot:1
+26 QUIT
+27 ;end new abm*2.6*27 IHS/SD/AML,SDR HEAT314802/CR8897
