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