ABMRSTI2 ; IHS/SD/SDR - Split Claim Billing (part 2);
;;2.6;IHS 3P BILLING SYSTEM;**22**;NOV 12, 2009;Build 418
;IHS/SD/SDR 2.6*22 HEAT335246 - New routine
;
Q
SPLITCLM ;EP
S ABMPG=""
F S ABMPG=$O(^TMP("ABM-SPIN",$J,"VLST",ABMP("CDFN"),ABMPG)) Q:$G(ABMPG)="" D ;loop thru selected pages to split
.I ABMY("PGS")'[("^"_ABMPG_"^") Q ;not a page that was selected by user
.I $TR($P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),0)),U,25),",")[ABMPG Q ;don't split pages that have already been split from claim
.;I +$G(^TMP("ABM-SPIN",$J,"VLST",ABMP("CDFN"),ABMPG))<2 Q ;claim should have 2 entries for page before splitting will occur; this is to address issue found in TST but couldn't replicate again
.S ABMCNT=0
.S ABMCNTF=0
.I ABMY("SPLITHOW")=2 D
..D NEWENTRY
..Q:$O(^TMP("ABM-STIN",$J,"NEWCLMLST",ABMP("CDFN"),""))=""
..;no entry was created so quit
..D CLEANUP
.;
.I ABMY("SPLITHOW")=1 D
..F J=1:1:$G(^TMP("ABM-SPIN",$J,"VLST",ABMP("CDFN"),ABMPG)) D
...D NEWENTRY
...Q:$O(^TMP("ABM-STIN",$J,"NEWCLMLST",ABMP("CDFN"),""))=""
...D CLEANUP
;
I ABMY("SPLITHOW")=1 D
.K ABMSV,ABMSV2
.S ABMC2=0
.F S ABMC2=$O(^TMP("ABM-STIN",$J,"NEWCLMLST",ABMP("CDFN"),ABMC2)) Q:'ABMC2 D
..F ABMPA="8A","8B","8C","8D","8E","8F","8G","8H","8J","8K" D
...S ABMC=0
...S ABMP=$S(ABMPA="8A":21,ABMPA="8B":27,ABMPA="8C":25,ABMPA="8D":23,ABMPA="8E":37,ABMPA="8F":35,ABMPA="8G":39,ABMPA="8H":43,ABMPA="8J":45,ABMPA="8K":47,1:0)
...S ABMD=0
...F S ABMD=$O(^ABMDCLM(DUZ(2),ABMC2,ABMP,ABMD)) Q:'ABMD D
....S ABMC=+$G(ABMC)+1
....Q:$G(^TMP("ABM-STIN",$J,"NEWCLMLST",ABMP("CDFN"),ABMC2,ABMPA))=ABMC
....D DELSUB
...D REINDEX(ABMC2) ;reindex new claim after claim is in final state (meaning all unwanted entries from this claim have been removed
.;
;If one claim per page, delete other charges
I ABMY("SPLITHOW")=2 D
.S ABMC2=0
.F S ABMC2=$O(^TMP("ABM-STIN",$J,"NEWCLMLST",ABMP("CDFN"),ABMC2)) Q:'ABMC2 D
..S ABMPA=""
..F S ABMPA=$O(^TMP("ABM-STIN",$J,"NEWCLMLST",ABMP("CDFN"),ABMC2,ABMPA)) Q:$G(ABMPA)="" D
...S ABMK=$S(ABMPA="8A":21,ABMPA="8B":27,ABMPA="8C":25,ABMPA="8D":23,ABMPA="8E":37,ABMPA="8F":35,ABMPA="8G":39,ABMPA="8H":43,ABMPA="8J":45,ABMPA="8K":47,1:0)
...F ABMD=27,21,25,23,37,35,39,33,43,45 D
....Q:ABMK=ABMD ;only entry to keep; delete the rest
....K ^ABMDCLM(DUZ(2),ABMC2,ABMD)
..D REINDEX(ABMC2) ;reindex new claim after claim is in final state (meaning all unwanted entries from this claim have been removed
;
I +$G(ABMDLT)=1 D DEL ;only delete if they asked to
D REINDEX(ABMP("CDFN")) ;reindex original claim
;I $G(ABMY("SPLIT"))'="A" D
;.W !,"Split claim complete."
Q
NEWENTRY ;EP
S X=$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U)
S DINUM=$$NXNM^ABMDUTL
I DINUM="" D Q
.W !!,"ERROR: Claim not created - check global ^ABMDCLM(0)"
.S DIR(0)="E" D ^DIR K DIR
S DIC="^ABMDCLM(DUZ(2),"
S DIC(0)="L"
K DD,DO D FILE^DICN Q:+Y<0 S ABMC2=+Y
S ABMCNT=+$G(ABMCNT)+1
S ^TMP("ABM-STIN",$J,"NEWCLMLST",ABMP("CDFN"),ABMC2,ABMPG)=ABMCNT ;keep list of new claims sorted by old claim number
S ABMC=+$G(ABMC)+1
M ^ABMDCLM(DUZ(2),ABMC2)=^ABMDCLM(DUZ(2),ABMP("CDFN")) ;merge data into new claim
;edit new claim fields
S DIE="^ABMDCLM(DUZ(2),"
S DA=ABMC2
S DR=".1////"_DT_";.04///E"
S DR=DR_";.17////"_DT ;date created
S DR=DR_";.022////"_$S($G(ABMY("SPLIT"))="A":"A",1:"S") ;auto or manual split
S DR=DR_";.07////"_$S(ABMPG="8D":997,ABMPG="8E":996,ABMPG="8F":995,1:$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),0)),U,7)) ;visit type
S DR=DR_";.023////"_DUZ_";.024///"_ABMY("AUTODT") ;who split and when
D ^DIE
;label original claim
S DIE="^ABMDCLM(DUZ(2),"
S DA=ABMP("CDFN")
S DR=".022////O"
D ^DIE
I $P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),0)),U,25)[ABMPG Q ;already labeled claim as split; it gets here for ea split claim so if there are multiple charges it will try to add the page multiple times
S DR=".025////"_$S($P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),0)),U,25)'="":$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),0)),U,25)_",",1:"")_ABMPG ;keep track of pages split from this claim
D ^DIE
K DIR
Q
CLEANUP ;EP
;if one charge per claim, loop thru and delete other charges because we merged them all onto each claim
F ABMPA="8A","8B","8C","8D","8E","8F","8G","8H","8J","8K" D
.S ABMP=$S(ABMPA="8A":21,ABMPA="8B":27,ABMPA="8C":25,ABMPA="8D":23,ABMPA="8E":37,ABMPA="8F":35,ABMPA="8G":39,ABMPA="8H":43,ABMPA="8J":45,ABMPA="8K":47,1:0)
.S ABMP("DSUB")=$S(ABMPA="8D":23,ABMPA="8E":37,ABMPA="8F":35,ABMPA="8H":43,1:0)
.I ABMP("DSUB")=0!(ABMPG'[ABMPA) K ^ABMDCLM(DUZ(2),ABMC2,ABMP)
Q
DEL ;EP DELETE SECTIONS FROM ORIGINAL CLAIM
;K ^ABMDCLM(DUZ(2),ABMC2,13)
F I=1:1:10 D
.S ABMPG=$P("8A^8B^8C^8D^8E^8F^8G^8H^8I^8J","^",I)
.S ABMSEC=$P("27^21^25^23^37^35^39^43^33^45","^",I)
.I ABMY("PGS")[ABMPG K ^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMSEC)
.Q:ABMY("PGS")["8Z"
.;I '(ABMY("PGS")[ABMPG) K ^ABMDCLM(DUZ(2),ABMC2,ABMSEC)
Q
DELSUB ;EP
S DA=ABMD
S DA(1)=ABMC2
S DIK="^ABMDCLM(DUZ(2),"_DA(1)_","_ABMP_","
D ^DIK
Q
REINDEX(X) ;EP
S DA=X
K ^ABMDCLM(DUZ(2),DA,"ASRC")
S DIK="^ABMDCLM(DUZ(2),"
D IX1^DIK
Q
ABMRSTI2 ; IHS/SD/SDR - Split Claim Billing (part 2);
+1 ;;2.6;IHS 3P BILLING SYSTEM;**22**;NOV 12, 2009;Build 418
+2 ;IHS/SD/SDR 2.6*22 HEAT335246 - New routine
+3 ;
+4 QUIT
SPLITCLM ;EP
+1 SET ABMPG=""
+2 ;loop thru selected pages to split
FOR
SET ABMPG=$ORDER(^TMP("ABM-SPIN",$JOB,"VLST",ABMP("CDFN"),ABMPG))
IF $GET(ABMPG)=""
QUIT
Begin DoDot:1
+3 ;not a page that was selected by user
IF ABMY("PGS")'[("^"_ABMPG_"^")
QUIT
+4 ;don't split pages that have already been split from claim
IF $TRANSLATE($PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),0)),U,25),",")[ABMPG
QUIT
+5 ;I +$G(^TMP("ABM-SPIN",$J,"VLST",ABMP("CDFN"),ABMPG))<2 Q ;claim should have 2 entries for page before splitting will occur; this is to address issue found in TST but couldn't replicate again
+6 SET ABMCNT=0
+7 SET ABMCNTF=0
+8 IF ABMY("SPLITHOW")=2
Begin DoDot:2
+9 DO NEWENTRY
+10 IF $ORDER(^TMP("ABM-STIN",$JOB,"NEWCLMLST",ABMP("CDFN"),""))=""
QUIT
+11 ;no entry was created so quit
+12 DO CLEANUP
End DoDot:2
+13 ;
+14 IF ABMY("SPLITHOW")=1
Begin DoDot:2
+15 FOR J=1:1:$GET(^TMP("ABM-SPIN",$JOB,"VLST",ABMP("CDFN"),ABMPG))
Begin DoDot:3
+16 DO NEWENTRY
+17 IF $ORDER(^TMP("ABM-STIN",$JOB,"NEWCLMLST",ABMP("CDFN"),""))=""
QUIT
+18 DO CLEANUP
End DoDot:3
End DoDot:2
End DoDot:1
+19 ;
+20 IF ABMY("SPLITHOW")=1
Begin DoDot:1
+21 KILL ABMSV,ABMSV2
+22 SET ABMC2=0
+23 FOR
SET ABMC2=$ORDER(^TMP("ABM-STIN",$JOB,"NEWCLMLST",ABMP("CDFN"),ABMC2))
IF 'ABMC2
QUIT
Begin DoDot:2
+24 FOR ABMPA="8A","8B","8C","8D","8E","8F","8G","8H","8J","8K"
Begin DoDot:3
+25 SET ABMC=0
+26 SET ABMP=$SELECT(ABMPA="8A":21,ABMPA="8B":27,ABMPA="8C":25,ABMPA="8D":23,ABMPA="8E":37,ABMPA="8F":35,ABMPA="8G":39,ABMPA="8H":43,ABMPA="8J":45,ABMPA="8K":47,1:0)
+27 SET ABMD=0
+28 FOR
SET ABMD=$ORDER(^ABMDCLM(DUZ(2),ABMC2,ABMP,ABMD))
IF 'ABMD
QUIT
Begin DoDot:4
+29 SET ABMC=+$GET(ABMC)+1
+30 IF $GET(^TMP("ABM-STIN",$JOB,"NEWCLMLST",ABMP("CDFN"),ABMC2,ABMPA))=ABMC
QUIT
+31 DO DELSUB
End DoDot:4
+32 ;reindex new claim after claim is in final state (meaning all unwanted entries from this claim have been removed
DO REINDEX(ABMC2)
End DoDot:3
End DoDot:2
+33 ;
End DoDot:1
+34 ;If one claim per page, delete other charges
+35 IF ABMY("SPLITHOW")=2
Begin DoDot:1
+36 SET ABMC2=0
+37 FOR
SET ABMC2=$ORDER(^TMP("ABM-STIN",$JOB,"NEWCLMLST",ABMP("CDFN"),ABMC2))
IF 'ABMC2
QUIT
Begin DoDot:2
+38 SET ABMPA=""
+39 FOR
SET ABMPA=$ORDER(^TMP("ABM-STIN",$JOB,"NEWCLMLST",ABMP("CDFN"),ABMC2,ABMPA))
IF $GET(ABMPA)=""
QUIT
Begin DoDot:3
+40 SET ABMK=$SELECT(ABMPA="8A":21,ABMPA="8B":27,ABMPA="8C":25,ABMPA="8D":23,ABMPA="8E":37,ABMPA="8F":35,ABMPA="8G":39,ABMPA="8H":43,ABMPA="8J":45,ABMPA="8K":47,1:0)
+41 FOR ABMD=27,21,25,23,37,35,39,33,43,45
Begin DoDot:4
+42 ;only entry to keep; delete the rest
IF ABMK=ABMD
QUIT
+43 KILL ^ABMDCLM(DUZ(2),ABMC2,ABMD)
End DoDot:4
End DoDot:3
+44 ;reindex new claim after claim is in final state (meaning all unwanted entries from this claim have been removed
DO REINDEX(ABMC2)
End DoDot:2
End DoDot:1
+45 ;
+46 ;only delete if they asked to
IF +$GET(ABMDLT)=1
DO DEL
+47 ;reindex original claim
DO REINDEX(ABMP("CDFN"))
+48 ;I $G(ABMY("SPLIT"))'="A" D
+49 ;.W !,"Split claim complete."
+50 QUIT
NEWENTRY ;EP
+1 SET X=$PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U)
+2 SET DINUM=$$NXNM^ABMDUTL
+3 IF DINUM=""
Begin DoDot:1
+4 WRITE !!,"ERROR: Claim not created - check global ^ABMDCLM(0)"
+5 SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:1
QUIT
+6 SET DIC="^ABMDCLM(DUZ(2),"
+7 SET DIC(0)="L"
+8 KILL DD,DO
DO FILE^DICN
IF +Y<0
QUIT
SET ABMC2=+Y
+9 SET ABMCNT=+$GET(ABMCNT)+1
+10 ;keep list of new claims sorted by old claim number
SET ^TMP("ABM-STIN",$JOB,"NEWCLMLST",ABMP("CDFN"),ABMC2,ABMPG)=ABMCNT
+11 SET ABMC=+$GET(ABMC)+1
+12 ;merge data into new claim
MERGE ^ABMDCLM(DUZ(2),ABMC2)=^ABMDCLM(DUZ(2),ABMP("CDFN"))
+13 ;edit new claim fields
+14 SET DIE="^ABMDCLM(DUZ(2),"
+15 SET DA=ABMC2
+16 SET DR=".1////"_DT_";.04///E"
+17 ;date created
SET DR=DR_";.17////"_DT
+18 ;auto or manual split
SET DR=DR_";.022////"_$SELECT($GET(ABMY("SPLIT"))="A":"A",1:"S")
+19 ;visit type
SET DR=DR_";.07////"_$SELECT(ABMPG="8D":997,ABMPG="8E":996,ABMPG="8F":995,1:$PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),0)),U,7))
+20 ;who split and when
SET DR=DR_";.023////"_DUZ_";.024///"_ABMY("AUTODT")
+21 DO ^DIE
+22 ;label original claim
+23 SET DIE="^ABMDCLM(DUZ(2),"
+24 SET DA=ABMP("CDFN")
+25 SET DR=".022////O"
+26 DO ^DIE
+27 ;already labeled claim as split; it gets here for ea split claim so if there are multiple charges it will try to add the page multiple times
IF $PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),0)),U,25)[ABMPG
QUIT
+28 ;keep track of pages split from this claim
SET DR=".025////"_$SELECT($PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),0)),U,25)'="":$PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),0)),U,25)_",",1:"")_ABMPG
+29 DO ^DIE
+30 KILL DIR
+31 QUIT
CLEANUP ;EP
+1 ;if one charge per claim, loop thru and delete other charges because we merged them all onto each claim
+2 FOR ABMPA="8A","8B","8C","8D","8E","8F","8G","8H","8J","8K"
Begin DoDot:1
+3 SET ABMP=$SELECT(ABMPA="8A":21,ABMPA="8B":27,ABMPA="8C":25,ABMPA="8D":23,ABMPA="8E":37,ABMPA="8F":35,ABMPA="8G":39,ABMPA="8H":43,ABMPA="8J":45,ABMPA="8K":47,1:0)
+4 SET ABMP("DSUB")=$SELECT(ABMPA="8D":23,ABMPA="8E":37,ABMPA="8F":35,ABMPA="8H":43,1:0)
+5 IF ABMP("DSUB")=0!(ABMPG'[ABMPA)
KILL ^ABMDCLM(DUZ(2),ABMC2,ABMP)
End DoDot:1
+6 QUIT
DEL ;EP DELETE SECTIONS FROM ORIGINAL CLAIM
+1 ;K ^ABMDCLM(DUZ(2),ABMC2,13)
+2 FOR I=1:1:10
Begin DoDot:1
+3 SET ABMPG=$PIECE("8A^8B^8C^8D^8E^8F^8G^8H^8I^8J","^",I)
+4 SET ABMSEC=$PIECE("27^21^25^23^37^35^39^43^33^45","^",I)
+5 IF ABMY("PGS")[ABMPG
KILL ^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMSEC)
+6 IF ABMY("PGS")["8Z"
QUIT
+7 ;I '(ABMY("PGS")[ABMPG) K ^ABMDCLM(DUZ(2),ABMC2,ABMSEC)
End DoDot:1
+8 QUIT
DELSUB ;EP
+1 SET DA=ABMD
+2 SET DA(1)=ABMC2
+3 SET DIK="^ABMDCLM(DUZ(2),"_DA(1)_","_ABMP_","
+4 DO ^DIK
+5 QUIT
REINDEX(X) ;EP
+1 SET DA=X
+2 KILL ^ABMDCLM(DUZ(2),DA,"ASRC")
+3 SET DIK="^ABMDCLM(DUZ(2),"
+4 DO IX1^DIK
+5 QUIT
