BDPPASS ; IHS/CMI/TMJ - Routine to Pass data to Designated Provider Package ;
;;2.0;IHS PCC SUITE;**21**;MAY 14, 2009;Build 34
;
;This Routine creates a new entry or edits an existing entry
;of the Desginated Specialty Provider Management System
;BDPDFN = Patient DFN Number
;BDPTYPE = Internal IEN # of Provider Type File #90360.3
;BDPRPRVP = Internal IEN of Provider Name
;
;
;
CREATE(BDPDFN,BDPTYPE,BDPRPRVP) ;EP - Entry Point to Create
;
N BDPRR,BDPLINKI,BDPLPROV,BDPRIEN,BDPLINKI
;
S BDPQ=1
S BDPLINKI=1 ;tell xrefs we are in bdp
S BDPRPROV=$P($G(^VA(200,BDPRPRVP,0)),U) ;Provider Text Name
S BDPRR=$O(^BDPRECN("AA",BDPDFN,BDPTYPE,"")) ;Check to see if this Patient already has Type
I BDPRR="" D ADDNEW Q BDPQ ;NONE OF THIS TYPE
S BDPLPROV=$P($G(^BDPRECN(BDPRR,0)),U,3) ;Current Provider
Q:BDPLPROV=BDPRPRVP 0 ;Quit if Same Provider Selected as Current
S BDPRIEN=BDPRR D MOD Q 0
Q 0
;
ADDNEW ;Add a new Record
S DIC="^BDPRECN(",DIC(0)="L",DLAYGO=90360.1,DIC("DR")=".02////"_BDPDFN,X=BDPTYPE
D FILE^BDPFMC
I Y<0 W !,"Error creating DESIGNATED PROVIDER.",!,"Notify programmer.",! D EOP^BDP Q
;
S BDPRIEN=+Y
;S X="`"_BDPRPRVP,DIC="^BDPRECN("_BDPRIEN_",1,",DA(1)=BDPRIEN,DIC(0)="L",DIC("P")=$P(^DD(90360.1,.06,0),U,2) D ^DIC K DIC,DA,DR,Y,X,DIADD,DLAYGO D ^XBFMK
S X="`"_BDPRPRVP,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 D ^XBFMK ;IHS/CMI/LAB - PATCH 21 ADDED SETTING OF .04 EFFECTIVE DATE
S BDPQ=0
K BDPLINKI
Q
;
MOD ;Modify an Existing Provider Type for this Patient
S BDPLINKI=1
;FIND THE LAST MULTIPLE AND SET .05 EQUAL TO DT, .02 AND .03
S Z=0,X=0 F S X=$O(^BDPRECN(BDPRIEN,1,X)) Q:X'=+X I $P(^BDPRECN(BDPRIEN,1,X,0),U,1)=BDPLPROV S Z=X
I Z,$P(^BDPRECN(BDPRIEN,1,Z,0),U,5)="" S DIE="^BDPRECN("_BDPRIEN_",1,",DA(1)=BDPRIEN,DA=Z,DR=".02////"_DUZ_";.03////"_DT_";.05////"_DT D ^DIE K DIE,DR,DA,DINUM,X,Y,Z
;S X="`"_BDPRPRVP,DIC="^BDPRECN("_BDPRIEN_",1,",DA(1)=BDPRIEN,DIC(0)="L",DIC("P")=$P(^DD(90360.1,.06,0),U,2) D ^DIC K DIC,DA,DR,Y,X,DIADD,DLAYGO D ^XBFMK
K X,DIC
;IHS/CMI/LAB - ADDED SETTING OF .04 EFFECTIVE DATE PATCH 21
S DIADD=1,X="`"_BDPRPRVP,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,X,DIADD,DLAYGO
I Y=-1 S BDPQ=0 Q
K DIC,DA,DR,Y,X,DIADD,DLAYGO D ^XBFMK
;SET 0 NODE FIELDS
S DIE="^BDPRECN(",DA=BDPRIEN,DR=".03///`"_BDPRPRVP_";.04////"_DUZ_";.05////"_DT D ^DIE,^XBFMK
S BDPQ=0
K BDPLINKI
Q
;
;
DELETE ;EP Delete a Designated Provider
;user must set BDPPAT,BDPTYPE
NEW BDPIEN,BDPLINKI,DIE,DA,DR,DINUM,X,Y,BDPPROV
S BDPLINKI=1
;
;
S BDPIEN=$O(^BDPRECN("AA",BDPPAT,BDPTYPE,"")) ;Get Existing
I BDPIEN="" Q ;Quit if no Existing Record
;
S BDPPROV=$P(^BDPRECN(BDPIEN,0),U,3)
;
S DIE="^BDPRECN(",DA=BDPIEN,DR=".03///@;.04////"_DUZ_";.05////"_DT D ^DIE K DIE,DR,DA,DINUM
;SET INACTIVE DATE IN MULTIPLE PLUS .02 AND .03
;FIND THE LAST MULTIPLE AND SET .05 EQUAL TO DT, .02 AND .03
S X=0 F S X=$O(^BDPRECN(BDPIEN,1,X)) Q:X'=+X I $P(^BDPRECN(BDPIEN,1,X,0),U,1)=BDPPROV S Y=X
I Y,$P(^BDPRECN(BDPIEN,1,Y,0),U,5)="" S DIE="^BDPRECN("_BDPIEN_",1,",DA(1)=BDPIEN,DA=Y,DR=".02////"_DUZ_";.03////"_DT_";.05////"_DT D ^DIE K DIE,DR,DA,DINUM
K BDPLINKI
Q
EOJ ; END OF JOB
K BDPLINKI
Q
;
BDPPASS ; IHS/CMI/TMJ - Routine to Pass data to Designated Provider Package ;
+1 ;;2.0;IHS PCC SUITE;**21**;MAY 14, 2009;Build 34
+2 ;
+3 ;This Routine creates a new entry or edits an existing entry
+4 ;of the Desginated Specialty Provider Management System
+5 ;BDPDFN = Patient DFN Number
+6 ;BDPTYPE = Internal IEN # of Provider Type File #90360.3
+7 ;BDPRPRVP = Internal IEN of Provider Name
+8 ;
+9 ;
+10 ;
CREATE(BDPDFN,BDPTYPE,BDPRPRVP) ;EP - Entry Point to Create
+1 ;
+2 NEW BDPRR,BDPLINKI,BDPLPROV,BDPRIEN,BDPLINKI
+3 ;
+4 SET BDPQ=1
+5 ;tell xrefs we are in bdp
SET BDPLINKI=1
+6 ;Provider Text Name
SET BDPRPROV=$PIECE($GET(^VA(200,BDPRPRVP,0)),U)
+7 ;Check to see if this Patient already has Type
SET BDPRR=$ORDER(^BDPRECN("AA",BDPDFN,BDPTYPE,""))
+8 ;NONE OF THIS TYPE
IF BDPRR=""
DO ADDNEW
QUIT BDPQ
+9 ;Current Provider
SET BDPLPROV=$PIECE($GET(^BDPRECN(BDPRR,0)),U,3)
+10 ;Quit if Same Provider Selected as Current
IF BDPLPROV=BDPRPRVP
QUIT 0
+11 SET BDPRIEN=BDPRR
DO MOD
QUIT 0
+12 QUIT 0
+13 ;
ADDNEW ;Add a new Record
+1 SET DIC="^BDPRECN("
SET DIC(0)="L"
SET DLAYGO=90360.1
SET DIC("DR")=".02////"_BDPDFN
SET X=BDPTYPE
+2 DO FILE^BDPFMC
+3 IF Y<0
WRITE !,"Error creating DESIGNATED PROVIDER.",!,"Notify programmer.",!
DO EOP^BDP
QUIT
+4 ;
+5 SET BDPRIEN=+Y
+6 ;S X="`"_BDPRPRVP,DIC="^BDPRECN("_BDPRIEN_",1,",DA(1)=BDPRIEN,DIC(0)="L",DIC("P")=$P(^DD(90360.1,.06,0),U,2) D ^DIC K DIC,DA,DR,Y,X,DIADD,DLAYGO D ^XBFMK
+7 ;IHS/CMI/LAB - PATCH 21 ADDED SETTING OF .04 EFFECTIVE DATE
SET X="`"_BDPRPRVP
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
DO ^XBFMK
+8 SET BDPQ=0
+9 KILL BDPLINKI
+10 QUIT
+11 ;
MOD ;Modify an Existing Provider Type for this Patient
+1 SET BDPLINKI=1
+2 ;FIND THE LAST MULTIPLE AND SET .05 EQUAL TO DT, .02 AND .03
+3 SET Z=0
SET X=0
FOR
SET X=$ORDER(^BDPRECN(BDPRIEN,1,X))
IF X'=+X
QUIT
IF $PIECE(^BDPRECN(BDPRIEN,1,X,0),U,1)=BDPLPROV
SET Z=X
+4 IF Z
IF $PIECE(^BDPRECN(BDPRIEN,1,Z,0),U,5)=""
SET DIE="^BDPRECN("_BDPRIEN_",1,"
SET DA(1)=BDPRIEN
SET DA=Z
SET DR=".02////"_DUZ_";.03////"_DT_";.05////"_DT
DO ^DIE
KILL DIE,DR,DA,DINUM,X,Y,Z
+5 ;S X="`"_BDPRPRVP,DIC="^BDPRECN("_BDPRIEN_",1,",DA(1)=BDPRIEN,DIC(0)="L",DIC("P")=$P(^DD(90360.1,.06,0),U,2) D ^DIC K DIC,DA,DR,Y,X,DIADD,DLAYGO D ^XBFMK
+6 KILL X,DIC
+7 ;IHS/CMI/LAB - ADDED SETTING OF .04 EFFECTIVE DATE PATCH 21
+8 SET DIADD=1
SET X="`"_BDPRPRVP
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,X,DIADD,DLAYGO
+9 IF Y=-1
SET BDPQ=0
QUIT
+10 KILL DIC,DA,DR,Y,X,DIADD,DLAYGO
DO ^XBFMK
+11 ;SET 0 NODE FIELDS
+12 SET DIE="^BDPRECN("
SET DA=BDPRIEN
SET DR=".03///`"_BDPRPRVP_";.04////"_DUZ_";.05////"_DT
DO ^DIE
DO ^XBFMK
+13 SET BDPQ=0
+14 KILL BDPLINKI
+15 QUIT
+16 ;
+17 ;
DELETE ;EP Delete a Designated Provider
+1 ;user must set BDPPAT,BDPTYPE
+2 NEW BDPIEN,BDPLINKI,DIE,DA,DR,DINUM,X,Y,BDPPROV
+3 SET BDPLINKI=1
+4 ;
+5 ;
+6 ;Get Existing
SET BDPIEN=$ORDER(^BDPRECN("AA",BDPPAT,BDPTYPE,""))
+7 ;Quit if no Existing Record
IF BDPIEN=""
QUIT
+8 ;
+9 SET BDPPROV=$PIECE(^BDPRECN(BDPIEN,0),U,3)
+10 ;
+11 SET DIE="^BDPRECN("
SET DA=BDPIEN
SET DR=".03///@;.04////"_DUZ_";.05////"_DT
DO ^DIE
KILL DIE,DR,DA,DINUM
+12 ;SET INACTIVE DATE IN MULTIPLE PLUS .02 AND .03
+13 ;FIND THE LAST MULTIPLE AND SET .05 EQUAL TO DT, .02 AND .03
+14 SET X=0
FOR
SET X=$ORDER(^BDPRECN(BDPIEN,1,X))
IF X'=+X
QUIT
IF $PIECE(^BDPRECN(BDPIEN,1,X,0),U,1)=BDPPROV
SET Y=X
+15 IF Y
IF $PIECE(^BDPRECN(BDPIEN,1,Y,0),U,5)=""
SET DIE="^BDPRECN("_BDPIEN_",1,"
SET DA(1)=BDPIEN
SET DA=Y
SET DR=".02////"_DUZ_";.03////"_DT_";.05////"_DT
DO ^DIE
KILL DIE,DR,DA,DINUM
+16 KILL BDPLINKI
+17 QUIT
EOJ ; END OF JOB
+1 KILL BDPLINKI
+2 QUIT
+3 ;
