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

BDPLINKO.m

Go to the documentation of this file. 
  1. BDPLINKO ; IHS/CMI/TMJ - LINK ROUTINE ON PARM PASS TO THE DESG PROV PKG ;
  1.  ;;2.0;IHS PCC SUITE;**21**;MAY 14, 2009;Build 34
  1.  ;
  1.  ;
  1.  ;
  1. START ;Get Record Information
  1. UPDATE(BDPFILE,BDPFIELD,BDPDA,BDPPROV,BDPPAT) ;PEP - published entry point
  1.  ;THIS NEEDS UPDATED FOR PATCH 21
  1.  ;this entry point is called from xrefs on various
  1.  ;files/fields to update the current designated
  1.  ;provider package
  1.  ;called from 9002011.55, 9000001
  1.  I $G(BDPLINKI) Q  ;don't process if coming from bdp
  1.  I $G(BDPFILE)="" Q
  1.  I $G(BDPFIELD)="" Q
  1.  I $G(BDPDA)="" Q
  1.  I $G(BDPPROV)="" Q  ;bdpprov is the pointer to file 200
  1.  I $G(BDPPAT)="" Q
  1.  D EN^XBNEW("UPDATE1^BDPLINKO","BDPFILE;BDPFIELD;BDPDA;BDPPROV;BDPPAT;BDPLINKI")
  1.  Q
  1.  ;
  1. UPDATE1 ;
  1.  ;special code to take care of 9000001 file 6/200 issue
  1.  ;
  1.  ;S BDPLINKO=1 ;Sets Variable to determine to invoke Routine BDPLO
  1.  ;
  1.  I BDPFILE=9000001,$P(^DD(9000001,.14,0),U,2)[6 S BDPPROV=$P(^VA(200,BDPPROV,0),U,16) I BDPPROV="" Q  ;can't process if no file 200 ptr
  1.  S BDPTYIEN=$O(^BDPTCAT("AF",BDPFILE,BDPFIELD,0)) ;Get Type IEN
  1.  Q:BDPTYIEN=""  ;Quit if this type is not linked
  1.  S BDPRIEN=$O(^BDPRECN("AA",BDPPAT,BDPTYIEN,0))
  1.  I BDPRIEN="" D ADD Q:BDPRIEN=""   ;add entry to file, quit if it failed
  1.  ;now update multiple
  1.  ;if the last one in the multiple by date matches the one being passed
  1.  ;then just update the .03 field, otherwise populate the multiple
  1.  S BDPLAST=""
  1.  S X=0 F  S X=$O(^BDPRECN(BDPRIEN,1,X)) Q:X'=+X  S BDPLAST=$P($G(^BDPRECN(BDPRIEN,1,X,0)),U)
  1.  D ADDM ;the last one doesn't match this new one so go add to multiple
  1.  ;just update .03 since last entry in mulitple is this provider
  1.  D ^XBFMK S DIE="^BDPRECN(",DA=BDPRIEN,DR=".03///`"_BDPPROV_";.04////"_DUZ_";.05////"_DT D ^DIE,^XBFMK
  1.  Q
  1. ADDM ;
  1.  ;add to multiple of BDPRIEN using FILE^DICN
  1.  S DIADD=1,X="`"_BDPPROV,DIC="^BDPRECN("_BDPRIEN_",1,",DA(1)=BDPRIEN,DIC(0)="L",DIC("P")=$P(^DD(90360.1,.06,0),U,2),DIC("DR")=".04////"_DT D ^DIC K DIC,DA,DR,Y,X,DIADD,DLAYGO
  1.  Q
  1. ADD ;
  1.  D ^XBFMK K DIADD,DLAYGO
  1.  S DIC="^BDPRECN(",DIC(0)="L",DLAYGO=90360.1,DIC("DR")=".02////"_BDPPAT,X=BDPTYIEN
  1.  D FILE^DICN
  1.  I Y=-1 Q
  1.  S BDPRIEN=+Y
  1.  D ^XBFMK K DIADD,DLAYGO
  1.  Q
  1. KILL(BDPFILE,BDPFIELD,BDPDA,BDPPROV,BDPPAT) ;PEP - called from kill side of xrefs
  1.  I $G(BDPLINKI) Q  ;don't process if bdp
  1.  I $G(BDPFILE)="" Q
  1.  I $G(BDPFIELD)="" Q
  1.  I $G(BDPDA)="" Q
  1.  I $G(BDPPROV)="" Q  ;bdpprov is the pointer to file 200
  1.  I $G(BDPPAT)="" Q
  1.  D EN^XBNEW("KILL1^BDPLINKO","BDPFILE;BDPFIELD;BDPDA;BDPPROV;BDPPAT;BDPLINKI")
  1.  Q
  1. KILL1 ;EP - CALLED FROM XBNEW
  1.  S BDPTYIEN=$O(^BDPTCAT("AF",BDPFILE,BDPFIELD,0)) ;Get Type IEN
  1.  Q:BDPTYIEN=""  ;Quit if this type is not linked
  1.  S BDPRIEN=$O(^BDPRECN("AA",BDPPAT,BDPTYIEN,0))
  1.  Q:BDPRIEN=""  ;NO entry of this type for this patient
  1.  ;now delete last current provider field
  1.  S DIE="^BDPRECN(",DA=BDPRIEN,DR=".03///@;.04////"_DUZ_";.05////"_DT D ^DIE
  1.  D ^XBFMK
  1.  S X=0 F  S X=$O(^BDPRECN(BDPRIEN,1,X)) Q:X'=+X  S Y=X
  1.  I Y,$P(^BDPRECN(BDPRIEN,1,Y,0),U,5)="" S DIE="^BDPRECN("_BDPRIEN_",1,",DA(1)=BDPRIEN,DA=Y,DR=".02////"_DUZ_";.03////"_DT_";.05////"_DT D ^DIE K DIE,DR,DA,DINUM
  1.  D ^XBFMK
  1.  Q