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

BPHRUPD.m

Go to the documentation of this file. 
  1. BPHRUPD ;GDIT/HS/ALA-Update parameters ; 05 Aug 2013  1:57 PM
  1.  ;;2.1;IHS PERSONAL HEALTH RECORD;**1,2**;Apr 01, 2014;Build 4
  1.  Q
  1.  ;
  1. WEB ;EP - Update Web Services
  1.  ; Add a new service and update the associated fields
  1.  ; Edit an existing service's associated fields
  1.  NEW DA,DIC,DIE,DR,Y,DLAYGO,DIR,X,DIRUT,DUOUT
  1.  S DIR(0)="S^1:TEST PHR SERVER;2:PRODUCTION PHR SERVER"
  1.  D ^DIR I Y="^"!(Y="") Q
  1.  S DA=Y
  1.  ;
  1.  S DIC="^BPHR(90670.2,",DIC(0)="AELMNZ",DIE=DIC,DR="[BPHR ADD/EDIT WEB SERVICE]"
  1.  ;S DLAYGO=90670.2 D ^DIC S DA=+Y
  1.  D ^DIE
  1.  Q
  1.  ;
  1. ITR ;EP - Input Transform
  1.  I $L(X)>40!($L(X)<1) K X Q
  1.  I $E(X,1,8)'="https://" K X Q
  1.  Q
  1.  ;
  1. PROV(PROV) ;EP = Provider DIRECT address
  1.  NEW FACAD,MAD,NCOMP,NAME,VALUE,FN,LN
  1.  S ADDR=""
  1.  I $G(PROV)="" Q ADDR
  1.  S FACAD=$P($G(^AUTTLOC(DUZ(2),21)),"^",5)
  1.  I FACAD="" Q ADDR
  1.  I FACAD'="" S MAD=$P(FACAD,"@",2)
  1.  S NCOMP=$P($G(^VA(200,PROV,3.1)),"^",1)
  1.  I NCOMP'="" D
  1.  . S FN=$P($G(^VA(20,NCOMP,1)),"^",2),FN=$$STRIP^XLFSTR(FN," "),FN=$$PUNC(FN)
  1.  . S LN=$P($G(^VA(20,NCOMP,1)),"^",1),LN=$$STRIP^XLFSTR(LN," "),LN=$$PUNC(LN)
  1.  . S VALUE=$$LOW^XLFSTR(FN)_"."_$$LOW^XLFSTR(LN)
  1.  . I $G(VALUE)=""!($G(VALUE)=".") S NCOMP=""
  1.  ;
  1.  I NCOMP="" D
  1.  . S NAME=$P(^VA(200,PROV,0),"^",1)
  1.  . D STDNAME^XLFNAME(.NAME,"FC")
  1.  . S FN=$G(NAME("GIVEN")),FN=$$STRIP^XLFSTR(FN," "),FN=$$PUNC(FN)
  1.  . S LN=$G(NAME("FAMILY")),LN=$$STRIP^XLFSTR(LN," "),LN=$$PUNC(LN)
  1.  . S VALUE=$$LOW^XLFSTR(FN)_"."_$$LOW^XLFSTR(LN)
  1.  ;
  1.  S ADDR=VALUE_"@"_MAD
  1.  Q ADDR
  1.  ;
  1. AGNT(DFN) ;EP = Messaging Agent for Patient
  1.  NEW BDPCAT,BDPIEN,MSA,BPA,AGN,ADR,BPDATA,NBP,OK
  1.  S ADDR=""
  1.  S BDPCAT=$$FIND1^DIC(90360.3,,"X","MESSAGE AGENT")
  1.  I BDPCAT="" Q ADDR
  1.  S BDPIEN=$O(^BDPRECN("AA",DFN,BDPCAT,""))
  1.  I BDPIEN="" Q ADDR
  1.  S BPA=0
  1.  F  S BPA=$O(^BDPRECN(BDPIEN,1,BPA)) Q:'BPA  D
  1.  . S BPDATA=^BDPRECN(BDPIEN,1,BPA,0)
  1.  . S MSA=$P(^BDPRECN(BDPIEN,1,BPA,0),"^",1)
  1.  . S AGN(BPA)=MSA_"^"_$P(BPDATA,"^",3)
  1.  . S AGN(BPA)=MSA_"^"_$P(BPDATA,"^",3),LBP=BPA
  1.  . ; Check the next agent in the history
  1.  . S NBP=$O(^BDPRECN(BDPIEN,1,BPA)) I 'NBP D  Q
  1.  .. S QL=0 D CMA^BPHRCHK
  1.  .. I 'QL S $P(AGN(BPA),"^",3)=DT Q
  1.  .. I QL S $P(AGN(BPA),"^",3)=CDT
  1.  . S $P(AGN(BPA),"^",3)=$P(^BDPRECN(BDPIEN,1,NBP,0),"^",3)
  1.  ;
  1.  I CURR'="",$P(^BDPRECN(BDPIEN,1,LBP,0),"^",1)'=CURR D
  1.  . S AGN(LBP+1)=CURR_"^"_CDT_"^"_DT
  1.  ;
  1.  S MS="" F  S MS=$O(AGN(MS)) Q:MS=""  D
  1.  . S OK=0
  1.  . I EDT<$P(AGN(MS),"^",2)!(BDT>$P(AGN(MS),"^",3)) Q
  1.  . I BDT'<$P(AGN(MS),"^",2),BDT'>$P(AGN(MS),"^",3) S OK=1
  1.  . I EDT'<$P(AGN(MS),"^",2),EDT'>$P(AGN(MS),"^",3) S OK=1
  1.  . ;
  1.  . I BDT'>$P(AGN(MS),"^",2),EDT'<$P(AGN(MS),"^",2) S OK=1
  1.  . I BDT'>$P(AGN(MS),"^",3),EDT'<$P(AGN(MS),"^",3) S OK=1
  1.  . ;
  1.  . I OK D
  1.  .. S MSA=$P(AGN(MS),"^",1)
  1.  .. S ADR=$$LOW^XLFSTR($P($G(^BDPMSGA(MSA,0)),"^",2))
  1.  .. I ADR'["direct" Q
  1.  .. S ADDR=ADDR_ADR_","
  1.  Q ADDR
  1.  ;
  1. PUNC(X) ;EP
  1.  Q $TR(X,"`~!@#$%^&*()-_=+\|[{]};:'"",<.>/?","")