BPHRUPD ;GDIT/HS/ALA-Update parameters ; 05 Aug 2013 1:57 PM
;;2.1;IHS PERSONAL HEALTH RECORD;**1,2**;Apr 01, 2014;Build 4
Q
;
WEB ;EP - Update Web Services
; Add a new service and update the associated fields
; Edit an existing service's associated fields
NEW DA,DIC,DIE,DR,Y,DLAYGO,DIR,X,DIRUT,DUOUT
S DIR(0)="S^1:TEST PHR SERVER;2:PRODUCTION PHR SERVER"
D ^DIR I Y="^"!(Y="") Q
S DA=Y
;
S DIC="^BPHR(90670.2,",DIC(0)="AELMNZ",DIE=DIC,DR="[BPHR ADD/EDIT WEB SERVICE]"
;S DLAYGO=90670.2 D ^DIC S DA=+Y
D ^DIE
Q
;
ITR ;EP - Input Transform
I $L(X)>40!($L(X)<1) K X Q
I $E(X,1,8)'="https://" K X Q
Q
;
PROV(PROV) ;EP = Provider DIRECT address
NEW FACAD,MAD,NCOMP,NAME,VALUE,FN,LN
S ADDR=""
I $G(PROV)="" Q ADDR
S FACAD=$P($G(^AUTTLOC(DUZ(2),21)),"^",5)
I FACAD="" Q ADDR
I FACAD'="" S MAD=$P(FACAD,"@",2)
S NCOMP=$P($G(^VA(200,PROV,3.1)),"^",1)
I NCOMP'="" D
. S FN=$P($G(^VA(20,NCOMP,1)),"^",2),FN=$$STRIP^XLFSTR(FN," "),FN=$$PUNC(FN)
. S LN=$P($G(^VA(20,NCOMP,1)),"^",1),LN=$$STRIP^XLFSTR(LN," "),LN=$$PUNC(LN)
. S VALUE=$$LOW^XLFSTR(FN)_"."_$$LOW^XLFSTR(LN)
. I $G(VALUE)=""!($G(VALUE)=".") S NCOMP=""
;
I NCOMP="" D
. S NAME=$P(^VA(200,PROV,0),"^",1)
. D STDNAME^XLFNAME(.NAME,"FC")
. S FN=$G(NAME("GIVEN")),FN=$$STRIP^XLFSTR(FN," "),FN=$$PUNC(FN)
. S LN=$G(NAME("FAMILY")),LN=$$STRIP^XLFSTR(LN," "),LN=$$PUNC(LN)
. S VALUE=$$LOW^XLFSTR(FN)_"."_$$LOW^XLFSTR(LN)
;
S ADDR=VALUE_"@"_MAD
Q ADDR
;
AGNT(DFN) ;EP = Messaging Agent for Patient
NEW BDPCAT,BDPIEN,MSA,BPA,AGN,ADR,BPDATA,NBP,OK
S ADDR=""
S BDPCAT=$$FIND1^DIC(90360.3,,"X","MESSAGE AGENT")
I BDPCAT="" Q ADDR
S BDPIEN=$O(^BDPRECN("AA",DFN,BDPCAT,""))
I BDPIEN="" Q ADDR
S BPA=0
F S BPA=$O(^BDPRECN(BDPIEN,1,BPA)) Q:'BPA D
. S BPDATA=^BDPRECN(BDPIEN,1,BPA,0)
. S MSA=$P(^BDPRECN(BDPIEN,1,BPA,0),"^",1)
. S AGN(BPA)=MSA_"^"_$P(BPDATA,"^",3)
. S AGN(BPA)=MSA_"^"_$P(BPDATA,"^",3),LBP=BPA
. ; Check the next agent in the history
. S NBP=$O(^BDPRECN(BDPIEN,1,BPA)) I 'NBP D Q
.. S QL=0 D CMA^BPHRCHK
.. I 'QL S $P(AGN(BPA),"^",3)=DT Q
.. I QL S $P(AGN(BPA),"^",3)=CDT
. S $P(AGN(BPA),"^",3)=$P(^BDPRECN(BDPIEN,1,NBP,0),"^",3)
;
I CURR'="",$P(^BDPRECN(BDPIEN,1,LBP,0),"^",1)'=CURR D
. S AGN(LBP+1)=CURR_"^"_CDT_"^"_DT
;
S MS="" F S MS=$O(AGN(MS)) Q:MS="" D
. S OK=0
. I EDT<$P(AGN(MS),"^",2)!(BDT>$P(AGN(MS),"^",3)) Q
. I BDT'<$P(AGN(MS),"^",2),BDT'>$P(AGN(MS),"^",3) S OK=1
. I EDT'<$P(AGN(MS),"^",2),EDT'>$P(AGN(MS),"^",3) S OK=1
. ;
. I BDT'>$P(AGN(MS),"^",2),EDT'<$P(AGN(MS),"^",2) S OK=1
. I BDT'>$P(AGN(MS),"^",3),EDT'<$P(AGN(MS),"^",3) S OK=1
. ;
. I OK D
.. S MSA=$P(AGN(MS),"^",1)
.. S ADR=$$LOW^XLFSTR($P($G(^BDPMSGA(MSA,0)),"^",2))
.. I ADR'["direct" Q
.. S ADDR=ADDR_ADR_","
Q ADDR
;
PUNC(X) ;EP
Q $TR(X,"`~!@#$%^&*()-_=+\|[{]};:'"",<.>/?","")
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
+2 QUIT
+3 ;
WEB ;EP - Update Web Services
+1 ; Add a new service and update the associated fields
+2 ; Edit an existing service's associated fields
+3 NEW DA,DIC,DIE,DR,Y,DLAYGO,DIR,X,DIRUT,DUOUT
+4 SET DIR(0)="S^1:TEST PHR SERVER;2:PRODUCTION PHR SERVER"
+5 DO ^DIR
IF Y="^"!(Y="")
QUIT
+6 SET DA=Y
+7 ;
+8 SET DIC="^BPHR(90670.2,"
SET DIC(0)="AELMNZ"
SET DIE=DIC
SET DR="[BPHR ADD/EDIT WEB SERVICE]"
+9 ;S DLAYGO=90670.2 D ^DIC S DA=+Y
+10 DO ^DIE
+11 QUIT
+12 ;
ITR ;EP - Input Transform
+1 IF $LENGTH(X)>40!($LENGTH(X)<1)
KILL X
QUIT
+2 IF $EXTRACT(X,1,8)'="https://"
KILL X
QUIT
+3 QUIT
+4 ;
PROV(PROV) ;EP = Provider DIRECT address
+1 NEW FACAD,MAD,NCOMP,NAME,VALUE,FN,LN
+2 SET ADDR=""
+3 IF $GET(PROV)=""
QUIT ADDR
+4 SET FACAD=$PIECE($GET(^AUTTLOC(DUZ(2),21)),"^",5)
+5 IF FACAD=""
QUIT ADDR
+6 IF FACAD'=""
SET MAD=$PIECE(FACAD,"@",2)
+7 SET NCOMP=$PIECE($GET(^VA(200,PROV,3.1)),"^",1)
+8 IF NCOMP'=""
Begin DoDot:1
+9 SET FN=$PIECE($GET(^VA(20,NCOMP,1)),"^",2)
SET FN=$$STRIP^XLFSTR(FN," ")
SET FN=$$PUNC(FN)
+10 SET LN=$PIECE($GET(^VA(20,NCOMP,1)),"^",1)
SET LN=$$STRIP^XLFSTR(LN," ")
SET LN=$$PUNC(LN)
+11 SET VALUE=$$LOW^XLFSTR(FN)_"."_$$LOW^XLFSTR(LN)
+12 IF $GET(VALUE)=""!($GET(VALUE)=".")
SET NCOMP=""
End DoDot:1
+13 ;
+14 IF NCOMP=""
Begin DoDot:1
+15 SET NAME=$PIECE(^VA(200,PROV,0),"^",1)
+16 DO STDNAME^XLFNAME(.NAME,"FC")
+17 SET FN=$GET(NAME("GIVEN"))
SET FN=$$STRIP^XLFSTR(FN," ")
SET FN=$$PUNC(FN)
+18 SET LN=$GET(NAME("FAMILY"))
SET LN=$$STRIP^XLFSTR(LN," ")
SET LN=$$PUNC(LN)
+19 SET VALUE=$$LOW^XLFSTR(FN)_"."_$$LOW^XLFSTR(LN)
End DoDot:1
+20 ;
+21 SET ADDR=VALUE_"@"_MAD
+22 QUIT ADDR
+23 ;
AGNT(DFN) ;EP = Messaging Agent for Patient
+1 NEW BDPCAT,BDPIEN,MSA,BPA,AGN,ADR,BPDATA,NBP,OK
+2 SET ADDR=""
+3 SET BDPCAT=$$FIND1^DIC(90360.3,,"X","MESSAGE AGENT")
+4 IF BDPCAT=""
QUIT ADDR
+5 SET BDPIEN=$ORDER(^BDPRECN("AA",DFN,BDPCAT,""))
+6 IF BDPIEN=""
QUIT ADDR
+7 SET BPA=0
+8 FOR
SET BPA=$ORDER(^BDPRECN(BDPIEN,1,BPA))
IF 'BPA
QUIT
Begin DoDot:1
+9 SET BPDATA=^BDPRECN(BDPIEN,1,BPA,0)
+10 SET MSA=$PIECE(^BDPRECN(BDPIEN,1,BPA,0),"^",1)
+11 SET AGN(BPA)=MSA_"^"_$PIECE(BPDATA,"^",3)
+12 SET AGN(BPA)=MSA_"^"_$PIECE(BPDATA,"^",3)
SET LBP=BPA
+13 ; Check the next agent in the history
+14 SET NBP=$ORDER(^BDPRECN(BDPIEN,1,BPA))
IF 'NBP
Begin DoDot:2
+15 SET QL=0
DO CMA^BPHRCHK
+16 IF 'QL
SET $PIECE(AGN(BPA),"^",3)=DT
QUIT
+17 IF QL
SET $PIECE(AGN(BPA),"^",3)=CDT
End DoDot:2
QUIT
+18 SET $PIECE(AGN(BPA),"^",3)=$PIECE(^BDPRECN(BDPIEN,1,NBP,0),"^",3)
End DoDot:1
+19 ;
+20 IF CURR'=""
IF $PIECE(^BDPRECN(BDPIEN,1,LBP,0),"^",1)'=CURR
Begin DoDot:1
+21 SET AGN(LBP+1)=CURR_"^"_CDT_"^"_DT
End DoDot:1
+22 ;
+23 SET MS=""
FOR
SET MS=$ORDER(AGN(MS))
IF MS=""
QUIT
Begin DoDot:1
+24 SET OK=0
+25 IF EDT<$PIECE(AGN(MS),"^",2)!(BDT>$PIECE(AGN(MS),"^",3))
QUIT
+26 IF BDT'<$PIECE(AGN(MS),"^",2)
IF BDT'>$PIECE(AGN(MS),"^",3)
SET OK=1
+27 IF EDT'<$PIECE(AGN(MS),"^",2)
IF EDT'>$PIECE(AGN(MS),"^",3)
SET OK=1
+28 ;
+29 IF BDT'>$PIECE(AGN(MS),"^",2)
IF EDT'<$PIECE(AGN(MS),"^",2)
SET OK=1
+30 IF BDT'>$PIECE(AGN(MS),"^",3)
IF EDT'<$PIECE(AGN(MS),"^",3)
SET OK=1
+31 ;
+32 IF OK
Begin DoDot:2
+33 SET MSA=$PIECE(AGN(MS),"^",1)
+34 SET ADR=$$LOW^XLFSTR($PIECE($GET(^BDPMSGA(MSA,0)),"^",2))
+35 IF ADR'["direct"
QUIT
+36 SET ADDR=ADDR_ADR_","
End DoDot:2
End DoDot:1
+37 QUIT ADDR
+38 ;
PUNC(X) ;EP
+1 QUIT $TRANSLATE(X,"`~!@#$%^&*()-_=+\|[{]};:'"",<.>/?","")
