ABMFEAPI ; IHS/SD/SDR - 3P Fee Table API
;;2.6;IHS THIRD PARTY BILLING SYSTEM;**2,3,8,14,21,27**;NOV 12, 2009;Build 486
;
;IHS/SD/SDR 2.6*3 FIXPMS10008 and FIXPMS10012 Corrections to RANGE tag
;IHS/SD/SDR 2.6*21 HEAT130924 Made correction to fee lookup for dental codes.
; Was using the code to lookup in the "B" x-ref but that one is by IEN.
;IHS/SD/SDR 2.6*27 CR8894 Corrections to Range tag; all variables weren't defined and Category III codes skipped
;
ONE(ABMFSCHD,ABMMLT,ABMCODE,ABMDT) ;PEP - returns charge for one code
; One of two errors may be returned with a "0"
; Fee Schedule doesn't exist
; Code not in Fee Schedule
;
; ABMFSCHD = Fee Schedule Number
; ABMMLT = What multiple to get code from; NOTE-some codes can exist
; in more than one multiple
; ABMCODE = code IEN
; ABMDT = Date of Service
;
N ABMI,ABMEDT,ABMFLG
S ABMA=""
I '$D(^ABMDFEE(ABMFSCHD)) S ABMA="0^Fee Schedule doesn't exist" Q ABMA
I ABMMLT=21 S ABMCODE=$G(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCODE,0)) ;dental
I $G(ABMCODE)="" S ABMA="0^Code not in Fee Schedule" Q ABMA
;I '$D(^ABMDFEE(ABMFSCHD,ABMMLT,"B",ABMCODE)) S ABMA="0^Code not in Fee Schedule" Q ABMA ;abm*2.6*2
;I '$D(^ABMDFEE(ABMFSCHD,ABMMLT,"B",+ABMCODE)) S ABMA="0^Code not in Fee Schedule" Q ABMA ;abm*2.6*2 ;abm*2.6*21 IHS/SD/SDR HEAT130924
;I ABMMLT'=21,'$D(^ABMDFEE(ABMFSCHD,ABMMLT,"B",+ABMCODE)) S ABMA="0^Code not in Fee Schedule" Q ABMA ;abm*2.6*21 IHS/SD/SDR HEAT130924 ;abm*2.6*27 IHS/SD/SDR CR8894
I ABMMLT=21,'$D(^ABMDFEE(ABMFSCHD,ABMMLT,1_$S(+$G(ABMR("CODE"))'=0:ABMR("CODE"),+$G(ABMZ("DCD"))'=0:ABMZ("DCD"),1:""))) S ABMA="0^Code not in Fee Schedule" Q ABMA ;abm*2.6*21 IHS/SD/SDR HEAT130924
;S ABMI=$O(^ABMDFEE(ABMFSCHD,ABMMLT,"B",ABMCODE,0)) ;abm*2.6*2
;S ABMI=$O(^ABMDFEE(ABMFSCHD,ABMMLT,"B",+ABMCODE,0)) ;abm*2.6*2 ;abm*2.6*21 IHS/SD/SDR HEAT130924
;S:(ABMMLT'=21) ABMI=$O(^ABMDFEE(ABMFSCHD,ABMMLT,"B",+ABMCODE,0)) ;abm*2.6*21 IHS/SD/SDR HEAT130924 ;abm*2.6*27 IHS/SD/SDR CR8894
;start new abm*2.6*27 IHS/SD/SDR CR8894
;S:(ABMMLT'=21) ABMI=$$DINUM^ABMFOFS($O(^ABMDFEE(ABMFSCHD,ABMMLT,"B",ABMCODE,0))) ;abm*2.6*21 IHS/SD/SDR HEAT130924 ;abm*2.6*27 IHS/SD/SDR CR8894
;I ABMMLT'=21 D Q:(+ABMA=0)
;.S ABMI=$O(^ABMDFEE(ABMFSCHD,ABMMLT,"B",ABMCODE,0))
;.I +ABMI=0 S ABMI=$O(^ABMDFEE(ABMFSCHD,ABMMLT,"C",ABMCODE,0))
;.I +ABMI=0 S ABMA="0^Code not in Fee Schedule" Q
;.S ABMI=$$DINUM^ABMFOFS(ABMI)
;I ABMMLT'=21 S ABMI=$S(+ABMCODE=0:$$DINUM^ABMFOFS(ABMCODE),1:ABMCODE)
I ABMMLT'=21 S ABMI=$S(+ABMCODE=0:$$DINUM^ABMFOFS(ABMCODE),($L(ABMCODE)'=$L(+ABMCODE)):$$DINUM^ABMFOFS(ABMCODE),1:ABMCODE)
;end new abm*2.6*27 IHS/SD/SDR CR8894
S:(ABMMLT=21) ABMI=1_$S(+$G(ABMR("CODE"))'=0:ABMR("CODE"),+$G(ABMZ("DCD"))'=0:ABMZ("DCD"),1:"") ;abm*2.6*21 IHS/SD/SDR HEAT130924
;
S ABMFDT=0,ABMEDT=0,ABMFLG=0,ABMSV=0
F S ABMFDT=$O(^ABMDFEE(ABMFSCHD,ABMMLT,ABMI,1,"B",ABMFDT)) Q:(+$G(ABMFDT)=0) D Q:(ABMFLG'=0)
.I +$G(ABMSV)=0 S ABMSV=ABMFDT
.I (ABMDT>ABMSV&(ABMDT<ABMFDT))!(ABMDT=ABMSV) D
..S ABMDIEN=$O(^ABMDFEE(ABMFSCHD,ABMMLT,ABMI,1,"B",ABMSV,0))
..S ABMFLG=1
.S ABMSV=ABMFDT
;I ABMFLG=0,(+$G(ABMSV)'=""),((ABMDT>ABMSV)!(ABMDT=ABMSV)) S ABMDIEN=$O(^ABMDFEE(ABMFSCHD,ABMMLT,ABMI,1,"B",ABMSV,0)),ABMFLG=1 ;abm*2.6*2
I ABMFLG=0,(+$G(ABMSV)'=0),((ABMDT>ABMSV)!(ABMDT=ABMSV)) S ABMDIEN=$O(^ABMDFEE(ABMFSCHD,ABMMLT,ABMI,1,"B",ABMSV,0)),ABMFLG=1 ;abm*2.6*2
I ABMFLG=0,($D(^ABMDFEE(ABMFSCHD,ABMMLT,ABMI))<11) S ABMA=+$P($G(^ABMDFEE(ABMFSCHD,ABMMLT,ABMI,0)),U,2) Q ABMA ;default to old charge ;abm*2.6*2
I ABMFLG=0 S ABMA="0^No Active Fee for requested date" Q ABMA
;
S ABMA=+$P(^ABMDFEE(ABMFSCHD,ABMMLT,ABMI,1,ABMDIEN,0),U,2)_U_+$P(^ABMDFEE(ABMFSCHD,ABMMLT,ABMI,1,ABMDIEN,0),U,3)_U_+$P(^ABMDFEE(ABMFSCHD,ABMMLT,ABMI,1,ABMDIEN,0),U,4)
I ABMA="" S ABMA=+$P($G(^ABMDFEE(ABMFSCHD,ABMMLT,ABMI,0)),U,2) ;this is the old charge amount - default just in case
I ABMA="" S ABMA="0^Code not in Fee Schedule"
Q ABMA
;
RANGE(ABMFSCHD,ABMMLT,ABMDT) ;PEP - returns range of codes with charges
; results will be put into ^TMP global
; (^TMP("ABM-FS",$J,CODE)=GLOBAL CHARGE^TECHNICAL CHARGE^PROFESSIONAL CHARGE
; One error could be returned with a "-1" for Fee Schedule doesn't exist
;
; ABMFSCHD = Fee Schedule Number
; ABMMLT = What multiple (range) of codes to return
; ABMDT = Effective Date
;
K ^TMP("ABM-FS",$J)
N ABMCODE,ABMDIEN,ABMEDT
I '$D(^ABMDFEE(ABMFSCHD)) S ^TMP("ABM-FS",$J)="0^Fee Schedule doesn't exist" Q
;start old code abm*2.6*3 FIXPMS10008
;S ABMCODE=0
;F S ABMCODE=$O(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCODE)) Q:(+$G(ABMCODE)=0) D
;.S ABMEDT=0,ABMSV=0
;.F S ABMEDT=$O(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCODE,1,"B",ABMEDT)) Q:(+$G(ABMEDT)=0) D
;..I +$G(ABMSV)=0 S ABMSV=ABMEDT
;..I ABMDT>ABMSV,(ABMDT<ABMFDT) D
;...S ABMDIEN=$O(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCODE,1,"B",ABMSV,0))
;...S ABMFLG=0
;...S ^TMP("ABM-FS",$J,ABMCODE)=+$P(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCODE,1,ABMDIEN,0),U,2)
;...S $P(^TMP("ABM-FS",$J,ABMCODE),U,2)=+$P(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCODE,1,ABMDIEN,0),U,3)
;...S $P(^TMP("ABM-FS",$J,ABMCODE),U,3)=+$P(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCODE,1,ABMDIEN,0),U,4)
;...;default to old charge amount, just in case
;...I $G(^TMP("ABM-FS",$J,ABMCODE))="" S ^TMP("ABM-FS",$J,ABMCODE)=+$P($G(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCODE,0)),U,2)
;end old code start new code FIXPMS10008
S ABMCIEN=0
F S ABMCIEN=$O(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN)) Q:(+$G(ABMCIEN)=0) D
.;S ABMFDT=0,ABMSV=0,ABMFLG=0 ;abm*2.6*8 HEAT19236
.S ABMFDT=9999999,ABMSV=9999999,ABMFLG=0 ;abm*2.6*8 HEAT19236
.;F S ABMFDT=$O(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,1,"B",ABMFDT)) Q:(+$G(ABMFDT)=0) D Q:(ABMFLG'=0) ;abm*2.6*8 HEAT19236
.F S ABMFDT=$O(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,1,"B",ABMFDT),-1) Q:(+$G(ABMFDT)=0) D Q:(ABMFLG'=0) ;abm*2.6*8 HEAT19236
..;I +$G(ABMSV)=0 S ABMSV=ABMFDT ;abm*2.6*8 HEAT19236
..;I (ABMDT>ABMSV&(ABMDT<ABMFDT))!(ABMDT=ABMSV) D ;abm*2.6*8 HEAT19236
..I (ABMFDT=ABMDT)!(ABMFDT<ABMDT) D ;abm*2.6*8 HEAT19236
...S ABMSV=$G(ABMFDT) ;abm*2.6* HEAT19236
...S ABMDIEN=$O(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,1,"B",ABMSV,0))
...S ABMFLG=1
...;S ABMSV=$G(ABMFDT) ;abm*2.6* HEAT19236
.;I ABMFLG=0,(+$G(ABMSV)'=""),((ABMDT>ABMSV)!(ABMDT=ABMSV)) S ABMDIEN=$O(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,1,"B",ABMSV,0)),ABMFLG=1 ;abm*2.6*8 HEAT19236
.I ABMFLG=0,(+$G(ABMSV)'=0),((ABMDT>ABMSV)!(ABMDT=ABMSV)) S ABMDIEN=$O(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,1,"B",ABMSV,0)),ABMFLG=1 ;abm*2.6*8 HEAT19236
.I ABMFLG=1 D
..;I "^19^11^15^17^23^13^"[("^"_ABM("CAT")_"^") S ABMCODE=$P($G(^ICPT(ABMCIEN,0)),U) ;CPTs ;abm*2.6*27 IHS/SD/SDR CR8894
..I "^19^11^15^17^23^13^"[("^"_ABMMLT_"^") S ABMCODE=$P($G(^ICPT($P($G(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,0)),U),0)),U) ;CPTs ;abm*2.6*27 IHS/SD/SDR CR8894
..;start old abm*2.6*27 IHS/SD/SDR CR8894
..;I ABM("CAT")=21 S ABMCODE=$P($G(^AUTTADA($P($G(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,0)),U),0)),U) ;dental
..;I ABM("CAT")=25 S ABMCODE=ABMCIEN ;drug - get drescription later
..;I ABM("CAT")=31 S ABMCODE=$P($G(^AUTTREVN(ABMCIEN,0)),U) ;reveue code
..;I ABM("CAT")=32 S ABMCODE=ABMCIEN ;charge master - get description later
..;end old start new abm*2.6*27 IHS/SD/SDR CR8894
..I ABMMLT=21 S ABMCODE=$P($G(^AUTTADA($P($G(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,0)),U),0)),U) ;dental
..I ABMMLT=25 S ABMCODE=ABMCIEN ;drug - get drescription later
..I ABMMLT=31 S ABMCODE=$P($G(^AUTTREVN(ABMCIEN,0)),U) ;reveue code
..I ABMMLT=32 S ABMCODE=ABMCIEN ;charge master - get description later
..;end new abm*2.6*27 IHS/SD/SDR CR8894
..Q:$G(ABMCODE)="" ;code not found in CPT file ;abm*2.6*3
..;S ^TMP("ABM-FS",$J,ABMCODE)=$S(ABM("CAT")=21:$P($G(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,0)),U),1:ABMCIEN) ;abm*2.6*27 IHS/SD/SDR CR8894
..S ^TMP("ABM-FS",$J,ABMCODE)=$S(ABMMLT=21:$P($G(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,0)),U),1:ABMCIEN) ;abm*2.6*27 IHS/SD/SDR CR8894
..S $P(^TMP("ABM-FS",$J,ABMCODE),U,2)=+$P(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,1,ABMDIEN,0),U,2)
..S $P(^TMP("ABM-FS",$J,ABMCODE),U,3)=+$P(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,1,ABMDIEN,0),U,3)
..S $P(^TMP("ABM-FS",$J,ABMCODE),U,4)=+$P(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,1,ABMDIEN,0),U,4)
..;default to old charge amount, just in case
..I $G(^TMP("ABM-FS",$J,ABMCODE))="" S ^TMP("ABM-FS",$J,ABMCODE)=+$P($G(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,0)),U,2)
.;end new code FIXPMS10008
Q
ABMFEAPI ; IHS/SD/SDR - 3P Fee Table API
+1 ;;2.6;IHS THIRD PARTY BILLING SYSTEM;**2,3,8,14,21,27**;NOV 12, 2009;Build 486
+2 ;
+3 ;IHS/SD/SDR 2.6*3 FIXPMS10008 and FIXPMS10012 Corrections to RANGE tag
+4 ;IHS/SD/SDR 2.6*21 HEAT130924 Made correction to fee lookup for dental codes.
+5 ; Was using the code to lookup in the "B" x-ref but that one is by IEN.
+6 ;IHS/SD/SDR 2.6*27 CR8894 Corrections to Range tag; all variables weren't defined and Category III codes skipped
+7 ;
ONE(ABMFSCHD,ABMMLT,ABMCODE,ABMDT) ;PEP - returns charge for one code
+1 ; One of two errors may be returned with a "0"
+2 ; Fee Schedule doesn't exist
+3 ; Code not in Fee Schedule
+4 ;
+5 ; ABMFSCHD = Fee Schedule Number
+6 ; ABMMLT = What multiple to get code from; NOTE-some codes can exist
+7 ; in more than one multiple
+8 ; ABMCODE = code IEN
+9 ; ABMDT = Date of Service
+10 ;
+11 NEW ABMI,ABMEDT,ABMFLG
+12 SET ABMA=""
+13 IF '$DATA(^ABMDFEE(ABMFSCHD))
SET ABMA="0^Fee Schedule doesn't exist"
QUIT ABMA
+14 ;dental
IF ABMMLT=21
SET ABMCODE=$GET(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCODE,0))
+15 IF $GET(ABMCODE)=""
SET ABMA="0^Code not in Fee Schedule"
QUIT ABMA
+16 ;I '$D(^ABMDFEE(ABMFSCHD,ABMMLT,"B",ABMCODE)) S ABMA="0^Code not in Fee Schedule" Q ABMA ;abm*2.6*2
+17 ;I '$D(^ABMDFEE(ABMFSCHD,ABMMLT,"B",+ABMCODE)) S ABMA="0^Code not in Fee Schedule" Q ABMA ;abm*2.6*2 ;abm*2.6*21 IHS/SD/SDR HEAT130924
+18 ;I ABMMLT'=21,'$D(^ABMDFEE(ABMFSCHD,ABMMLT,"B",+ABMCODE)) S ABMA="0^Code not in Fee Schedule" Q ABMA ;abm*2.6*21 IHS/SD/SDR HEAT130924 ;abm*2.6*27 IHS/SD/SDR CR8894
+19 ;abm*2.6*21 IHS/SD/SDR HEAT130924
IF ABMMLT=21
IF '$DATA(^ABMDFEE(ABMFSCHD,ABMMLT,1_$SELECT(+$GET(ABMR("CODE"))'=0:ABMR("CODE"),+$GET(ABMZ("DCD"))'=0:ABMZ("DCD"),1:"")))
SET ABMA="0^Code not in Fee Schedule"
QUIT ABMA
+20 ;S ABMI=$O(^ABMDFEE(ABMFSCHD,ABMMLT,"B",ABMCODE,0)) ;abm*2.6*2
+21 ;S ABMI=$O(^ABMDFEE(ABMFSCHD,ABMMLT,"B",+ABMCODE,0)) ;abm*2.6*2 ;abm*2.6*21 IHS/SD/SDR HEAT130924
+22 ;S:(ABMMLT'=21) ABMI=$O(^ABMDFEE(ABMFSCHD,ABMMLT,"B",+ABMCODE,0)) ;abm*2.6*21 IHS/SD/SDR HEAT130924 ;abm*2.6*27 IHS/SD/SDR CR8894
+23 ;start new abm*2.6*27 IHS/SD/SDR CR8894
+24 ;S:(ABMMLT'=21) ABMI=$$DINUM^ABMFOFS($O(^ABMDFEE(ABMFSCHD,ABMMLT,"B",ABMCODE,0))) ;abm*2.6*21 IHS/SD/SDR HEAT130924 ;abm*2.6*27 IHS/SD/SDR CR8894
+25 ;I ABMMLT'=21 D Q:(+ABMA=0)
+26 ;.S ABMI=$O(^ABMDFEE(ABMFSCHD,ABMMLT,"B",ABMCODE,0))
+27 ;.I +ABMI=0 S ABMI=$O(^ABMDFEE(ABMFSCHD,ABMMLT,"C",ABMCODE,0))
+28 ;.I +ABMI=0 S ABMA="0^Code not in Fee Schedule" Q
+29 ;.S ABMI=$$DINUM^ABMFOFS(ABMI)
+30 ;I ABMMLT'=21 S ABMI=$S(+ABMCODE=0:$$DINUM^ABMFOFS(ABMCODE),1:ABMCODE)
+31 IF ABMMLT'=21
SET ABMI=$SELECT(+ABMCODE=0:$$DINUM^ABMFOFS(ABMCODE),($LENGTH(ABMCODE)'=$LENGTH(+ABMCODE)):$$DINUM^ABMFOFS(ABMCODE),1:ABMCODE)
+32 ;end new abm*2.6*27 IHS/SD/SDR CR8894
+33 ;abm*2.6*21 IHS/SD/SDR HEAT130924
IF (ABMMLT=21)
SET ABMI=1_$SELECT(+$GET(ABMR("CODE"))'=0:ABMR("CODE"),+$GET(ABMZ("DCD"))'=0:ABMZ("DCD"),1:"")
+34 ;
+35 SET ABMFDT=0
SET ABMEDT=0
SET ABMFLG=0
SET ABMSV=0
+36 FOR
SET ABMFDT=$ORDER(^ABMDFEE(ABMFSCHD,ABMMLT,ABMI,1,"B",ABMFDT))
IF (+$GET(ABMFDT)=0)
QUIT
Begin DoDot:1
+37 IF +$GET(ABMSV)=0
SET ABMSV=ABMFDT
+38 IF (ABMDT>ABMSV&(ABMDT<ABMFDT))!(ABMDT=ABMSV)
Begin DoDot:2
+39 SET ABMDIEN=$ORDER(^ABMDFEE(ABMFSCHD,ABMMLT,ABMI,1,"B",ABMSV,0))
+40 SET ABMFLG=1
End DoDot:2
+41 SET ABMSV=ABMFDT
End DoDot:1
IF (ABMFLG'=0)
QUIT
+42 ;I ABMFLG=0,(+$G(ABMSV)'=""),((ABMDT>ABMSV)!(ABMDT=ABMSV)) S ABMDIEN=$O(^ABMDFEE(ABMFSCHD,ABMMLT,ABMI,1,"B",ABMSV,0)),ABMFLG=1 ;abm*2.6*2
+43 ;abm*2.6*2
IF ABMFLG=0
IF (+$GET(ABMSV)'=0)
IF ((ABMDT>ABMSV)!(ABMDT=ABMSV))
SET ABMDIEN=$ORDER(^ABMDFEE(ABMFSCHD,ABMMLT,ABMI,1,"B",ABMSV,0))
SET ABMFLG=1
+44 ;default to old charge ;abm*2.6*2
IF ABMFLG=0
IF ($DATA(^ABMDFEE(ABMFSCHD,ABMMLT,ABMI))<11)
SET ABMA=+$PIECE($GET(^ABMDFEE(ABMFSCHD,ABMMLT,ABMI,0)),U,2)
QUIT ABMA
+45 IF ABMFLG=0
SET ABMA="0^No Active Fee for requested date"
QUIT ABMA
+46 ;
+47 SET ABMA=+$PIECE(^ABMDFEE(ABMFSCHD,ABMMLT,ABMI,1,ABMDIEN,0),U,2)_U_+$PIECE(^ABMDFEE(ABMFSCHD,ABMMLT,ABMI,1,ABMDIEN,0),U,3)_U_+$PIECE(^ABMDFEE(ABMFSCHD,ABMMLT,ABMI,1,ABMDIEN,0),U,4)
+48 ;this is the old charge amount - default just in case
IF ABMA=""
SET ABMA=+$PIECE($GET(^ABMDFEE(ABMFSCHD,ABMMLT,ABMI,0)),U,2)
+49 IF ABMA=""
SET ABMA="0^Code not in Fee Schedule"
+50 QUIT ABMA
+51 ;
RANGE(ABMFSCHD,ABMMLT,ABMDT) ;PEP - returns range of codes with charges
+1 ; results will be put into ^TMP global
+2 ; (^TMP("ABM-FS",$J,CODE)=GLOBAL CHARGE^TECHNICAL CHARGE^PROFESSIONAL CHARGE
+3 ; One error could be returned with a "-1" for Fee Schedule doesn't exist
+4 ;
+5 ; ABMFSCHD = Fee Schedule Number
+6 ; ABMMLT = What multiple (range) of codes to return
+7 ; ABMDT = Effective Date
+8 ;
+9 KILL ^TMP("ABM-FS",$JOB)
+10 NEW ABMCODE,ABMDIEN,ABMEDT
+11 IF '$DATA(^ABMDFEE(ABMFSCHD))
SET ^TMP("ABM-FS",$JOB)="0^Fee Schedule doesn't exist"
QUIT
+12 ;start old code abm*2.6*3 FIXPMS10008
+13 ;S ABMCODE=0
+14 ;F S ABMCODE=$O(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCODE)) Q:(+$G(ABMCODE)=0) D
+15 ;.S ABMEDT=0,ABMSV=0
+16 ;.F S ABMEDT=$O(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCODE,1,"B",ABMEDT)) Q:(+$G(ABMEDT)=0) D
+17 ;..I +$G(ABMSV)=0 S ABMSV=ABMEDT
+18 ;..I ABMDT>ABMSV,(ABMDT<ABMFDT) D
+19 ;...S ABMDIEN=$O(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCODE,1,"B",ABMSV,0))
+20 ;...S ABMFLG=0
+21 ;...S ^TMP("ABM-FS",$J,ABMCODE)=+$P(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCODE,1,ABMDIEN,0),U,2)
+22 ;...S $P(^TMP("ABM-FS",$J,ABMCODE),U,2)=+$P(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCODE,1,ABMDIEN,0),U,3)
+23 ;...S $P(^TMP("ABM-FS",$J,ABMCODE),U,3)=+$P(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCODE,1,ABMDIEN,0),U,4)
+24 ;...;default to old charge amount, just in case
+25 ;...I $G(^TMP("ABM-FS",$J,ABMCODE))="" S ^TMP("ABM-FS",$J,ABMCODE)=+$P($G(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCODE,0)),U,2)
+26 ;end old code start new code FIXPMS10008
+27 SET ABMCIEN=0
+28 FOR
SET ABMCIEN=$ORDER(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN))
IF (+$GET(ABMCIEN)=0)
QUIT
Begin DoDot:1
+29 ;S ABMFDT=0,ABMSV=0,ABMFLG=0 ;abm*2.6*8 HEAT19236
+30 ;abm*2.6*8 HEAT19236
SET ABMFDT=9999999
SET ABMSV=9999999
SET ABMFLG=0
+31 ;F S ABMFDT=$O(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,1,"B",ABMFDT)) Q:(+$G(ABMFDT)=0) D Q:(ABMFLG'=0) ;abm*2.6*8 HEAT19236
+32 ;abm*2.6*8 HEAT19236
FOR
SET ABMFDT=$ORDER(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,1,"B",ABMFDT),-1)
IF (+$GET(ABMFDT)=0)
QUIT
Begin DoDot:2
+33 ;I +$G(ABMSV)=0 S ABMSV=ABMFDT ;abm*2.6*8 HEAT19236
+34 ;I (ABMDT>ABMSV&(ABMDT<ABMFDT))!(ABMDT=ABMSV) D ;abm*2.6*8 HEAT19236
+35 ;abm*2.6*8 HEAT19236
IF (ABMFDT=ABMDT)!(ABMFDT<ABMDT)
Begin DoDot:3
+36 ;abm*2.6* HEAT19236
SET ABMSV=$GET(ABMFDT)
+37 SET ABMDIEN=$ORDER(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,1,"B",ABMSV,0))
+38 SET ABMFLG=1
+39 ;S ABMSV=$G(ABMFDT) ;abm*2.6* HEAT19236
End DoDot:3
End DoDot:2
IF (ABMFLG'=0)
QUIT
+40 ;I ABMFLG=0,(+$G(ABMSV)'=""),((ABMDT>ABMSV)!(ABMDT=ABMSV)) S ABMDIEN=$O(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,1,"B",ABMSV,0)),ABMFLG=1 ;abm*2.6*8 HEAT19236
+41 ;abm*2.6*8 HEAT19236
IF ABMFLG=0
IF (+$GET(ABMSV)'=0)
IF ((ABMDT>ABMSV)!(ABMDT=ABMSV))
SET ABMDIEN=$ORDER(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,1,"B",ABMSV,0))
SET ABMFLG=1
+42 IF ABMFLG=1
Begin DoDot:2
+43 ;I "^19^11^15^17^23^13^"[("^"_ABM("CAT")_"^") S ABMCODE=$P($G(^ICPT(ABMCIEN,0)),U) ;CPTs ;abm*2.6*27 IHS/SD/SDR CR8894
+44 ;CPTs ;abm*2.6*27 IHS/SD/SDR CR8894
IF "^19^11^15^17^23^13^"[("^"_ABMMLT_"^")
SET ABMCODE=$PIECE($GET(^ICPT($PIECE($GET(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,0)),U),0)),U)
+45 ;start old abm*2.6*27 IHS/SD/SDR CR8894
+46 ;I ABM("CAT")=21 S ABMCODE=$P($G(^AUTTADA($P($G(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,0)),U),0)),U) ;dental
+47 ;I ABM("CAT")=25 S ABMCODE=ABMCIEN ;drug - get drescription later
+48 ;I ABM("CAT")=31 S ABMCODE=$P($G(^AUTTREVN(ABMCIEN,0)),U) ;reveue code
+49 ;I ABM("CAT")=32 S ABMCODE=ABMCIEN ;charge master - get description later
+50 ;end old start new abm*2.6*27 IHS/SD/SDR CR8894
+51 ;dental
IF ABMMLT=21
SET ABMCODE=$PIECE($GET(^AUTTADA($PIECE($GET(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,0)),U),0)),U)
+52 ;drug - get drescription later
IF ABMMLT=25
SET ABMCODE=ABMCIEN
+53 ;reveue code
IF ABMMLT=31
SET ABMCODE=$PIECE($GET(^AUTTREVN(ABMCIEN,0)),U)
+54 ;charge master - get description later
IF ABMMLT=32
SET ABMCODE=ABMCIEN
+55 ;end new abm*2.6*27 IHS/SD/SDR CR8894
+56 ;code not found in CPT file ;abm*2.6*3
IF $GET(ABMCODE)=""
QUIT
+57 ;S ^TMP("ABM-FS",$J,ABMCODE)=$S(ABM("CAT")=21:$P($G(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,0)),U),1:ABMCIEN) ;abm*2.6*27 IHS/SD/SDR CR8894
+58 ;abm*2.6*27 IHS/SD/SDR CR8894
SET ^TMP("ABM-FS",$JOB,ABMCODE)=$SELECT(ABMMLT=21:$PIECE($GET(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,0)),U),1:ABMCIEN)
+59 SET $PIECE(^TMP("ABM-FS",$JOB,ABMCODE),U,2)=+$PIECE(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,1,ABMDIEN,0),U,2)
+60 SET $PIECE(^TMP("ABM-FS",$JOB,ABMCODE),U,3)=+$PIECE(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,1,ABMDIEN,0),U,3)
+61 SET $PIECE(^TMP("ABM-FS",$JOB,ABMCODE),U,4)=+$PIECE(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,1,ABMDIEN,0),U,4)
+62 ;default to old charge amount, just in case
+63 IF $GET(^TMP("ABM-FS",$JOB,ABMCODE))=""
SET ^TMP("ABM-FS",$JOB,ABMCODE)=+$PIECE($GET(^ABMDFEE(ABMFSCHD,ABMMLT,ABMCIEN,0)),U,2)
End DoDot:2
+64 ;end new code FIXPMS10008
End DoDot:1
+65 QUIT
