Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ABMFCPT

ABMFCPT.m

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