- 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
