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

BDPPASS.m

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