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

ABMRSTI2.m

Go to the documentation of this file. 
  1. ABMRSTI2 ; IHS/SD/SDR - Split Claim Billing (part 2); 
  1.  ;;2.6;IHS 3P BILLING SYSTEM;**22**;NOV 12, 2009;Build 418
  1.  ;IHS/SD/SDR 2.6*22 HEAT335246 - New routine
  1.  ;
  1.  Q
  1. SPLITCLM ;EP
  1.  S ABMPG=""
  1.  F  S ABMPG=$O(^TMP("ABM-SPIN",$J,"VLST",ABMP("CDFN"),ABMPG)) Q:$G(ABMPG)=""  D  ;loop thru selected pages to split
  1.  .I ABMY("PGS")'[("^"_ABMPG_"^") Q  ;not a page that was selected by user
  1.  .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
  1.  .;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
  1.  .S ABMCNT=0
  1.  .S ABMCNTF=0
  1.  .I ABMY("SPLITHOW")=2 D
  1.  ..D NEWENTRY
  1.  ..Q:$O(^TMP("ABM-STIN",$J,"NEWCLMLST",ABMP("CDFN"),""))=""
  1.  ..;no entry was created so quit
  1.  ..D CLEANUP
  1.  .;
  1.  .I ABMY("SPLITHOW")=1 D
  1.  ..F J=1:1:$G(^TMP("ABM-SPIN",$J,"VLST",ABMP("CDFN"),ABMPG)) D
  1.  ...D NEWENTRY
  1.  ...Q:$O(^TMP("ABM-STIN",$J,"NEWCLMLST",ABMP("CDFN"),""))=""
  1.  ...D CLEANUP
  1.  ;
  1.  I ABMY("SPLITHOW")=1 D
  1.  .K ABMSV,ABMSV2
  1.  .S ABMC2=0
  1.  .F  S ABMC2=$O(^TMP("ABM-STIN",$J,"NEWCLMLST",ABMP("CDFN"),ABMC2)) Q:'ABMC2  D
  1.  ..F ABMPA="8A","8B","8C","8D","8E","8F","8G","8H","8J","8K" D
  1.  ...S ABMC=0
  1.  ...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)
  1.  ...S ABMD=0
  1.  ...F  S ABMD=$O(^ABMDCLM(DUZ(2),ABMC2,ABMP,ABMD)) Q:'ABMD  D
  1.  ....S ABMC=+$G(ABMC)+1
  1.  ....Q:$G(^TMP("ABM-STIN",$J,"NEWCLMLST",ABMP("CDFN"),ABMC2,ABMPA))=ABMC
  1.  ....D DELSUB
  1.  ...D REINDEX(ABMC2)  ;reindex new claim after claim is in final state (meaning all unwanted entries from this claim have been removed
  1.  .; 
  1.  ;If one claim per page, delete other charges
  1.  I ABMY("SPLITHOW")=2 D
  1.  .S ABMC2=0
  1.  .F  S ABMC2=$O(^TMP("ABM-STIN",$J,"NEWCLMLST",ABMP("CDFN"),ABMC2)) Q:'ABMC2  D
  1.  ..S ABMPA=""
  1.  ..F  S ABMPA=$O(^TMP("ABM-STIN",$J,"NEWCLMLST",ABMP("CDFN"),ABMC2,ABMPA)) Q:$G(ABMPA)=""  D
  1.  ...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)
  1.  ...F ABMD=27,21,25,23,37,35,39,33,43,45 D
  1.  ....Q:ABMK=ABMD  ;only entry to keep; delete the rest
  1.  ....K ^ABMDCLM(DUZ(2),ABMC2,ABMD)
  1.  ..D REINDEX(ABMC2)  ;reindex new claim after claim is in final state (meaning all unwanted entries from this claim have been removed
  1.  ;
  1.  I +$G(ABMDLT)=1 D DEL  ;only delete if they asked to
  1.  D REINDEX(ABMP("CDFN"))  ;reindex original claim
  1.  ;I $G(ABMY("SPLIT"))'="A" D
  1.  ;.W !,"Split claim complete."
  1.  Q
  1. NEWENTRY ;EP
  1.  S X=$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U)
  1.  S DINUM=$$NXNM^ABMDUTL
  1.  I DINUM="" D  Q
  1.  .W !!,"ERROR: Claim not created - check global ^ABMDCLM(0)"
  1.  .S DIR(0)="E" D ^DIR K DIR
  1.  S DIC="^ABMDCLM(DUZ(2),"
  1.  S DIC(0)="L"
  1.  K DD,DO D FILE^DICN Q:+Y<0  S ABMC2=+Y
  1.  S ABMCNT=+$G(ABMCNT)+1
  1.  S ^TMP("ABM-STIN",$J,"NEWCLMLST",ABMP("CDFN"),ABMC2,ABMPG)=ABMCNT ;keep list of new claims sorted by old claim number
  1.  S ABMC=+$G(ABMC)+1
  1.  M ^ABMDCLM(DUZ(2),ABMC2)=^ABMDCLM(DUZ(2),ABMP("CDFN"))  ;merge data into new claim
  1.  ;edit new claim fields
  1.  S DIE="^ABMDCLM(DUZ(2),"
  1.  S DA=ABMC2
  1.  S DR=".1////"_DT_";.04///E"
  1.  S DR=DR_";.17////"_DT  ;date created
  1.  S DR=DR_";.022////"_$S($G(ABMY("SPLIT"))="A":"A",1:"S")  ;auto or manual split
  1.  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
  1.  S DR=DR_";.023////"_DUZ_";.024///"_ABMY("AUTODT")  ;who split and when
  1.  D ^DIE
  1.  ;label original claim
  1.  S DIE="^ABMDCLM(DUZ(2),"
  1.  S DA=ABMP("CDFN")
  1.  S DR=".022////O"
  1.  D ^DIE
  1.  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
  1.  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
  1.  D ^DIE
  1.  K DIR
  1.  Q
  1. CLEANUP ;EP
  1.  ;if one charge per claim, loop thru and delete other charges because we merged them all onto each claim
  1.  F ABMPA="8A","8B","8C","8D","8E","8F","8G","8H","8J","8K" D
  1.  .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)
  1.  .S ABMP("DSUB")=$S(ABMPA="8D":23,ABMPA="8E":37,ABMPA="8F":35,ABMPA="8H":43,1:0)
  1.  .I ABMP("DSUB")=0!(ABMPG'[ABMPA) K ^ABMDCLM(DUZ(2),ABMC2,ABMP)
  1.  Q
  1. DEL ;EP DELETE SECTIONS FROM ORIGINAL CLAIM
  1.  ;K ^ABMDCLM(DUZ(2),ABMC2,13)
  1.  F I=1:1:10 D
  1.  .S ABMPG=$P("8A^8B^8C^8D^8E^8F^8G^8H^8I^8J","^",I)
  1.  .S ABMSEC=$P("27^21^25^23^37^35^39^43^33^45","^",I)
  1.  .I ABMY("PGS")[ABMPG K ^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMSEC)
  1.  .Q:ABMY("PGS")["8Z"
  1.  .;I '(ABMY("PGS")[ABMPG) K ^ABMDCLM(DUZ(2),ABMC2,ABMSEC)
  1.  Q
  1. DELSUB ;EP
  1.  S DA=ABMD
  1.  S DA(1)=ABMC2
  1.  S DIK="^ABMDCLM(DUZ(2),"_DA(1)_","_ABMP_","
  1.  D ^DIK
  1.  Q
  1. REINDEX(X) ;EP
  1.  S DA=X
  1.  K ^ABMDCLM(DUZ(2),DA,"ASRC")
  1.  S DIK="^ABMDCLM(DUZ(2),"
  1.  D IX1^DIK
  1.  Q