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

ABMDSPLB.m

Go to the documentation of this file. 
  1. ABMDSPLB ; IHS/SD/SDR - SPLIT CLAIM IN TWO medicare B;     
  1.  ;;2.6;IHS 3P BILLING SYSTEM;**14,21**;NOV 12, 2009;Build 379
  1.  ;
  1.  ; IHS/SD/SDR - v2.5 p8 - task 6 - Added code to not split claim if ambulance
  1.  ; IHS/SD/SDR - v2.5 p9 - IM19717/IM20374 - Added to merge check primary provider and primary DX
  1.  ;
  1.  ;IHS/SD/SDR - 2.6*21 - HEAT112417 - Made change so MCR pro fee bill will still have itemized data
  1.  ; *********************************************************************
  1.  ;
  1. MAIN(ABMCF) ;EP - main section
  1.  ;x=claim to clone
  1.  D CHK I $G(ABMQUIT) K ABMQUIT Q
  1.  D ADD Q:+Y<0
  1.  D EDIT
  1.  D DEL
  1.  D XREF
  1.  K ABMCF,ABMC2
  1.  Q
  1. CHK ;checks create claim or quit
  1.  N ABMPAT,ABMDT,ABMVTYP,ABMINS,ABMCLIN
  1.  S ABMQUIT=1
  1.  Q:'$D(^ABMDCLM(DUZ(2),ABMCF,0))
  1.  S ABMPAT=$P(^ABMDCLM(DUZ(2),ABMCF,0),U),ABMDT=$P(^(0),U,2),ABMVTYP=$P(^(0),U,7),ABMINS=$P(^(0),U,8),ABMCLIN=$P(^(0),U,6)
  1.  Q:ABMDT<3010701
  1.  Q:$P($G(^DIC(40.7,ABMCLIN,0)),U)="AMBULANCE"
  1.  I '$$PARTB(ABMPAT,ABMDT) Q
  1.  D DUP I $G(ABMDUP) Q
  1.  K ABMQUIT
  1.  Q
  1. DUP ; EP - check for duplicate claim
  1.  K ABMDUP
  1.  N I
  1.  S I=0 F  S I=$O(^ABMDCLM(DUZ(2),"B",ABMPAT,I)) Q:'I  D
  1.  .Q:$P(^ABMDCLM(DUZ(2),I,0),"^",2)'=ABMDT
  1.  .Q:$P(^ABMDCLM(DUZ(2),I,0),"^",7)'=999
  1.  .Q:$P(^ABMDCLM(DUZ(2),I,0),"^",8)'=ABMINS
  1.  .Q:$P(^ABMDCLM(DUZ(2),I,0),"^",6)'=ABMCLIN
  1.  .D GETPPRV
  1.  .D GETPPOV
  1.  .Q:$G(ABMVPRV)'=ABMCPRV2
  1.  .Q:$G(ABMVICD)'=ABMCICD2
  1.  .S ABMDUP=1
  1.  Q
  1. ADD ; EP - add claim
  1.  S X=$P($G(^ABMDCLM(DUZ(2),ABMCF,0)),U)
  1.  Q:'X
  1.  S DINUM=$$NXNM^ABMDUTL
  1.  Q:DINUM=""
  1.  S DIC="^ABMDCLM(DUZ(2),"
  1.  S DIC(0)="L"
  1.  K DD,DO
  1.  D FILE^DICN
  1.  Q:+Y<0
  1.  S ABMC2=+Y
  1.  M ^ABMDCLM(DUZ(2),ABMC2)=^ABMDCLM(DUZ(2),ABMCF)
  1.  Q
  1. EDIT ; EP - edit fields
  1.  S DA=ABMC2
  1.  S DIE="^ABMDCLM(DUZ(2),"
  1.  S DR=".07///999;.1///"_DT_";.04///E;.14///20;.17///"_DT
  1.  D ^DIE
  1.  Q
  1. DEL ; EP - delete sections
  1.  ;start old abm*2.6*21 IHS/SD/SDR HEAT112417
  1.  ;N I F I=13,23,25,33,37,43,45 D
  1.  ;.K ^ABMDCLM(DUZ(2),DA,I)
  1.  ;end old HEAT112417
  1.  Q
  1. XREF ; EP - cross reference
  1.  S DIK="^ABMDCLM(DUZ(2),"
  1.  K ^ABMDCLM(DUZ(2),DA,"ASRC")
  1.  D IX1^DIK
  1.  Q
  1. PARTB(X,Y) ;EP - check for part b
  1.  ;x=patient dfn, y=date
  1.  I 'X S Z=0 Q Z
  1.  I 'Y S Z=0 Q Z
  1.  S Z=0
  1.  N I
  1.  S I=0 F  S I=$O(^AUPNMCR(X,11,I)) Q:'I  D
  1.  .S ABMZERO=^AUPNMCR(X,11,I,0)
  1.  .D BSUB
  1.  S I=0 F  S I=$O(^AUPNRRE(X,11,I)) Q:'I  D
  1.  .S ABMZERO=^AUPNRRE(X,11,I,0)
  1.  .D BSUB
  1.  K ABMZERO
  1.  Q Z
  1.  ;
  1.  ; *********************************************************************
  1. BSUB ; EP
  1.  ; check for B subroutine
  1.  Q:$P(ABMZERO,"^",3)'="B"
  1.  Q:$P(ABMZERO,U)>Y
  1.  I $P(ABMZERO,"^",2),$P(ABMZERO,"^",2)<Y Q
  1.  S Z=1
  1.  Q
  1. GETPPRV ;EP
  1.  ;get attending/operating provider from claim
  1.  S ABMCPRV2=+$O(^ABMDCLM(DUZ(2),I,41,"C","A",0))
  1.  S:ABMCPRV2=0 ABMCPRV2=+$O(^ABMDCLM(DUZ(2),I,41,"C","O",0))
  1.  I ABMCPRV2'=0 S ABMCPRV2=$P($G(^ABMDCLM(DUZ(2),I,41,ABMCPRV2,0)),U)
  1.  Q
  1. GETPPOV ;EP
  1.  ;get Primary/first entry from claim
  1.  S ABMCICD2=+$O(^ABMDCLM(DUZ(2),I,17,0))
  1.  Q