Routine: BDPLINKI

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")

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

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

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

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

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

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

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")

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

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

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

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

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

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

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)

BDPLINKI.m