ABMFCPT ; IHS/ASDST/DMJ - FILE CPT CODE ;
;;2.6;IHS Third Party Billing System;**2,11,27**;NOV 12, 2009;Build 486
;
;IHS/ASDS/JLG 01/23/01 2.4*3 NOIS NEA-0600-18022 Modified routine to fix problem with provider narrative not showing up.
;IHS/ASDS/SDH 04/26/01 2.4*9 NOIS DXX-0400-140004 Allow quantity to pass from PCC to 3PB when the CPT mnuemonic is used.
;IHS/ASDS/LSL 07/03/01 2.4*9 NOIS NEA-0600-180021 Modified to allow Pathology, Cytology, and Blood Bank CPT's
; entered through CPT mnuemonic in PCC to pass to 3PB. Thanks to Jim Gray for the code.
;
;IHS/SD/SDR 11/4/02 2.5*2 ZZZ-0301-210046 Modified to capture modifiers from PCC
;IHS/SD/SDR 2.5*8 Added code so A0000-A0999 would go to page 8K if ambulance
;IHS/SD/SDR 2.5*10 IM21095 Removed VRAD check for unit; it should always be 1
;
;IHS/SD/SDR v2.6 CSV
;IHS/SD/SDR 2.6*2 3PMS10003A modified to call ABMFEAPI
;IHS/SD/SDR 2.8*27 CR8894 Made correction to ABMFEAPI call to use CPT (not IEN); API does cross reference look up on CPT code
; *********************************************************************
;
START ;FILE ONE CPT CODE
;NEEDS ABMCPT (CPT CODE), ABMSDT (SERVICE DATE/TIME),
;ABMSRC (DATA SOURCE), AND DA(1) OR ABMP("CDFN")) DEFINED
;This is written to work for Anesthesiology, surgery, radiology, lab
;Two lines of code were added to the surgery subrtn to add the priority
;field. JLG 4/9/98
N ABMCTG,DXPTR,ABMCPTIE,ABMUNIT
S:'$G(ABMP("FEE")) ABMP("FEE")=1
S:'$G(DA(1)) DA(1)=ABMP("CDFN")
D
.;I '+ABMCPT D HCPCS Q
.I (ABMCPT<100)!(ABMCPT?.5N1.6A.5N)!($L(ABMCPT)=6) D HCPCS Q
.I +ABMCPT<10000 D ANES Q
.I +ABMCPT<70000 D SURG Q
.I +ABMCPT<80000 D RAD Q
.I +ABMCPT<90000 D LAB Q
.D MED
K ABMCPT,ABMSRC,ABMRVN,DIC,DIE,DR,X,Y,ABMUNIT
Q
ANES ;ANESTHESIA CODE
N QUIT,VFILE,VIEN
I ABMCPT>9999 D Q:QUIT
.S QUIT=1
.S VFILE=$P(AUPNCPT(N),U,4)
.I VFILE'=9000010.08 Q
.S VIEN=$P(AUPNCPT(N),U,5)
.S A=$P(^AUPNVPRC(VIEN,0),U,14)
.I A S QUIT=0 Q ;Don't quit if anesth admin
.E S QUIT=1 Q
S ABMCTG=39 D EDIT Q:+Y<0
S:'ABMRVN ABMRVN=370
S DR=DR_";.02////"_ABMRVN
;S DR=DR_";.04////"_$P($G(^ABMDFEE(ABMP("FEE"),23,+ABMCPT,0)),"^",2) ;abm*2.6*2 3PMS10003A
;S DR=DR_";.04////"_$P($$ONE^ABMFEAPI(ABMP("FEE"),23,+ABMCPT,ABMP("VDT")),U) ;abm*2.6*2 3PMS10003A ;abm*2.6*27 IHS/SD/SDR CR8894
S DR=DR_";.04////"_$P($$ONE^ABMFEAPI(ABMP("FEE"),23,ABMCPT,ABMP("VDT")),U) ;abm*2.6*2 3PMS10003A ;abm*2.6*27 IHS/SD/SDR CR8894
S DR=DR_";.05////"_ABMSDT
S DR=DR_";.06////"_ABMMOD1
S DR=DR_";.07////"_ABMAST ;Anes. start dt/tm abm*2.6*11 HEAT83923
S DR=DR_";.08////"_ABMAET ;Anes. end dt/tm abm*2.6*11 HEAT83923
;Next line set correspond diagnosis if only 1 POV
I $D(ABMP("CORRSDIAG")) S DR=DR_";.1////1"
S DR=DR_";.17////"_ABMSRC
D ^DIE
Q
SURG ;SURGICAL CODE
S ABMCTG=21 D EDIT Q:+Y<0
S ABMSRGPR=$G(ABMSRGPR)+1
S:'ABMRVN ABMRVN=960
N ABMPNARR,ABMINDXP
S ABMPNARR=$$GET1^DIQ($P(AUPNCPT(N),U,4),ABMDA_",",.04,"I")
I 'ABMPNARR S ABMPNARR=$P(AUPNCPT(N),U,2)
S ABMPNARR=$TR(ABMPNARR,";",",")
S DR=DR_";.02////"_ABMSRGPR
S DR=DR_";.03////"_ABMRVN
S DR=DR_";.05////"_ABMSDT
I ABMPNARR S DR=DR_";.06////"_ABMPNARR
E I ABMPNARR]"" S DR=DR_";.06///"_ABMPNARR
;S DR=DR_";.07////"_+$P($G(^ABMDFEE(ABMP("FEE"),11,ABMCPT,0)),"^",2) ;abm*2.6*2 3PMS10003A
S DR=DR_";.07////"_+$P($$ONE^ABMFEAPI(ABMP("FEE"),11,ABMCPT,ABMP("VDT")),U) ;abm*2.6*2 3PMS10003A
S ABMUNIT=$P($G(^AUPNVCPT(ABMDA,0)),U,16)
I +ABMUNIT=0 S ABMUNIT=1
S DR=DR_";.09////"_ABMMOD1
S DR=DR_";.11////"_ABMMOD2
S DR=DR_";.13////"_ABMUNIT
S DR=DR_";.17////"_ABMSRC
I $D(ABMCORDI(ABMCPT)) D
.Q:'$D(^ABMDCLM(DUZ(2),ABMP("CDFN"),17,ABMCORDI(ABMCPT),0))
.S DXPTR=$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),17,ABMCORDI(ABMCPT),0),U,2)
.S ABMINDXP=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),17,"C",""))
.S DR=DR_";.04////"_(DXPTR-ABMINDXP+1)
;Next line set correspond diagnosis if only 1 POV
E I $D(ABMP("CORRSDIAG")) S DR=DR_";.04////1"
D ^DIE
D ANES
Q
;
RAD ;RADIOLOGY
S ABMCTG=35 D EDIT Q:+Y<0
S:'ABMRVN ABMRVN=320
S DR=DR_";.02////"_ABMRVN
S ABMUNIT=1
S DR=DR_";.03////"_ABMUNIT
;S DR=DR_";.04////"_$P($G(^ABMDFEE(ABMP("FEE"),15,ABMCPT,0)),"^",2) ;abm*2.6*2 3PMS10003A
S DR=DR_";.04////"_$P($$ONE^ABMFEAPI(ABMP("FEE"),15,ABMCPT,ABMP("VDT")),U) ;abm*2.6*2 3PMS10003A
S DR=DR_";.05////"_ABMMOD1
S DR=DR_";.06////"_ABMMOD2
;Next line set correspond diagnosis if only 1 POV
I $D(ABMP("CORRSDIAG")) S DR=DR_";.08////1"
S DR=DR_";.09////"_ABMSDT
S DR=DR_";.17////"_ABMSRC
D ^DIE
Q
;
MED ;MEDICAL CODE
S ABMCTG=27 D EDIT Q:+Y<0
S:'ABMRVN ABMRVN=510
S DR=DR_";.02////"_ABMRVN
S ABMUNIT=$P($G(^AUPNVCPT(ABMDA,0)),U,16)
I +ABMUNIT=0 S ABMUNIT=1
S DR=DR_";.03////"_ABMUNIT
;S DR=DR_";.04////"_$P($G(^ABMDFEE(ABMP("FEE"),19,ABMCPT,0)),"^",2) ;abm*2.6*2 3PMS10003A
S DR=DR_";.04////"_$P($$ONE^ABMFEAPI(ABMP("FEE"),19,ABMCPT,ABMP("VDT")),U) ;abm*2.6*2 3PMS10003A
S DR=DR_";.05////"_ABMMOD1
S DR=DR_";.08////"_ABMMOD2
;Next line set correspond diagnosis if only 1 POV
I $D(ABMP("CORRSDIAG")) S DR=DR_";.06////1"
S DR=DR_";.07////"_ABMSDT
S DR=DR_";.17////"_ABMSRC
D ^DIE
Q
;
HCPCS ;HCPCS CODE
S XTLKUT=""
S ABMCTG=$S(ABMCPT]]"A0000"&(ABMCPT']]"A0999"):47,1:43) D EDIT Q:+Y<0
I ABMRVN="" D
.I $E(ABMCPT,1,2)="A0" S ABMRVN=540 Q
.I $E(ABMCPT)="E" S ABMRVN=290 Q
.I $E(ABMCPT)="J" S ABMRVN=250 Q
.I $E(ABMCPT)="K" S ABMRVN=290 Q
.I $E(ABMCPT,1,3)="L86" S ABMRVN=274 Q
.I $E(ABMCPT,1,2)="P9" S ABMRVN=300 Q
.S ABMRVN=270
S DR=DR_";.02////"_ABMRVN
S ABMUNIT=$P($G(^AUPNVCPT(ABMDA,0)),U,16)
I +ABMUNIT=0 S ABMUNIT=1
S DR=DR_";.03////"_ABMUNIT
;S DR=DR_";.04////"_$P($G(^ABMDFEE(ABMP("FEE"),13,ABMCPTIE,0)),"^",2) ;abm*2.6*2 3PMS10003A
;S DR=DR_";.04////"_$P($$ONE^ABMFEAPI(ABMP("FEE"),13,ABMCPTIE,ABMP("VDT")),U) ;abm*2.6*2 3PMS10003A ;abm*2.6*27 IHS/SD/SDR CR8894
S DR=DR_";.04////"_$P($$ONE^ABMFEAPI(ABMP("FEE"),13,ABMCPT,ABMP("VDT")),U) ;abm*2.6*2 3PMS10003A ;abm*2.6*27 IHS/SD/SDR CR8894
S DR=DR_";.05////"_ABMMOD1
;Next line set correspond diagnosis if only 1 POV
I $D(ABMP("CORRSDIAG")) S DR=DR_";.06////1"
S DR=DR_";.07////"_ABMSDT
S DR=DR_";.08////"_ABMMOD2
S DR=DR_";.17////"_ABMSRC
D ^DIE
K XTLKUT
Q
;
LAB ;
I '$D(ABMCPTTB("LAB")) D
.S ABMIEN=0
.F I=1:1 S ABMIEN=$O(^ABMDCPT("C","LAB",ABMIEN)) Q:'ABMIEN D
..S ABMCPTTB("LAB",I)=$P(^ABMDCPT(ABMIEN,0),U,4,5)
S ABMOK=0
S I=0
F S I=$O(ABMCPTTB("LAB",I)) Q:'I D Q:ABMOK
.I ABMCPT'<$P(ABMCPTTB("LAB",I),U)&(ABMCPT'>$P(ABMCPTTB("LAB",I),U,2)) S ABMOK=1
Q:'ABMOK
S ABMFILE=$P(AUPNCPT(N),U,4)
S ABMIENS=ABMDA_","
I ABMFILE=9000010.18 D
.S ABMFLD1=.08
.S ABMFLD2=.09
E I ABMFILE=9000010.08 D
.S ABMFLD1=.17
.S ABMFLD2=.18
E I ABMFILE=9000010.22 D
.S ABMFLD1=.07
.S ABMFLD2=.08
E K ABMFLD1,ABMFLD2
S ABMMOD(1)=$$GET1^DIQ(ABMFILE,ABMIENS,ABMFLD1)
I ABMMOD(1)]"" S ABMMOD(2)=$$GET1^DIQ(ABMFILE,ABMIENS,ABMFLD2)
E K ABMMOD(1)
I ABMFILE=9000010.18 S ABMUNITS=$$GET1^DIQ(ABMFILE,ABMIENS,.16)
E S ABMUNITS=1
S:ABMUNITS<1 ABMUNITS=1
S ABMCOLDT=$$GET1^DIQ(ABMFILE,ABMIENS,1201,"I")
S:ABMCOLDT<2000101 ABMCOLDT=ABMCHVDT
S ABMREVCD=$P($$IHSCPT^ABMCVAPI(ABMCPT,ABMP("VDT")),U,3) ;CSV-c
I 'ABMREVCD D
.N ABMCPTCT
.S ABMCPTCT=$P($$CPT^ABMCVAPI(ABMCPT,ABMP("VDT")),U,4) ;CSV-c
.Q:'ABMCPTCT
.S ABMREVCD=$P($$IHSCAT^ABMCVAPI(ABMCPTCT,ABMP("VDT")),U) ;CSV-c
S:'ABMREVCD ABMREVCD=300
;S FEE=$P($G(^ABMDFEE(+ABMP("FEE"),17,ABMCPT,0)),U,2) ;abm*2.6*2 3PMS10003A
S FEE=$P($$ONE^ABMFEAPI(+ABMP("FEE"),17,ABMCPT,ABMP("VDT")),U) ;abm*2.6*2 3PMS10003A
K DIC,DD,DO
S X=ABMCPT
S DIC="^ABMDCLM("_DUZ(2)_","_ABMP("CDFN")_",37,"
S DIC("DR")=".02////"_ABMREVCD
S DIC("DR")=DIC("DR")_";.03////"_ABMUNITS
S DIC("DR")=DIC("DR")_";.04////"_FEE
S DIC("DR")=DIC("DR")_";.05////"_ABMCOLDT
S DIC("DR")=DIC("DR")_";.06////"_ABMMOD1
S DIC("DR")=DIC("DR")_";.07////"_ABMMOD2
S DIC("DR")=DIC("DR")_";.17////"_ABMSRC
I $D(ABMP("CORRSDIAG")) S DIC("DR")=DIC("DR")_";.09////1"
I $D(ABMMOD) F J=1:1:2 Q:'$D(ABMMOD(J)) D
.S DIC("DR")=DIC("DR")_";"_((5+J)/100)_"////"_ABMMOD(J)
S DA=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),"ASRC",ABMSRC,0))
I DA,'$D(@(DIC_DA_",0)")) S DA="" ;For duplicates problem
S DA(1)=ABMP("CDFN")
I DA>0 D
.K DR
.S DIE=DIC
.S DR=".01///"_X_";"_DIC("DR")
.D ^DIE
E D
.S DIC(0)="LE"
.S DIC("P")=$P(^DD(9002274.3,37,0),U,2)
.K DD,DO
.K DD,DO D FILE^DICN
Q
EDIT ;EDIT EXISTING ENTRY
N ABM1,ABMY,P
K DIC,DIE
S (DIC,DIE)="^ABMDCLM(DUZ(2),DA(1),ABMCTG,"
;S ABMCPTIE=$O(^ICPT("B",ABMCPT,0)) ;abm*2.6*11 HEAT94153
S ABMCPTIE=$P(AUPNCPT(N),U,3) ;abm*2.6*11 HEAT94153
S ABMRVN=$P($$IHSCPT^ABMCVAPI(+ABMCPTIE,ABMP("VDT")),U,3) ;CSV-c
S DA=$O(^ABMDCLM(DUZ(2),DA(1),"ASRC",ABMSRC,0))
I DA,'$D(@(DIC_DA_",0)")) S DA="" ;For duplicates problem
N XREF
I DA,(ABMCTG=21)!(ABMCTG=39) D
.S XREF="ASRC"_$S(ABMCTG=21:"S",1:"A")
.I $D(^ABMDCLM(DUZ(2),DA(1),ABMCTG,XREF,ABMSRC,DA)) Q
.S DA=""
I DA="" D
.S ABM1=0
.F S ABM1=$O(^ABMDCLM(DUZ(2),DA(1),ABMCTG,ABM1)) Q:'ABM1 D Q:DA]""
..;If this finds an old entry with no source field
..; and it matches DA is set and new record not created.
..; and no match a new entry is created and DA defined
..;If no old entry a new record is created and DA defined
..;If all old entries have source field new record created & DA defined
..S ABMY=$G(^ABMDCLM(DUZ(2),DA(1),ABMCTG,ABM1,0))
..Q:$P(ABMY,U,17)]""
..S P=$S(ABMCTG=21!(ABMCTG=39):5,ABMCTG=35:9,1:7)
..I ABMCPTIE=+ABMY,ABMSDT=$P(ABMY,U,P) S DA=ABM1 Q
.Q:DA]""
.I (ABMCTG=21)!(ABMCTG=39) D Q:DA]""
..S XREF="ASRC"_$S(ABMCTG=21:"S",1:"A")
..S DA=$O(^ABMDCLM(DUZ(2),DA(1),ABMCTG,XREF,ABMSRC,DA))
.D ADD
S Y=$G(Y)
S DR=".01////"_ABMCPTIE
Q
;
ADD ;SET ZERO NODE AND DIC
S:'$D(^ABMDCLM(DUZ(2),DA(1),ABMCTG,0)) ^(0)="^9002274.30"_ABMCTG_"P^^"
S X=ABMCPTIE
S DIC(0)="LXE"
K DD,DO,DINUM D FILE^DICN
S DA=+Y
Q
ABMFCPT ; IHS/ASDST/DMJ - FILE CPT CODE ;
+1 ;;2.6;IHS Third Party Billing System;**2,11,27**;NOV 12, 2009;Build 486
+2 ;
+3 ;IHS/ASDS/JLG 01/23/01 2.4*3 NOIS NEA-0600-18022 Modified routine to fix problem with provider narrative not showing up.
+4 ;IHS/ASDS/SDH 04/26/01 2.4*9 NOIS DXX-0400-140004 Allow quantity to pass from PCC to 3PB when the CPT mnuemonic is used.
+5 ;IHS/ASDS/LSL 07/03/01 2.4*9 NOIS NEA-0600-180021 Modified to allow Pathology, Cytology, and Blood Bank CPT's
+6 ; entered through CPT mnuemonic in PCC to pass to 3PB. Thanks to Jim Gray for the code.
+7 ;
+8 ;IHS/SD/SDR 11/4/02 2.5*2 ZZZ-0301-210046 Modified to capture modifiers from PCC
+9 ;IHS/SD/SDR 2.5*8 Added code so A0000-A0999 would go to page 8K if ambulance
+10 ;IHS/SD/SDR 2.5*10 IM21095 Removed VRAD check for unit; it should always be 1
+11 ;
+12 ;IHS/SD/SDR v2.6 CSV
+13 ;IHS/SD/SDR 2.6*2 3PMS10003A modified to call ABMFEAPI
+14 ;IHS/SD/SDR 2.8*27 CR8894 Made correction to ABMFEAPI call to use CPT (not IEN); API does cross reference look up on CPT code
+15 ; *********************************************************************
+16 ;
START ;FILE ONE CPT CODE
+1 ;NEEDS ABMCPT (CPT CODE), ABMSDT (SERVICE DATE/TIME),
+2 ;ABMSRC (DATA SOURCE), AND DA(1) OR ABMP("CDFN")) DEFINED
+3 ;This is written to work for Anesthesiology, surgery, radiology, lab
+4 ;Two lines of code were added to the surgery subrtn to add the priority
+5 ;field. JLG 4/9/98
+6 NEW ABMCTG,DXPTR,ABMCPTIE,ABMUNIT
+7 IF '$GET(ABMP("FEE"))
SET ABMP("FEE")=1
+8 IF '$GET(DA(1))
SET DA(1)=ABMP("CDFN")
+9 Begin DoDot:1
+10 ;I '+ABMCPT D HCPCS Q
+11 IF (ABMCPT<100)!(ABMCPT?.5N1.6A.5N)!($LENGTH(ABMCPT)=6)
DO HCPCS
QUIT
+12 IF +ABMCPT<10000
DO ANES
QUIT
+13 IF +ABMCPT<70000
DO SURG
QUIT
+14 IF +ABMCPT<80000
DO RAD
QUIT
+15 IF +ABMCPT<90000
DO LAB
QUIT
+16 DO MED
End DoDot:1
+17 KILL ABMCPT,ABMSRC,ABMRVN,DIC,DIE,DR,X,Y,ABMUNIT
+18 QUIT
ANES ;ANESTHESIA CODE
+1 NEW QUIT,VFILE,VIEN
+2 IF ABMCPT>9999
Begin DoDot:1
+3 SET QUIT=1
+4 SET VFILE=$PIECE(AUPNCPT(N),U,4)
+5 IF VFILE'=9000010.08
QUIT
+6 SET VIEN=$PIECE(AUPNCPT(N),U,5)
+7 SET A=$PIECE(^AUPNVPRC(VIEN,0),U,14)
+8 ;Don't quit if anesth admin
IF A
SET QUIT=0
QUIT
+9 IF '$TEST
SET QUIT=1
QUIT
End DoDot:1
IF QUIT
QUIT
+10 SET ABMCTG=39
DO EDIT
IF +Y<0
QUIT
+11 IF 'ABMRVN
SET ABMRVN=370
+12 SET DR=DR_";.02////"_ABMRVN
+13 ;S DR=DR_";.04////"_$P($G(^ABMDFEE(ABMP("FEE"),23,+ABMCPT,0)),"^",2) ;abm*2.6*2 3PMS10003A
+14 ;S DR=DR_";.04////"_$P($$ONE^ABMFEAPI(ABMP("FEE"),23,+ABMCPT,ABMP("VDT")),U) ;abm*2.6*2 3PMS10003A ;abm*2.6*27 IHS/SD/SDR CR8894
+15 ;abm*2.6*2 3PMS10003A ;abm*2.6*27 IHS/SD/SDR CR8894
SET DR=DR_";.04////"_$PIECE($$ONE^ABMFEAPI(ABMP("FEE"),23,ABMCPT,ABMP("VDT")),U)
+16 SET DR=DR_";.05////"_ABMSDT
+17 SET DR=DR_";.06////"_ABMMOD1
+18 ;Anes. start dt/tm abm*2.6*11 HEAT83923
SET DR=DR_";.07////"_ABMAST
+19 ;Anes. end dt/tm abm*2.6*11 HEAT83923
SET DR=DR_";.08////"_ABMAET
+20 ;Next line set correspond diagnosis if only 1 POV
+21 IF $DATA(ABMP("CORRSDIAG"))
SET DR=DR_";.1////1"
+22 SET DR=DR_";.17////"_ABMSRC
+23 DO ^DIE
+24 QUIT
SURG ;SURGICAL CODE
+1 SET ABMCTG=21
DO EDIT
IF +Y<0
QUIT
+2 SET ABMSRGPR=$GET(ABMSRGPR)+1
+3 IF 'ABMRVN
SET ABMRVN=960
+4 NEW ABMPNARR,ABMINDXP
+5 SET ABMPNARR=$$GET1^DIQ($PIECE(AUPNCPT(N),U,4),ABMDA_",",.04,"I")
+6 IF 'ABMPNARR
SET ABMPNARR=$PIECE(AUPNCPT(N),U,2)
+7 SET ABMPNARR=$TRANSLATE(ABMPNARR,";",",")
+8 SET DR=DR_";.02////"_ABMSRGPR
+9 SET DR=DR_";.03////"_ABMRVN
+10 SET DR=DR_";.05////"_ABMSDT
+11 IF ABMPNARR
SET DR=DR_";.06////"_ABMPNARR
+12 IF '$TEST
IF ABMPNARR]""
SET DR=DR_";.06///"_ABMPNARR
+13 ;S DR=DR_";.07////"_+$P($G(^ABMDFEE(ABMP("FEE"),11,ABMCPT,0)),"^",2) ;abm*2.6*2 3PMS10003A
+14 ;abm*2.6*2 3PMS10003A
SET DR=DR_";.07////"_+$PIECE($$ONE^ABMFEAPI(ABMP("FEE"),11,ABMCPT,ABMP("VDT")),U)
+15 SET ABMUNIT=$PIECE($GET(^AUPNVCPT(ABMDA,0)),U,16)
+16 IF +ABMUNIT=0
SET ABMUNIT=1
+17 SET DR=DR_";.09////"_ABMMOD1
+18 SET DR=DR_";.11////"_ABMMOD2
+19 SET DR=DR_";.13////"_ABMUNIT
+20 SET DR=DR_";.17////"_ABMSRC
+21 IF $DATA(ABMCORDI(ABMCPT))
Begin DoDot:1
+22 IF '$DATA(^ABMDCLM(DUZ(2),ABMP("CDFN"),17,ABMCORDI(ABMCPT),0))
QUIT
+23 SET DXPTR=$PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),17,ABMCORDI(ABMCPT),0),U,2)
+24 SET ABMINDXP=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),17,"C",""))
+25 SET DR=DR_";.04////"_(DXPTR-ABMINDXP+1)
End DoDot:1
+26 ;Next line set correspond diagnosis if only 1 POV
+27 IF '$TEST
IF $DATA(ABMP("CORRSDIAG"))
SET DR=DR_";.04////1"
+28 DO ^DIE
+29 DO ANES
+30 QUIT
+31 ;
RAD ;RADIOLOGY
+1 SET ABMCTG=35
DO EDIT
IF +Y<0
QUIT
+2 IF 'ABMRVN
SET ABMRVN=320
+3 SET DR=DR_";.02////"_ABMRVN
+4 SET ABMUNIT=1
+5 SET DR=DR_";.03////"_ABMUNIT
+6 ;S DR=DR_";.04////"_$P($G(^ABMDFEE(ABMP("FEE"),15,ABMCPT,0)),"^",2) ;abm*2.6*2 3PMS10003A
+7 ;abm*2.6*2 3PMS10003A
SET DR=DR_";.04////"_$PIECE($$ONE^ABMFEAPI(ABMP("FEE"),15,ABMCPT,ABMP("VDT")),U)
+8 SET DR=DR_";.05////"_ABMMOD1
+9 SET DR=DR_";.06////"_ABMMOD2
+10 ;Next line set correspond diagnosis if only 1 POV
+11 IF $DATA(ABMP("CORRSDIAG"))
SET DR=DR_";.08////1"
+12 SET DR=DR_";.09////"_ABMSDT
+13 SET DR=DR_";.17////"_ABMSRC
+14 DO ^DIE
+15 QUIT
+16 ;
MED ;MEDICAL CODE
+1 SET ABMCTG=27
DO EDIT
IF +Y<0
QUIT
+2 IF 'ABMRVN
SET ABMRVN=510
+3 SET DR=DR_";.02////"_ABMRVN
+4 SET ABMUNIT=$PIECE($GET(^AUPNVCPT(ABMDA,0)),U,16)
+5 IF +ABMUNIT=0
SET ABMUNIT=1
+6 SET DR=DR_";.03////"_ABMUNIT
+7 ;S DR=DR_";.04////"_$P($G(^ABMDFEE(ABMP("FEE"),19,ABMCPT,0)),"^",2) ;abm*2.6*2 3PMS10003A
+8 ;abm*2.6*2 3PMS10003A
SET DR=DR_";.04////"_$PIECE($$ONE^ABMFEAPI(ABMP("FEE"),19,ABMCPT,ABMP("VDT")),U)
+9 SET DR=DR_";.05////"_ABMMOD1
+10 SET DR=DR_";.08////"_ABMMOD2
+11 ;Next line set correspond diagnosis if only 1 POV
+12 IF $DATA(ABMP("CORRSDIAG"))
SET DR=DR_";.06////1"
+13 SET DR=DR_";.07////"_ABMSDT
+14 SET DR=DR_";.17////"_ABMSRC
+15 DO ^DIE
+16 QUIT
+17 ;
HCPCS ;HCPCS CODE
+1 SET XTLKUT=""
+2 SET ABMCTG=$SELECT(ABMCPT]]"A0000"&(ABMCPT']]"A0999"):47,1:43)
DO EDIT
IF +Y<0
QUIT
+3 IF ABMRVN=""
Begin DoDot:1
+4 IF $EXTRACT(ABMCPT,1,2)="A0"
SET ABMRVN=540
QUIT
+5 IF $EXTRACT(ABMCPT)="E"
SET ABMRVN=290
QUIT
+6 IF $EXTRACT(ABMCPT)="J"
SET ABMRVN=250
QUIT
+7 IF $EXTRACT(ABMCPT)="K"
SET ABMRVN=290
QUIT
+8 IF $EXTRACT(ABMCPT,1,3)="L86"
SET ABMRVN=274
QUIT
+9 IF $EXTRACT(ABMCPT,1,2)="P9"
SET ABMRVN=300
QUIT
+10 SET ABMRVN=270
End DoDot:1
+11 SET DR=DR_";.02////"_ABMRVN
+12 SET ABMUNIT=$PIECE($GET(^AUPNVCPT(ABMDA,0)),U,16)
+13 IF +ABMUNIT=0
SET ABMUNIT=1
+14 SET DR=DR_";.03////"_ABMUNIT
+15 ;S DR=DR_";.04////"_$P($G(^ABMDFEE(ABMP("FEE"),13,ABMCPTIE,0)),"^",2) ;abm*2.6*2 3PMS10003A
+16 ;S DR=DR_";.04////"_$P($$ONE^ABMFEAPI(ABMP("FEE"),13,ABMCPTIE,ABMP("VDT")),U) ;abm*2.6*2 3PMS10003A ;abm*2.6*27 IHS/SD/SDR CR8894
+17 ;abm*2.6*2 3PMS10003A ;abm*2.6*27 IHS/SD/SDR CR8894
SET DR=DR_";.04////"_$PIECE($$ONE^ABMFEAPI(ABMP("FEE"),13,ABMCPT,ABMP("VDT")),U)
+18 SET DR=DR_";.05////"_ABMMOD1
+19 ;Next line set correspond diagnosis if only 1 POV
+20 IF $DATA(ABMP("CORRSDIAG"))
SET DR=DR_";.06////1"
+21 SET DR=DR_";.07////"_ABMSDT
+22 SET DR=DR_";.08////"_ABMMOD2
+23 SET DR=DR_";.17////"_ABMSRC
+24 DO ^DIE
+25 KILL XTLKUT
+26 QUIT
+27 ;
LAB ;
+1 IF '$DATA(ABMCPTTB("LAB"))
Begin DoDot:1
+2 SET ABMIEN=0
+3 FOR I=1:1
SET ABMIEN=$ORDER(^ABMDCPT("C","LAB",ABMIEN))
IF 'ABMIEN
QUIT
Begin DoDot:2
+4 SET ABMCPTTB("LAB",I)=$PIECE(^ABMDCPT(ABMIEN,0),U,4,5)
End DoDot:2
End DoDot:1
+5 SET ABMOK=0
+6 SET I=0
+7 FOR
SET I=$ORDER(ABMCPTTB("LAB",I))
IF 'I
QUIT
Begin DoDot:1
+8 IF ABMCPT'<$PIECE(ABMCPTTB("LAB",I),U)&(ABMCPT'>$PIECE(ABMCPTTB("LAB",I),U,2))
SET ABMOK=1
End DoDot:1
IF ABMOK
QUIT
+9 IF 'ABMOK
QUIT
+10 SET ABMFILE=$PIECE(AUPNCPT(N),U,4)
+11 SET ABMIENS=ABMDA_","
+12 IF ABMFILE=9000010.18
Begin DoDot:1
+13 SET ABMFLD1=.08
+14 SET ABMFLD2=.09
End DoDot:1
+15 IF '$TEST
IF ABMFILE=9000010.08
Begin DoDot:1
+16 SET ABMFLD1=.17
+17 SET ABMFLD2=.18
End DoDot:1
+18 IF '$TEST
IF ABMFILE=9000010.22
Begin DoDot:1
+19 SET ABMFLD1=.07
+20 SET ABMFLD2=.08
End DoDot:1
+21 IF '$TEST
KILL ABMFLD1,ABMFLD2
+22 SET ABMMOD(1)=$$GET1^DIQ(ABMFILE,ABMIENS,ABMFLD1)
+23 IF ABMMOD(1)]""
SET ABMMOD(2)=$$GET1^DIQ(ABMFILE,ABMIENS,ABMFLD2)
+24 IF '$TEST
KILL ABMMOD(1)
+25 IF ABMFILE=9000010.18
SET ABMUNITS=$$GET1^DIQ(ABMFILE,ABMIENS,.16)
+26 IF '$TEST
SET ABMUNITS=1
+27 IF ABMUNITS<1
SET ABMUNITS=1
+28 SET ABMCOLDT=$$GET1^DIQ(ABMFILE,ABMIENS,1201,"I")
+29 IF ABMCOLDT<2000101
SET ABMCOLDT=ABMCHVDT
+30 ;CSV-c
SET ABMREVCD=$PIECE($$IHSCPT^ABMCVAPI(ABMCPT,ABMP("VDT")),U,3)
+31 IF 'ABMREVCD
Begin DoDot:1
+32 NEW ABMCPTCT
+33 ;CSV-c
SET ABMCPTCT=$PIECE($$CPT^ABMCVAPI(ABMCPT,ABMP("VDT")),U,4)
+34 IF 'ABMCPTCT
QUIT
+35 ;CSV-c
SET ABMREVCD=$PIECE($$IHSCAT^ABMCVAPI(ABMCPTCT,ABMP("VDT")),U)
End DoDot:1
+36 IF 'ABMREVCD
SET ABMREVCD=300
+37 ;S FEE=$P($G(^ABMDFEE(+ABMP("FEE"),17,ABMCPT,0)),U,2) ;abm*2.6*2 3PMS10003A
+38 ;abm*2.6*2 3PMS10003A
SET FEE=$PIECE($$ONE^ABMFEAPI(+ABMP("FEE"),17,ABMCPT,ABMP("VDT")),U)
+39 KILL DIC,DD,DO
+40 SET X=ABMCPT
+41 SET DIC="^ABMDCLM("_DUZ(2)_","_ABMP("CDFN")_",37,"
+42 SET DIC("DR")=".02////"_ABMREVCD
+43 SET DIC("DR")=DIC("DR")_";.03////"_ABMUNITS
+44 SET DIC("DR")=DIC("DR")_";.04////"_FEE
+45 SET DIC("DR")=DIC("DR")_";.05////"_ABMCOLDT
+46 SET DIC("DR")=DIC("DR")_";.06////"_ABMMOD1
+47 SET DIC("DR")=DIC("DR")_";.07////"_ABMMOD2
+48 SET DIC("DR")=DIC("DR")_";.17////"_ABMSRC
+49 IF $DATA(ABMP("CORRSDIAG"))
SET DIC("DR")=DIC("DR")_";.09////1"
+50 IF $DATA(ABMMOD)
FOR J=1:1:2
IF '$DATA(ABMMOD(J))
QUIT
Begin DoDot:1
+51 SET DIC("DR")=DIC("DR")_";"_((5+J)/100)_"////"_ABMMOD(J)
End DoDot:1
+52 SET DA=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),"ASRC",ABMSRC,0))
+53 ;For duplicates problem
IF DA
IF '$DATA(@(DIC_DA_",0)"))
SET DA=""
+54 SET DA(1)=ABMP("CDFN")
+55 IF DA>0
Begin DoDot:1
+56 KILL DR
+57 SET DIE=DIC
+58 SET DR=".01///"_X_";"_DIC("DR")
+59 DO ^DIE
End DoDot:1
+60 IF '$TEST
Begin DoDot:1
+61 SET DIC(0)="LE"
+62 SET DIC("P")=$PIECE(^DD(9002274.3,37,0),U,2)
+63 KILL DD,DO
+64 KILL DD,DO
DO FILE^DICN
End DoDot:1
+65 QUIT
EDIT ;EDIT EXISTING ENTRY
+1 NEW ABM1,ABMY,P
+2 KILL DIC,DIE
+3 SET (DIC,DIE)="^ABMDCLM(DUZ(2),DA(1),ABMCTG,"
+4 ;S ABMCPTIE=$O(^ICPT("B",ABMCPT,0)) ;abm*2.6*11 HEAT94153
+5 ;abm*2.6*11 HEAT94153
SET ABMCPTIE=$PIECE(AUPNCPT(N),U,3)
+6 ;CSV-c
SET ABMRVN=$PIECE($$IHSCPT^ABMCVAPI(+ABMCPTIE,ABMP("VDT")),U,3)
+7 SET DA=$ORDER(^ABMDCLM(DUZ(2),DA(1),"ASRC",ABMSRC,0))
+8 ;For duplicates problem
IF DA
IF '$DATA(@(DIC_DA_",0)"))
SET DA=""
+9 NEW XREF
+10 IF DA
IF (ABMCTG=21)!(ABMCTG=39)
Begin DoDot:1
+11 SET XREF="ASRC"_$SELECT(ABMCTG=21:"S",1:"A")
+12 IF $DATA(^ABMDCLM(DUZ(2),DA(1),ABMCTG,XREF,ABMSRC,DA))
QUIT
+13 SET DA=""
End DoDot:1
+14 IF DA=""
Begin DoDot:1
+15 SET ABM1=0
+16 FOR
SET ABM1=$ORDER(^ABMDCLM(DUZ(2),DA(1),ABMCTG,ABM1))
IF 'ABM1
QUIT
Begin DoDot:2
+17 ;If this finds an old entry with no source field
+18 ; and it matches DA is set and new record not created.
+19 ; and no match a new entry is created and DA defined
+20 ;If no old entry a new record is created and DA defined
+21 ;If all old entries have source field new record created & DA defined
+22 SET ABMY=$GET(^ABMDCLM(DUZ(2),DA(1),ABMCTG,ABM1,0))
+23 IF $PIECE(ABMY,U,17)]""
QUIT
+24 SET P=$SELECT(ABMCTG=21!(ABMCTG=39):5,ABMCTG=35:9,1:7)
+25 IF ABMCPTIE=+ABMY
IF ABMSDT=$PIECE(ABMY,U,P)
SET DA=ABM1
QUIT
End DoDot:2
IF DA]""
QUIT
+26 IF DA]""
QUIT
+27 IF (ABMCTG=21)!(ABMCTG=39)
Begin DoDot:2
+28 SET XREF="ASRC"_$SELECT(ABMCTG=21:"S",1:"A")
+29 SET DA=$ORDER(^ABMDCLM(DUZ(2),DA(1),ABMCTG,XREF,ABMSRC,DA))
End DoDot:2
IF DA]""
QUIT
+30 DO ADD
End DoDot:1
+31 SET Y=$GET(Y)
+32 SET DR=".01////"_ABMCPTIE
+33 QUIT
+34 ;
ADD ;SET ZERO NODE AND DIC
+1 IF '$DATA(^ABMDCLM(DUZ(2),DA(1),ABMCTG,0))
SET ^(0)="^9002274.30"_ABMCTG_"P^^"
+2 SET X=ABMCPTIE
+3 SET DIC(0)="LXE"
+4 KILL DD,DO,DINUM
DO FILE^DICN
+5 SET DA=+Y
+6 QUIT
