BDPLINKI ; IHS/CMI/TMJ - LINK ROUTINE ON PARM PASS FROM THE DESG PROV PKG ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
;
;
START ;Get Record Information
;
;
UPDATE(BDPFILE,BDPFIELD,BDPDA,BDPPROV,BDPPAT,BDPLINKI) ;PEP Update Record
I '$G(BDPLINKI) Q ;don't process if coming from non-bdp
;this entry point is called from xrefs on various
;files/fields to update the current designated
;provider package
;called from 90360.1
;
;I $G(BDPLNKO)=1 Q ;Quit this routine - BDPKLINKO is running
;
I $G(BDPFILE)=9002086,$$INSTALLD("BW.3.0") Q ;not with version 3.0
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^BDPLINKI","BDPFILE;BDPFIELD;BDPDA;BDPPROV;BDPPAT;BDPLINKI")
Q
;
UPDATE1 ;
;special code to take care of 9000001 file 6/200 issue
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
;
;
CKLINK ;Check which File to Populate
;
S BDPTYPE=$P($G(^BDPRECN(BDPDA,0)),U) ;Get Type
Q:BDPTYPE=""
I BDPTYPE=2 D MHLINK Q
I BDPTYPE=3 D SSLINK Q
I BDPTYPE=4 D CDLINK Q
I BDPTYPE=8 D WHLINK Q
I BDPTYPE=1 D DPLINK Q
E Q ;Quit if no Link
Q
;
MHLINK ;Update the Desg. Spec. Provider Record
;This Adds a new record if none exist
;Updates the existing Patient Record if different Provider
S BDPMHIEN=$O(^AMHPATR("B",BDPPAT,"")) ;MHIEN RECORD
Q:BDPMHIEN="" ;Quit if no Record found for this patient
S BDPPRVCK=$P($G(^AMHPATR(BDPMHIEN,0)),U,2) ;Existing MH Prov
Q:BDPPRVCK=BDPPROV ;Quit if same Provider
S DIE="^AMHPATR(",DA=BDPMHIEN,DR=".02///"_"`"_BDPPROV D ^DIE K DIE,DR,DA,DINUM
Q
;
SSLINK ;Social Services Update
;This Adds a new record if none exist
;Updates the existing Patient Record if different Provider
S BDPSSIEN=$O(^AMHPATR("B",BDPPAT,"")) ;SSIEN RECORD
Q:BDPSSIEN="" ;Quit if no Record found for this patient
S BDPPRVCK=$P($G(^AMHPATR(BDPSSIEN,0)),U,3) ;Existing SS Prov
Q:BDPPRVCK=BDPPROV ;Quit if same Provider
S DIE="^AMHPATR(",DA=BDPSSIEN,DR=".03///"_"`"_BDPPROV D ^DIE K DIE,DR,DA,DINUM
Q
;
;
CDLINK ;Chemical Dependency Link Update
;This Adds a new record if none exist
;Updates the existing Patient Record if different Provider
S BDPCDIEN=$O(^AMHPATR("B",BDPPAT,"")) ;CDIEN RECORD
Q:BDPCDIEN="" ;Quit if no Record found for this patient
S BDPPRVCK=$P($G(^AMHPATR(BDPCDIEN,0)),U,4) ;Existing CD Prov
Q:BDPPRVCK=BDPPROV ;Quit if same Provider
S DIE="^AMHPATR(",DA=BDPCDIEN,DR=".04///"_"`"_BDPPROV D ^DIE K DIE,DR,DA,DINUM
Q
;
WHLINK ;Womens Health Update
;This Adds a new record if none exist
;Updates the existing Patient Record if different Provider
S BDPWHIEN=$O(^BWP("B",BDPPAT,"")) ;WHIEN RECORD
Q:BDPWHIEN="" ;Quit if no Record found for this patient
S BDPPRVCK=$P($G(^BWP(BDPWHIEN,0)),U,10) ;Existing WH Prov
Q:BDPPRVCK=BDPPROV ;Quit if same Provider
S DIE="^BWP(",DA=BDPWHIEN,DR=".1///"_"`"_BDPPROV D ^DIE K DIE,DR,DA,DINUM
Q
;
DPLINK ;Patient Primary Care Provider Update
;This Adds a new record if none exist
;Updates the existing Patient Record if different Provider
S BDPDPIEN=$O(^AUPNPAT("B",BDPPAT,"")) ;DPIEN RECORD
Q:BDPDPIEN="" ;Quit if no Record found for this patient
S BDPPRVCK=$P($G(^AUPNPAT(BDPDPIEN,0)),U,14) ;Existing DPP Prov
Q:BDPPRVCK=BDPPROV ;Quit if same Provider
S DIE="^AUPNPAT(",DA=BDPDPIEN,DR=".14///"_"`"_BDPPROV D ^DIE K DIE,DR,DA,DINUM
Q
;
;
;
;
KILL(BDPFILE,BDPFIELD,BDPDA,BDPPROV,BDPPAT,BDPLINKI) ;PEP - called from kill side of xrefs
I '$G(BDPLINKI) Q ;don't process if coming from non-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^BDPLINKI","BDPFILE;BDPFIELD;BDPDA;BDPPROV;BDPPAT;BDPLINKI")
Q
KILL1 ;EP - CALLED FROM XBNEW
;This Adds a new record if none exist
;Updates the existing Patient Record if different Provider
;
S BDPTYPE=$P($G(^BDPRECN(BDPDA,0)),U) ;Get Type
Q:BDPTYPE=""
I BDPTYPE=2 D MHKILL Q
I BDPTYPE=3 D SSKILL Q
I BDPTYPE=4 D CDKILL Q
I BDPTYPE=8 D WHKILL Q
I BDPTYPE=1 D DPKILL Q
E Q ;Quit if no Link
Q
;
;
MHKILL ;Kill Mental Health Record
S BDPMHIEN=$O(^AMHPATR("B",BDPPAT,"")) ;MHIEN RECORD
Q:BDPMHIEN="" ;Quit if no Record found for this patient
S BDPPRVCK=$P($G(^AMHPATR(BDPMHIEN,0)),U,2) ;Existing MH Prov
;Q:BDPPRVCK=BDPPROV ;Quit if same Provider
;Q:BDPTYIEN="" ;Quit if this type is not linked
;Q:BDPRIEN="" ;NO entry of this type for this patient
;now delete last current provider field
S DIE="^AMHPATR(",DA=BDPMHIEN,DR=".02///@" D ^DIE
D ^XBFMK
Q
;
SSKILL ;Social Services Kill
S BDPSSIEN=$O(^AMHPATR("B",BDPPAT,"")) ;SSIEN RECORD
Q:BDPSSIEN="" ;Quit if no Record found for this patient
S BDPPRVCK=$P($G(^AMHPATR(BDPSSIEN,0)),U,3) ;Existing SS Prov
;Q:BDPPRVCK=BDPPROV ;Quit if same Provider
;Q:BDPTYIEN="" ;Quit if this type is not linked
;Q:BDPRIEN="" ;NO entry of this type for this patient
;now delete last current provider field
S DIE="^AMHPATR(",DA=BDPSSIEN,DR=".03///@" D ^DIE
D ^XBFMK
Q
;
CDKILL ;Chemical Dependency Kill
S BDPCDIEN=$O(^AMHPATR("B",BDPPAT,"")) ;CDIEN RECORD
Q:BDPCDIEN="" ;Quit if no Record found for this patient
S BDPPRVCK=$P($G(^AMHPATR(BDPCDIEN,0)),U,4) ;Existing MH Prov
;Q:BDPPRVCK=BDPPROV ;Quit if same Provider
;Q:BDPTYIEN="" ;Quit if this type is not linked
;Q:BDPRIEN="" ;NO entry of this type for this patient
;now delete last current provider field
S DIE="^AMHPATR(",DA=BDPCDIEN,DR=".04///@" D ^DIE
D ^XBFMK
Q
;
WHKILL ;Womens Health Kill
S BDPWHIEN=$O(^BWP("B",BDPPAT,"")) ;WHIEN RECORD
Q:BDPWHIEN="" ;Quit if no Record found for this patient
S BDPPRVCK=$P($G(^BWP(BDPWHIEN,0)),U,10) ;Existing MH Prov
;Q:BDPPRVCK=BDPPROV ;Quit if same Provider
;Q:BDPTYIEN="" ;Quit if this type is not linked
;Q:BDPRIEN="" ;NO entry of this type for this patient
;now delete last current provider field
S DIE="^BWP(",DA=BDPWHIEN,DR=".1///@" D ^DIE
D ^XBFMK
Q
;
DPKILL ;Patient Care Primary Provider Kill
S BDPDPIEN=$O(^AUPNPAT("B",BDPPAT,"")) ;DPIEN RECORD
Q:BDPDPIEN="" ;Quit if no Record found for this patient
S BDPPRVCK=$P($G(^AUPNPAT(BDPDPIEN,0)),U,14) ;Existing MH Prov
;Q:BDPPRVCK=BDPPROV ;Quit if same Provider
;Q:BDPTYIEN="" ;Quit if this type is not linked
;Q:BDPRIEN="" ;NO entry of this type for this patient
;now delete last current provider field
S DIE="^AUPNPAT(",DA=BDPDPIEN,DR=".14///@" D ^DIE
D ^XBFMK
Q
;
INSTALLD(BDPSTAL) ;EP - Determine if patch BDPSTAL was installed, where
; BDPSTAL is the name of the INSTALL. E.g "AG*6.0*11".
;
NEW BDPY,DIC,X,Y
S X=$P(BDPSTAL,"*",1)
S DIC="^DIC(9.4,",DIC(0)="FM",D="C"
D IX^DIC
I Y<1 Q 0
S DIC=DIC_+Y_",22,",X=$P(BDPSTAL,"*",2)
D ^DIC
I Y<1 Q 0
S DIC=DIC_+Y_",""PAH"",",X=$P(BDPSTAL,"*",3)
D ^DIC
S BDPY=Y
Q $S(BDPY<1:0,1:1)
BDPLINKI ; IHS/CMI/TMJ - LINK ROUTINE ON PARM PASS FROM THE DESG PROV PKG ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
+3 ;
+4 ;
START ;Get Record Information
+1 ;
+2 ;
UPDATE(BDPFILE,BDPFIELD,BDPDA,BDPPROV,BDPPAT,BDPLINKI) ;PEP Update Record
+1 ;don't process if coming from non-bdp
IF '$GET(BDPLINKI)
QUIT
+2 ;this entry point is called from xrefs on various
+3 ;files/fields to update the current designated
+4 ;provider package
+5 ;called from 90360.1
+6 ;
+7 ;I $G(BDPLNKO)=1 Q ;Quit this routine - BDPKLINKO is running
+8 ;
+9 ;not with version 3.0
IF $GET(BDPFILE)=9002086
IF $$INSTALLD("BW.3.0")
QUIT
+10 IF $GET(BDPFILE)=""
QUIT
+11 IF $GET(BDPFIELD)=""
QUIT
+12 IF $GET(BDPDA)=""
QUIT
+13 ;bdpprov is the pointer to file 200
IF $GET(BDPPROV)=""
QUIT
+14 IF $GET(BDPPAT)=""
QUIT
+15 DO EN^XBNEW("UPDATE1^BDPLINKI","BDPFILE;BDPFIELD;BDPDA;BDPPROV;BDPPAT;BDPLINKI")
+16 QUIT
+17 ;
UPDATE1 ;
+1 ;special code to take care of 9000001 file 6/200 issue
+2 ;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
+3 ;
+4 ;
CKLINK ;Check which File to Populate
+1 ;
+2 ;Get Type
SET BDPTYPE=$PIECE($GET(^BDPRECN(BDPDA,0)),U)
+3 IF BDPTYPE=""
QUIT
+4 IF BDPTYPE=2
DO MHLINK
QUIT
+5 IF BDPTYPE=3
DO SSLINK
QUIT
+6 IF BDPTYPE=4
DO CDLINK
QUIT
+7 IF BDPTYPE=8
DO WHLINK
QUIT
+8 IF BDPTYPE=1
DO DPLINK
QUIT
+9 ;Quit if no Link
IF '$TEST
QUIT
+10 QUIT
+11 ;
MHLINK ;Update the Desg. Spec. Provider Record
+1 ;This Adds a new record if none exist
+2 ;Updates the existing Patient Record if different Provider
+3 ;MHIEN RECORD
SET BDPMHIEN=$ORDER(^AMHPATR("B",BDPPAT,""))
+4 ;Quit if no Record found for this patient
IF BDPMHIEN=""
QUIT
+5 ;Existing MH Prov
SET BDPPRVCK=$PIECE($GET(^AMHPATR(BDPMHIEN,0)),U,2)
+6 ;Quit if same Provider
IF BDPPRVCK=BDPPROV
QUIT
+7 SET DIE="^AMHPATR("
SET DA=BDPMHIEN
SET DR=".02///"_"`"_BDPPROV
DO ^DIE
KILL DIE,DR,DA,DINUM
+8 QUIT
+9 ;
SSLINK ;Social Services Update
+1 ;This Adds a new record if none exist
+2 ;Updates the existing Patient Record if different Provider
+3 ;SSIEN RECORD
SET BDPSSIEN=$ORDER(^AMHPATR("B",BDPPAT,""))
+4 ;Quit if no Record found for this patient
IF BDPSSIEN=""
QUIT
+5 ;Existing SS Prov
SET BDPPRVCK=$PIECE($GET(^AMHPATR(BDPSSIEN,0)),U,3)
+6 ;Quit if same Provider
IF BDPPRVCK=BDPPROV
QUIT
+7 SET DIE="^AMHPATR("
SET DA=BDPSSIEN
SET DR=".03///"_"`"_BDPPROV
DO ^DIE
KILL DIE,DR,DA,DINUM
+8 QUIT
+9 ;
+10 ;
CDLINK ;Chemical Dependency Link Update
+1 ;This Adds a new record if none exist
+2 ;Updates the existing Patient Record if different Provider
+3 ;CDIEN RECORD
SET BDPCDIEN=$ORDER(^AMHPATR("B",BDPPAT,""))
+4 ;Quit if no Record found for this patient
IF BDPCDIEN=""
QUIT
+5 ;Existing CD Prov
SET BDPPRVCK=$PIECE($GET(^AMHPATR(BDPCDIEN,0)),U,4)
+6 ;Quit if same Provider
IF BDPPRVCK=BDPPROV
QUIT
+7 SET DIE="^AMHPATR("
SET DA=BDPCDIEN
SET DR=".04///"_"`"_BDPPROV
DO ^DIE
KILL DIE,DR,DA,DINUM
+8 QUIT
+9 ;
WHLINK ;Womens Health Update
+1 ;This Adds a new record if none exist
+2 ;Updates the existing Patient Record if different Provider
+3 ;WHIEN RECORD
SET BDPWHIEN=$ORDER(^BWP("B",BDPPAT,""))
+4 ;Quit if no Record found for this patient
IF BDPWHIEN=""
QUIT
+5 ;Existing WH Prov
SET BDPPRVCK=$PIECE($GET(^BWP(BDPWHIEN,0)),U,10)
+6 ;Quit if same Provider
IF BDPPRVCK=BDPPROV
QUIT
+7 SET DIE="^BWP("
SET DA=BDPWHIEN
SET DR=".1///"_"`"_BDPPROV
DO ^DIE
KILL DIE,DR,DA,DINUM
+8 QUIT
+9 ;
DPLINK ;Patient Primary Care Provider Update
+1 ;This Adds a new record if none exist
+2 ;Updates the existing Patient Record if different Provider
+3 ;DPIEN RECORD
SET BDPDPIEN=$ORDER(^AUPNPAT("B",BDPPAT,""))
+4 ;Quit if no Record found for this patient
IF BDPDPIEN=""
QUIT
+5 ;Existing DPP Prov
SET BDPPRVCK=$PIECE($GET(^AUPNPAT(BDPDPIEN,0)),U,14)
+6 ;Quit if same Provider
IF BDPPRVCK=BDPPROV
QUIT
+7 SET DIE="^AUPNPAT("
SET DA=BDPDPIEN
SET DR=".14///"_"`"_BDPPROV
DO ^DIE
KILL DIE,DR,DA,DINUM
+8 QUIT
+9 ;
+10 ;
+11 ;
+12 ;
KILL(BDPFILE,BDPFIELD,BDPDA,BDPPROV,BDPPAT,BDPLINKI) ;PEP - called from kill side of xrefs
+1 ;don't process if coming from non-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^BDPLINKI","BDPFILE;BDPFIELD;BDPDA;BDPPROV;BDPPAT;BDPLINKI")
+8 QUIT
KILL1 ;EP - CALLED FROM XBNEW
+1 ;This Adds a new record if none exist
+2 ;Updates the existing Patient Record if different Provider
+3 ;
+4 ;Get Type
SET BDPTYPE=$PIECE($GET(^BDPRECN(BDPDA,0)),U)
+5 IF BDPTYPE=""
QUIT
+6 IF BDPTYPE=2
DO MHKILL
QUIT
+7 IF BDPTYPE=3
DO SSKILL
QUIT
+8 IF BDPTYPE=4
DO CDKILL
QUIT
+9 IF BDPTYPE=8
DO WHKILL
QUIT
+10 IF BDPTYPE=1
DO DPKILL
QUIT
+11 ;Quit if no Link
IF '$TEST
QUIT
+12 QUIT
+13 ;
+14 ;
MHKILL ;Kill Mental Health Record
+1 ;MHIEN RECORD
SET BDPMHIEN=$ORDER(^AMHPATR("B",BDPPAT,""))
+2 ;Quit if no Record found for this patient
IF BDPMHIEN=""
QUIT
+3 ;Existing MH Prov
SET BDPPRVCK=$PIECE($GET(^AMHPATR(BDPMHIEN,0)),U,2)
+4 ;Q:BDPPRVCK=BDPPROV ;Quit if same Provider
+5 ;Q:BDPTYIEN="" ;Quit if this type is not linked
+6 ;Q:BDPRIEN="" ;NO entry of this type for this patient
+7 ;now delete last current provider field
+8 SET DIE="^AMHPATR("
SET DA=BDPMHIEN
SET DR=".02///@"
DO ^DIE
+9 DO ^XBFMK
+10 QUIT
+11 ;
SSKILL ;Social Services Kill
+1 ;SSIEN RECORD
SET BDPSSIEN=$ORDER(^AMHPATR("B",BDPPAT,""))
+2 ;Quit if no Record found for this patient
IF BDPSSIEN=""
QUIT
+3 ;Existing SS Prov
SET BDPPRVCK=$PIECE($GET(^AMHPATR(BDPSSIEN,0)),U,3)
+4 ;Q:BDPPRVCK=BDPPROV ;Quit if same Provider
+5 ;Q:BDPTYIEN="" ;Quit if this type is not linked
+6 ;Q:BDPRIEN="" ;NO entry of this type for this patient
+7 ;now delete last current provider field
+8 SET DIE="^AMHPATR("
SET DA=BDPSSIEN
SET DR=".03///@"
DO ^DIE
+9 DO ^XBFMK
+10 QUIT
+11 ;
CDKILL ;Chemical Dependency Kill
+1 ;CDIEN RECORD
SET BDPCDIEN=$ORDER(^AMHPATR("B",BDPPAT,""))
+2 ;Quit if no Record found for this patient
IF BDPCDIEN=""
QUIT
+3 ;Existing MH Prov
SET BDPPRVCK=$PIECE($GET(^AMHPATR(BDPCDIEN,0)),U,4)
+4 ;Q:BDPPRVCK=BDPPROV ;Quit if same Provider
+5 ;Q:BDPTYIEN="" ;Quit if this type is not linked
+6 ;Q:BDPRIEN="" ;NO entry of this type for this patient
+7 ;now delete last current provider field
+8 SET DIE="^AMHPATR("
SET DA=BDPCDIEN
SET DR=".04///@"
DO ^DIE
+9 DO ^XBFMK
+10 QUIT
+11 ;
WHKILL ;Womens Health Kill
+1 ;WHIEN RECORD
SET BDPWHIEN=$ORDER(^BWP("B",BDPPAT,""))
+2 ;Quit if no Record found for this patient
IF BDPWHIEN=""
QUIT
+3 ;Existing MH Prov
SET BDPPRVCK=$PIECE($GET(^BWP(BDPWHIEN,0)),U,10)
+4 ;Q:BDPPRVCK=BDPPROV ;Quit if same Provider
+5 ;Q:BDPTYIEN="" ;Quit if this type is not linked
+6 ;Q:BDPRIEN="" ;NO entry of this type for this patient
+7 ;now delete last current provider field
+8 SET DIE="^BWP("
SET DA=BDPWHIEN
SET DR=".1///@"
DO ^DIE
+9 DO ^XBFMK
+10 QUIT
+11 ;
DPKILL ;Patient Care Primary Provider Kill
+1 ;DPIEN RECORD
SET BDPDPIEN=$ORDER(^AUPNPAT("B",BDPPAT,""))
+2 ;Quit if no Record found for this patient
IF BDPDPIEN=""
QUIT
+3 ;Existing MH Prov
SET BDPPRVCK=$PIECE($GET(^AUPNPAT(BDPDPIEN,0)),U,14)
+4 ;Q:BDPPRVCK=BDPPROV ;Quit if same Provider
+5 ;Q:BDPTYIEN="" ;Quit if this type is not linked
+6 ;Q:BDPRIEN="" ;NO entry of this type for this patient
+7 ;now delete last current provider field
+8 SET DIE="^AUPNPAT("
SET DA=BDPDPIEN
SET DR=".14///@"
DO ^DIE
+9 DO ^XBFMK
+10 QUIT
+11 ;
INSTALLD(BDPSTAL) ;EP - Determine if patch BDPSTAL was installed, where
+1 ; BDPSTAL is the name of the INSTALL. E.g "AG*6.0*11".
+2 ;
+3 NEW BDPY,DIC,X,Y
+4 SET X=$PIECE(BDPSTAL,"*",1)
+5 SET DIC="^DIC(9.4,"
SET DIC(0)="FM"
SET D="C"
+6 DO IX^DIC
+7 IF Y<1
QUIT 0
+8 SET DIC=DIC_+Y_",22,"
SET X=$PIECE(BDPSTAL,"*",2)
+9 DO ^DIC
+10 IF Y<1
QUIT 0
+11 SET DIC=DIC_+Y_",""PAH"","
SET X=$PIECE(BDPSTAL,"*",3)
+12 DO ^DIC
+13 SET BDPY=Y
+14 QUIT $SELECT(BDPY<1:0,1:1)
