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