BEHORXF2 ;MSC/IND/PLS - XML Support for Pharmacy Rx Gen service ;14-Nov-2013 15:46;DU
;;1.1;BEH COMPONENTS;**009009,009010,009011,009012**;Sep 18, 2007
;=================================================================
; RPC: BEHORXF2 DRUGTXT
; Returns data from 51.7 associated with drug
;
DRUGTXT(DATA,DRG) ;EP-
S DATA=$NA(^TMP("PSSDIN",$J))
D EN^PSSDIN(,DRG)
Q
GETALG(DFN) ;EP Get allergy data
N ALG,GMRAL,BEHI,BEHY
S ALG=""
D EN1^GMRADPT
I $D(GMRAL)'>9 D
. I $D(GMRAL),GMRAL=0 S ALG="Patient has answered NKA"
. E S ALG="No Allergy Assessment"
S BEHI=0,BEHY=""
F S BEHI=$O(GMRAL(BEHI)) Q:+BEHI'>0 D
. N X,Y,BEHX
. S BEHX=$P($G(GMRAL(BEHI)),U,2)
. S BEHY=$$APPEND(BEHX,BEHY,250)
. I BEHY=BEHX
. S ALG=BEHY
Q ALG
APPEND(X,Y,LEN) ; Append ", "_X to Y, unless Y would excede LEN
Q $S('$L(Y):X,($L(Y_$C(44)_" "_X)'>LEN):Y_$C(44)_" "_X,1:X)
WEIGHT(DFN) ;Get latest weight
N MSR,VMSR,OUT
S (WT,OUT)=""
S VMSR=$$VMSR^BEHOVM
S MSR="WT"
D QRYGMR:'VMSR,QRYMSR:VMSR
S WT=$P(OUT,U,1)
Q WT
HT(DFN) ;Get latest height
N MSR,VMSR,OUT
S (HT,OUT)=""
S VMSR=$$VMSR^BEHOVM
S MSR="HT"
D QRYGMR:'VMSR,QRYMSR:VMSR
S HT=$P(OUT,U,1)
Q HT
BMI(DFN) ; Get latest BMI
N BMI,HT,WT,WTDT,X,HTDT,OUT
S (BMI,OUT)=""
S VMSR=$$VMSR^BEHOVM
S MSR="WT"
D QRYGMR:'VMSR,QRYMSR:VMSR
S WT=$P(OUT,U,2),WTDT=$P(OUT,U,3)
I '+WT G END
S MSR="HT"
D QRYGMR:'VMSR,QRYMSR:VMSR
S HT=$P(OUT,U,2),HTDT=$P(OUT,U,3)
I '+HT G END
S BMI=""
S WT=WT*.45359,HT=HT*.0254,HT=HT*HT,BMI=+$J(WT/HT,0,2)
S OUT="BMI: "_BMI_" on "_$$FMTDATE^BGOUTL(WTDT)
END Q OUT
QRYMSR ; Get data from V file
N VDT,IEN,FOUND,DATE,VALUE,MSR2
S OUT="",VDT=0
S FOUND=0,MSR2=0
S MSR2=$O(^AUTTMSR("B",MSR,MSR2))
Q:'+MSR2
F S VDT=$O(^AUPNVMSR("AA",DFN,MSR2,VDT)) Q:('VDT)!(+FOUND) D
.S IEN=0
.F S IEN=$O(^AUPNVMSR("AA",DFN,MSR2,VDT,IEN)) Q:'IEN!(+FOUND) D
..K BEH D ENP^XBDIQ1(9000010.01,IEN,".03;.04;2;1201","BEH(","I")
..Q:BEH(2,"I")=1
..S FOUND=1
..S DATE=$S($G(BEH(1201,"I"))]"":+BEH(1201,"I"),1:(9999999-VDT))
..I MSR="HT" S Y=$G(BEH(.04)),Y=$J(Y,5,2)_" in ["_$J((Y*2.54),5,2)_" cm]",VALUE=Y
..I MSR="WT" S Y=$G(BEH(.04)),Y=$J(Y,5,2)_" lb ["_$J((Y*.454),5,2)_" kg]",VALUE=Y
..S OUT=MSR_": "_VALUE_" on "_$$FMTDATE^BGOUTL(DATE)_U_$G(BEH(.04))_U_DATE
Q
QRYGMR ;Get data from GMR file
N VDT,IEN,FOUND,DATE,VALUE,MSR2
S OUT="",VDT=0
S FOUND=0,MSR2=0
S MSR2=$O(^GMRD(120.51,"C",MSR,MSR2))
Q:'+MSR2
F S IEN=$O(^GMR(120.5,"AA",DFN,MSR2,VDT)) Q:('VDT)!(+FOUND) D
.S IEN=0
.F S IEN=$O(^GMR(120.5,"AA",DFN,MSR2,VDT,IEN)) Q:'IEN!(+FOUND) D
..K BEH D ENP^XBDIQ1(120.5,IEN,".01;1.2;2","BEH(","I")
..Q:BEH(2,"I")=1
..S FOUND=1
..S DATE=$G(BEH(.01,"I"))
..I MSR="HT" S Y=$G(BEH(1.2)),Y=$J(Y,5,2)_" in ["_$J((Y*2.54),5,2)_" cm]",VALUE=Y
..I MSR="WT" S Y=$G(BEH(1.2)),Y=$J(Y,5,2)_" lb ["_$J((Y*.454),5,2)_" kg]",VALUE=Y
..S OUT=MSR_": "_VALUE_" on "_$$FMTDATE^BGOUTL(DATE)_U_$G(BEH(1.2))_U_DATE
Q
;Get RxNorm for order
RXNORM(POF) ;
N RXNORM,DIEN,NDC
S RXNORM=""
S DIEN=$$GET1^DIQ(52.41,POF,11,"I")
I +DIEN D
.S RXNORM=$$RXNORDRG^APSPFNC1(+DIEN)
.;S NDC=$TR($P($G(^PSDRUG(DIEN,2)),U,4),"-","")
.;Q:'$L(NDC)
.;S RXNORM=+$O(^C0CRXN(176.002,"NDC",NDC,0))
.;S RXNORM=$$GET1^DIQ(176.002,RXNORM,.01)
Q RXNORM
;Get patient data
BLDPT(DFN,RX) ;
N SSN
S RX=$G(RX)
I RX'="" D ADD($$TAG^BEHORXF1("PatientHRN",2,$$HRN^AUPNPAT3(DFN,$$GET1^DIQ(59,$$GET1^DIQ(52,RX,20,"I"),100,"I"))))
I RX="" D ADD($$TAG^BEHORXF1("PatientHRN",2,$$HRN^AUPNPAT3(DFN,DUZ(2))))
D ADD($$TAG^BEHORXF1("PatientDOB",2,$$FMTE^XLFDT($$GET1^DIQ(2,DFN,.03,"I"),9)))
D ADD($$TAG^BEHORXF1("PatientGender",2,$$GET1^DIQ(2,DFN,.02)))
D ADD($$TAG^BEHORXF1("PatientPhone",2,$$GET1^DIQ(2,DFN,.131)))
S SSN=$$GET1^DIQ(2,DFN,.09)
D ADD($$TAG^BEHORXF1("PatientLastFour",2,$$FMTSSN^APSPFUNC(SSN)))
Q
; Build nodes for patient address
BLDPTADD(DFN) ;
D ADD($$TAG^BEHORXF1("PatientAddress1",2,$$GET1^DIQ(2,DFN,.111)))
D ADD($$TAG^BEHORXF1("PatientAddress2",2,$$GET1^DIQ(2,DFN,.112)))
D ADD($$TAG^BEHORXF1("PatientAddress3",2,$$GET1^DIQ(2,DFN,.113)))
D ADD($$TAG^BEHORXF1("PatientCity",2,$$GET1^DIQ(2,DFN,.114)))
D ADD($$TAG^BEHORXF1("PatientState",2,$$GET1^DIQ(2,DFN,.115)))
D ADD($$TAG^BEHORXF1("PatientZipCode",2,$$GET1^DIQ(2,DFN,.116)))
Q
PROV(PRVIEN,ORD) ;
N X
D ADD($$TAG^BEHORXF1("ProviderDEA",2,$$DEAVAUS^APSPFUNC(PRVIEN)))
;D ADD($$TAG^BEHORXF1("ProvIEN",2,PRVIEN))
D ADD($$TAG^BEHORXF1("ProviderPhone",2,$$PRVINFO(PRVIEN,.132)))
D ADD($$TAG^BEHORXF1("ProviderFax",2,$$PRVINFO(PRVIEN,.136)))
;D ADD($$TAG^BEHORXF1("ProviderESig",2,$S($L($$PRVINFO(PRVIEN,20.4)):"Electronic Signature on File",1:"")))
S X=$$PRVINFO(PRVIEN,20.2)
D ADD($$TAG^BEHORXF1("ProviderESig",2,$S($L(X):"/ES/ "_X,1:"")))
D ADD($$TAG^BEHORXF1("ProviderESigTitle",2,$$PRVINFO(PRVIEN,20.3)))
D ADD($$TAG^BEHORXF1("ProviderNPI",2,$$PRVINFO(PRVIEN,41.99)))
D ADD($$TAG^BEHORXF1("ProviderSup",2,$$GET1^DIQ(49,$$GET1^DIQ(200,PRVIEN,29,"I"),2)))
Q
;Get patient data
DATA(DFN) ;
D ADD($$TAG^BEHORXF1("Allergies",2,$$GETALG^BEHORXF2(DFN)))
D ADD($$TAG^BEHORXF1("Weight",2,$$WEIGHT^BEHORXF2(DFN)))
D ADD($$TAG^BEHORXF1("Height",2,$$HT^BEHORXF2(DFN)))
D ADD($$TAG^BEHORXF1("BMI",2,$$BMI^BEHORXF2(DFN)))
Q
; Add data to array
ADD(VAL) ;EP-
S CNT=CNT+1
S @DATA@(CNT)=VAL
Q
; Returns Provider information
PRVINFO(USR,FLD,FLG) ;EP-
S FLG=$G(FLG,"E")
Q $$GET1^DIQ(200,USR,FLD,FLG)
BEHORXF2 ;MSC/IND/PLS - XML Support for Pharmacy Rx Gen service ;14-Nov-2013 15:46;DU
+1 ;;1.1;BEH COMPONENTS;**009009,009010,009011,009012**;Sep 18, 2007
+2 ;=================================================================
+3 ; RPC: BEHORXF2 DRUGTXT
+4 ; Returns data from 51.7 associated with drug
+5 ;
DRUGTXT(DATA,DRG) ;EP-
+1 SET DATA=$NAME(^TMP("PSSDIN",$JOB))
+2 DO EN^PSSDIN(,DRG)
+3 QUIT
GETALG(DFN) ;EP Get allergy data
+1 NEW ALG,GMRAL,BEHI,BEHY
+2 SET ALG=""
+3 DO EN1^GMRADPT
+4 IF $DATA(GMRAL)'>9
Begin DoDot:1
+5 IF $DATA(GMRAL)
IF GMRAL=0
SET ALG="Patient has answered NKA"
+6 IF '$TEST
SET ALG="No Allergy Assessment"
End DoDot:1
+7 SET BEHI=0
SET BEHY=""
+8 FOR
SET BEHI=$ORDER(GMRAL(BEHI))
IF +BEHI'>0
QUIT
Begin DoDot:1
+9 NEW X,Y,BEHX
+10 SET BEHX=$PIECE($GET(GMRAL(BEHI)),U,2)
+11 SET BEHY=$$APPEND(BEHX,BEHY,250)
+12 IF BEHY=BEHX
+13 SET ALG=BEHY
End DoDot:1
+14 QUIT ALG
APPEND(X,Y,LEN) ; Append ", "_X to Y, unless Y would excede LEN
+1 QUIT $SELECT('$LENGTH(Y):X,($LENGTH(Y_$CHAR(44)_" "_X)'>LEN):Y_$CHAR(44)_" "_X,1:X)
WEIGHT(DFN) ;Get latest weight
+1 NEW MSR,VMSR,OUT
+2 SET (WT,OUT)=""
+3 SET VMSR=$$VMSR^BEHOVM
+4 SET MSR="WT"
+5 IF 'VMSR
DO QRYGMR
IF VMSR
DO QRYMSR
+6 SET WT=$PIECE(OUT,U,1)
+7 QUIT WT
HT(DFN) ;Get latest height
+1 NEW MSR,VMSR,OUT
+2 SET (HT,OUT)=""
+3 SET VMSR=$$VMSR^BEHOVM
+4 SET MSR="HT"
+5 IF 'VMSR
DO QRYGMR
IF VMSR
DO QRYMSR
+6 SET HT=$PIECE(OUT,U,1)
+7 QUIT HT
BMI(DFN) ; Get latest BMI
+1 NEW BMI,HT,WT,WTDT,X,HTDT,OUT
+2 SET (BMI,OUT)=""
+3 SET VMSR=$$VMSR^BEHOVM
+4 SET MSR="WT"
+5 IF 'VMSR
DO QRYGMR
IF VMSR
DO QRYMSR
+6 SET WT=$PIECE(OUT,U,2)
SET WTDT=$PIECE(OUT,U,3)
+7 IF '+WT
GOTO END
+8 SET MSR="HT"
+9 IF 'VMSR
DO QRYGMR
IF VMSR
DO QRYMSR
+10 SET HT=$PIECE(OUT,U,2)
SET HTDT=$PIECE(OUT,U,3)
+11 IF '+HT
GOTO END
+12 SET BMI=""
+13 SET WT=WT*.45359
SET HT=HT*.0254
SET HT=HT*HT
SET BMI=+$JUSTIFY(WT/HT,0,2)
+14 SET OUT="BMI: "_BMI_" on "_$$FMTDATE^BGOUTL(WTDT)
END QUIT OUT
QRYMSR ; Get data from V file
+1 NEW VDT,IEN,FOUND,DATE,VALUE,MSR2
+2 SET OUT=""
SET VDT=0
+3 SET FOUND=0
SET MSR2=0
+4 SET MSR2=$ORDER(^AUTTMSR("B",MSR,MSR2))
+5 IF '+MSR2
QUIT
+6 FOR
SET VDT=$ORDER(^AUPNVMSR("AA",DFN,MSR2,VDT))
IF ('VDT)!(+FOUND)
QUIT
Begin DoDot:1
+7 SET IEN=0
+8 FOR
SET IEN=$ORDER(^AUPNVMSR("AA",DFN,MSR2,VDT,IEN))
IF 'IEN!(+FOUND)
QUIT
Begin DoDot:2
+9 KILL BEH
DO ENP^XBDIQ1(9000010.01,IEN,".03;.04;2;1201","BEH(","I")
+10 IF BEH(2,"I")=1
QUIT
+11 SET FOUND=1
+12 SET DATE=$SELECT($GET(BEH(1201,"I"))]"":+BEH(1201,"I"),1:(9999999-VDT))
+13 IF MSR="HT"
SET Y=$GET(BEH(.04))
SET Y=$JUSTIFY(Y,5,2)_" in ["_$JUSTIFY((Y*2.54),5,2)_" cm]"
SET VALUE=Y
+14 IF MSR="WT"
SET Y=$GET(BEH(.04))
SET Y=$JUSTIFY(Y,5,2)_" lb ["_$JUSTIFY((Y*.454),5,2)_" kg]"
SET VALUE=Y
+15 SET OUT=MSR_": "_VALUE_" on "_$$FMTDATE^BGOUTL(DATE)_U_$GET(BEH(.04))_U_DATE
End DoDot:2
End DoDot:1
+16 QUIT
QRYGMR ;Get data from GMR file
+1 NEW VDT,IEN,FOUND,DATE,VALUE,MSR2
+2 SET OUT=""
SET VDT=0
+3 SET FOUND=0
SET MSR2=0
+4 SET MSR2=$ORDER(^GMRD(120.51,"C",MSR,MSR2))
+5 IF '+MSR2
QUIT
+6 FOR
SET IEN=$ORDER(^GMR(120.5,"AA",DFN,MSR2,VDT))
IF ('VDT)!(+FOUND)
QUIT
Begin DoDot:1
+7 SET IEN=0
+8 FOR
SET IEN=$ORDER(^GMR(120.5,"AA",DFN,MSR2,VDT,IEN))
IF 'IEN!(+FOUND)
QUIT
Begin DoDot:2
+9 KILL BEH
DO ENP^XBDIQ1(120.5,IEN,".01;1.2;2","BEH(","I")
+10 IF BEH(2,"I")=1
QUIT
+11 SET FOUND=1
+12 SET DATE=$GET(BEH(.01,"I"))
+13 IF MSR="HT"
SET Y=$GET(BEH(1.2))
SET Y=$JUSTIFY(Y,5,2)_" in ["_$JUSTIFY((Y*2.54),5,2)_" cm]"
SET VALUE=Y
+14 IF MSR="WT"
SET Y=$GET(BEH(1.2))
SET Y=$JUSTIFY(Y,5,2)_" lb ["_$JUSTIFY((Y*.454),5,2)_" kg]"
SET VALUE=Y
+15 SET OUT=MSR_": "_VALUE_" on "_$$FMTDATE^BGOUTL(DATE)_U_$GET(BEH(1.2))_U_DATE
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;Get RxNorm for order
RXNORM(POF) ;
+1 NEW RXNORM,DIEN,NDC
+2 SET RXNORM=""
+3 SET DIEN=$$GET1^DIQ(52.41,POF,11,"I")
+4 IF +DIEN
Begin DoDot:1
+5 SET RXNORM=$$RXNORDRG^APSPFNC1(+DIEN)
+6 ;S NDC=$TR($P($G(^PSDRUG(DIEN,2)),U,4),"-","")
+7 ;Q:'$L(NDC)
+8 ;S RXNORM=+$O(^C0CRXN(176.002,"NDC",NDC,0))
+9 ;S RXNORM=$$GET1^DIQ(176.002,RXNORM,.01)
End DoDot:1
+10 QUIT RXNORM
+11 ;Get patient data
BLDPT(DFN,RX) ;
+1 NEW SSN
+2 SET RX=$GET(RX)
+3 IF RX'=""
DO ADD($$TAG^BEHORXF1("PatientHRN",2,$$HRN^AUPNPAT3(DFN,$$GET1^DIQ(59,$$GET1^DIQ(52,RX,20,"I"),100,"I"))))
+4 IF RX=""
DO ADD($$TAG^BEHORXF1("PatientHRN",2,$$HRN^AUPNPAT3(DFN,DUZ(2))))
+5 DO ADD($$TAG^BEHORXF1("PatientDOB",2,$$FMTE^XLFDT($$GET1^DIQ(2,DFN,.03,"I"),9)))
+6 DO ADD($$TAG^BEHORXF1("PatientGender",2,$$GET1^DIQ(2,DFN,.02)))
+7 DO ADD($$TAG^BEHORXF1("PatientPhone",2,$$GET1^DIQ(2,DFN,.131)))
+8 SET SSN=$$GET1^DIQ(2,DFN,.09)
+9 DO ADD($$TAG^BEHORXF1("PatientLastFour",2,$$FMTSSN^APSPFUNC(SSN)))
+10 QUIT
+11 ; Build nodes for patient address
BLDPTADD(DFN) ;
+1 DO ADD($$TAG^BEHORXF1("PatientAddress1",2,$$GET1^DIQ(2,DFN,.111)))
+2 DO ADD($$TAG^BEHORXF1("PatientAddress2",2,$$GET1^DIQ(2,DFN,.112)))
+3 DO ADD($$TAG^BEHORXF1("PatientAddress3",2,$$GET1^DIQ(2,DFN,.113)))
+4 DO ADD($$TAG^BEHORXF1("PatientCity",2,$$GET1^DIQ(2,DFN,.114)))
+5 DO ADD($$TAG^BEHORXF1("PatientState",2,$$GET1^DIQ(2,DFN,.115)))
+6 DO ADD($$TAG^BEHORXF1("PatientZipCode",2,$$GET1^DIQ(2,DFN,.116)))
+7 QUIT
PROV(PRVIEN,ORD) ;
+1 NEW X
+2 DO ADD($$TAG^BEHORXF1("ProviderDEA",2,$$DEAVAUS^APSPFUNC(PRVIEN)))
+3 ;D ADD($$TAG^BEHORXF1("ProvIEN",2,PRVIEN))
+4 DO ADD($$TAG^BEHORXF1("ProviderPhone",2,$$PRVINFO(PRVIEN,.132)))
+5 DO ADD($$TAG^BEHORXF1("ProviderFax",2,$$PRVINFO(PRVIEN,.136)))
+6 ;D ADD($$TAG^BEHORXF1("ProviderESig",2,$S($L($$PRVINFO(PRVIEN,20.4)):"Electronic Signature on File",1:"")))
+7 SET X=$$PRVINFO(PRVIEN,20.2)
+8 DO ADD($$TAG^BEHORXF1("ProviderESig",2,$SELECT($LENGTH(X):"/ES/ "_X,1:"")))
+9 DO ADD($$TAG^BEHORXF1("ProviderESigTitle",2,$$PRVINFO(PRVIEN,20.3)))
+10 DO ADD($$TAG^BEHORXF1("ProviderNPI",2,$$PRVINFO(PRVIEN,41.99)))
+11 DO ADD($$TAG^BEHORXF1("ProviderSup",2,$$GET1^DIQ(49,$$GET1^DIQ(200,PRVIEN,29,"I"),2)))
+12 QUIT
+13 ;Get patient data
DATA(DFN) ;
+1 DO ADD($$TAG^BEHORXF1("Allergies",2,$$GETALG^BEHORXF2(DFN)))
+2 DO ADD($$TAG^BEHORXF1("Weight",2,$$WEIGHT^BEHORXF2(DFN)))
+3 DO ADD($$TAG^BEHORXF1("Height",2,$$HT^BEHORXF2(DFN)))
+4 DO ADD($$TAG^BEHORXF1("BMI",2,$$BMI^BEHORXF2(DFN)))
+5 QUIT
+6 ; Add data to array
ADD(VAL) ;EP-
+1 SET CNT=CNT+1
+2 SET @DATA@(CNT)=VAL
+3 QUIT
+4 ; Returns Provider information
PRVINFO(USR,FLD,FLG) ;EP-
+1 SET FLG=$GET(FLG,"E")
+2 QUIT $$GET1^DIQ(200,USR,FLD,FLG)
