VPRDSDAM ;SLC/MKB -- Appointment extract ;8/2/11 15:29
;;1.0;VIRTUAL PATIENT RECORD;**1,5,33**;Sep 01, 2011;Build 8
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^DGS(41.1 3796
; ^DIC(42 10039
; ^SC 10040
; ^VA(200 10060
; DIQ 2056
; SDAMA301 4433
; SDOE 2546
;
; ------------ Get appointment(s) from VistA ------------
;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's [future] appointments
N VPRX,VPRNUM,VPRDT,VPRCNT,VPRITM,VPRA,X,VPRSTS
S DFN=+$G(DFN) Q:DFN<1
I $G(BEG)<2000000 S BEG=DT
S END=$G(END,4141015),MAX=$G(MAX,9999)
S VPRX(1)=BEG_";"_END,VPRX(4)=DFN,VPRX("FLDS")="1;2;3;9;10;11;12;13;25;32",VPRX("SORT")="P"
;
A ; get one appt
I $L($G(ID)) D Q
. I ID'?1U1";"1.N.E Q ;expects A;date;loc or H;date[;loc]
. S (BEG,END)=$P(ID,";",2) I $P(ID,";")="H" D Q
.. S X=$$DGIEN(BEG) Q:'X
.. D DGS(X,.VPRITM),XML(.VPRITM)
. S VPRX(1)=BEG_";"_END,VPRX(2)=$P(ID,";",3)
. S VPRNUM=$$SDAPI^SDAMA301(.VPRX) Q:VPRNUM<1
. D EN1(BEG,.VPRITM),XML(.VPRITM)
. K ^TMP($J,"SDAMA301",DFN)
;
B ; get all [future] appointments
S VPRX(3)="R;I;NS;NSR;NT",VPRSTS=0 ;default = no cancelled appt's
I $L($G(FILTER("status"))) S VPRX(3)=FILTER("status"),VPRSTS=1
S VPRNUM=$$SDAPI^SDAMA301(.VPRX),(VPRDT,VPRCNT)=0
F S VPRDT=$O(^TMP($J,"SDAMA301",DFN,VPRDT)) Q:VPRDT<1 D Q:VPRCNT'<MAX
. S X=$P($G(^TMP($J,"SDAMA301",DFN,VPRDT)),U,3)
. I VPRDT<DT,'VPRSTS,$P(X,";")'["NS" Q ;no past kept appt's if default
. K VPRITM D EN1(VPRDT,.VPRITM) Q:'$D(VPRITM)
. D XML(.VPRITM) S VPRCNT=VPRCNT+1
K ^TMP($J,"SDAMA301",DFN)
;
C ; get scheduled admissions
S VPRA=0 F S VPRA=$O(^DGS(41.1,"B",DFN,VPRA)) Q:VPRA<1 D Q:VPRCNT'<MAX
. S VPRX=$G(^DGS(41.1,VPRA,0))
. I $P(VPRX,U,13),$G(FILTER("status"))'["C" Q ;cancelled
. I $P(VPRX,U,17),$G(FILTER("status"))'["R" Q ;admitted
. S X=$P(VPRX,U,2) Q:X<BEG!(X>END) ;out of date range
. K VPRITM D DGS(VPRA,.VPRITM) Q:'$D(VPRITM)
. D XML(.VPRITM) S VPRCNT=VPRCNT+1
Q
;
EN1(DATE,APPT) ; -- return an appointment in APPT("attribute")=value
; Expects ^TMP($J,"SDAMA301",DFN,DATE)
N X,HLOC,STS,CLS,SV,PRV,SDOE K APPT
S DATE=+$G(DATE),X=$G(^TMP($J,"SDAMA301",DFN,DATE)) Q:X=""
S HLOC=$P(X,U,2),APPT("type")=$TR($P(X,U,10),";","^")
S STS=$P(X,U,3),CLS=$S($E(STS)="I":"I",1:"O")
S:$P(X,U,9) APPT("checkIn")=$P(X,U,9)
S:$P(X,U,11) APPT("checkOut")=$P(X,U,11)
S:$P(X,U,25) APPT("cancelled")=$P(X,U,25)
S SDOE=$P(X,U,12) I SDOE S APPT("visit")=$P($$GETOE^SDOE(SDOE),U,5)
S APPT("id")="A;"_DATE_";"_+HLOC,APPT("dateTime")=DATE I HLOC D
. S APPT("location")=$P(HLOC,";",2)
. S APPT("clinicStop")=$$AMIS^VPRDVSIT(+$P(X,U,13))
. S SV=$$GET1^DIQ(44,+HLOC_",",9.5,"I")
. I SV S APPT("service")=$$SERV(SV)
. I 'SV S APPT("service")=$$GET1^DIQ(44,+HLOC_",",9)
. ;find default provider
. S PRV=+$$GET1^DIQ(44,+HLOC_",",16,"I") I 'PRV D
.. N VPRP,I,FIRST
.. D GETS^DIQ(44,+HLOC_",","2600*","I","VPRP")
.. S FIRST=$O(VPRP(44.1,"")),I=""
.. F S I=$O(VPRP(44.1,I)) Q:I="" I $G(VPRP(44.1,I,.02,"I")) S PRV=$G(VPRP(44.1,I,.01,"I")) Q
.. I 'PRV,FIRST S PRV=$G(VPRP(44.1,FIRST,.01,"I"))
. I PRV S APPT("provider")=PRV_U_$P($G(^VA(200,PRV,0)),U) Q
S APPT("facility")=$$FAC^VPRD(+HLOC)
S APPT("patientClass")=$S(CLS="I":"IMP",1:"AMB")
S APPT("serviceCategory")=$S(CLS="I":"I^INPATIENT VISIT",1:"A^AMBULATORY")
S APPT("apptStatus")=$P(STS,";",2)
S APPT("visitString")=+HLOC_";"_DATE_";A"
N X0 S X0=$G(^TMP($J,"SDAMA301",DFN,DATE,0))
S:$P(X0,U,5) APPT("cancelReason")=$P($P(X0,U,5),";",2)
Q
;
SERV(FTS) ; -- Return #42.4 Service for a Facility Treating Specialty
N Y S Y="",FTS=+$G(FTS)
S Y=$$GET1^DIQ(45.7,FTS_",","1:3","E")
Q Y
;
DGS(IFN,ADM) ; -- return a scheduled admission in ADM("attribute")=value
N X0,DATE,HLOC,SV,X K ADM
S X0=$G(^DGS(41.1,+$G(IFN),0)) Q:X0="" ;deleted
S DATE=+$P(X0,U,2),HLOC=+$G(^DIC(42,+$P(X0,U,8),44))
S ADM("id")="H;"_DATE,ADM("dateTime")=DATE I HLOC D
. S ADM("id")=ADM("id")_";"_HLOC,ADM("visitString")=HLOC_";"_DATE_";H"
. S ADM("location")=HLOC_U_$P($G(^SC(HLOC,0)),U)
. S X=$$GET1^DIQ(44,HLOC_",",8,"I"),ADM("clinicStop")=$$AMIS^VPRDVSIT(X)
. S SV=$$GET1^DIQ(44,HLOC_",",9.5,"I")
. I SV S ADM("service")=$$SERV(SV)
. I 'SV S ADM("service")=$$GET1^DIQ(44,+HLOC_",",9)
S ADM("facility")=$$FAC^VPRD(HLOC)
S X=$P(X0,U,5) I X S ADM("provider")=X_U_$P($G(^VA(200,X,0)),U)
S ADM("patientClass")="IMP",ADM("serviceCategory")="H^HOSPITALIZATION"
S ADM("apptStatus")=$S($P(X0,U,17):"ADMITTED",$P(X0,U,13):"CANCELLED",1:"SCHEDULED")
Q
;
DGIEN(DATE) ; -- find #41.1 ien for DFN and DATE
N I,X,Y S Y=0
S I=0 F S I=$O(^DGS(41.1,"B",DFN,I)) Q:I<1 I $P($G(^DGS(41.1,I,0)),U,2)=DATE S Y=I Q
Q Y
;
; ------------ Return data to middle tier ------------
;
XML(APPT) ; -- Return appointment as XML
N ATT,X,Y,NAMES
D ADD("<appointment>") S VPRTOTL=$G(VPRTOTL)+1
S ATT="" F S ATT=$O(APPT(ATT)) Q:ATT="" D D:$L(Y) ADD(Y)
. S X=$G(APPT(ATT)),Y="" Q:'$L(X)
. I X'["^" S Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />" Q
. I $L(X)>1 S NAMES="code^name^Z",Y="<"_ATT_" "_$$LOOP_"/>"
D ADD("</appointment>")
Q
;
LOOP() ; -- build sub-items string from NAMES and X
N STR,P,TAG S STR=""
F P=1:1 S TAG=$P(NAMES,U,P) Q:TAG="Z" I $L($P(X,U,P)) S STR=STR_TAG_"='"_$$ESC^VPRD($P(X,U,P))_"' "
Q STR
;
ADD(X) ; -- Add a line @VPR@(n)=X
S VPRI=$G(VPRI)+1
S @VPR@(VPRI)=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDSDAM 5681 printed Dec 13, 2024@02:45:06 Page 2
VPRDSDAM ;SLC/MKB -- Appointment extract ;8/2/11 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**1,5,33**;Sep 01, 2011;Build 8
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^DGS(41.1 3796
+7 ; ^DIC(42 10039
+8 ; ^SC 10040
+9 ; ^VA(200 10060
+10 ; DIQ 2056
+11 ; SDAMA301 4433
+12 ; SDOE 2546
+13 ;
+14 ; ------------ Get appointment(s) from VistA ------------
+15 ;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's [future] appointments
+1 NEW VPRX,VPRNUM,VPRDT,VPRCNT,VPRITM,VPRA,X,VPRSTS
+2 SET DFN=+$GET(DFN)
if DFN<1
QUIT
+3 IF $GET(BEG)<2000000
SET BEG=DT
+4 SET END=$GET(END,4141015)
SET MAX=$GET(MAX,9999)
+5 SET VPRX(1)=BEG_";"_END
SET VPRX(4)=DFN
SET VPRX("FLDS")="1;2;3;9;10;11;12;13;25;32"
SET VPRX("SORT")="P"
+6 ;
A ; get one appt
+1 IF $LENGTH($GET(ID))
Begin DoDot:1
+2 ;expects A;date;loc or H;date[;loc]
IF ID'?1U1";"1.N.E
QUIT
+3 SET (BEG,END)=$PIECE(ID,";",2)
IF $PIECE(ID,";")="H"
Begin DoDot:2
+4 SET X=$$DGIEN(BEG)
if 'X
QUIT
+5 DO DGS(X,.VPRITM)
DO XML(.VPRITM)
End DoDot:2
QUIT
+6 SET VPRX(1)=BEG_";"_END
SET VPRX(2)=$PIECE(ID,";",3)
+7 SET VPRNUM=$$SDAPI^SDAMA301(.VPRX)
if VPRNUM<1
QUIT
+8 DO EN1(BEG,.VPRITM)
DO XML(.VPRITM)
+9 KILL ^TMP($JOB,"SDAMA301",DFN)
End DoDot:1
QUIT
+10 ;
B ; get all [future] appointments
+1 ;default = no cancelled appt's
SET VPRX(3)="R;I;NS;NSR;NT"
SET VPRSTS=0
+2 IF $LENGTH($GET(FILTER("status")))
SET VPRX(3)=FILTER("status")
SET VPRSTS=1
+3 SET VPRNUM=$$SDAPI^SDAMA301(.VPRX)
SET (VPRDT,VPRCNT)=0
+4 FOR
SET VPRDT=$ORDER(^TMP($JOB,"SDAMA301",DFN,VPRDT))
if VPRDT<1
QUIT
Begin DoDot:1
+5 SET X=$PIECE($GET(^TMP($JOB,"SDAMA301",DFN,VPRDT)),U,3)
+6 ;no past kept appt's if default
IF VPRDT<DT
IF 'VPRSTS
IF $PIECE(X,";")'["NS"
QUIT
+7 KILL VPRITM
DO EN1(VPRDT,.VPRITM)
if '$DATA(VPRITM)
QUIT
+8 DO XML(.VPRITM)
SET VPRCNT=VPRCNT+1
End DoDot:1
if VPRCNT'<MAX
QUIT
+9 KILL ^TMP($JOB,"SDAMA301",DFN)
+10 ;
C ; get scheduled admissions
+1 SET VPRA=0
FOR
SET VPRA=$ORDER(^DGS(41.1,"B",DFN,VPRA))
if VPRA<1
QUIT
Begin DoDot:1
+2 SET VPRX=$GET(^DGS(41.1,VPRA,0))
+3 ;cancelled
IF $PIECE(VPRX,U,13)
IF $GET(FILTER("status"))'["C"
QUIT
+4 ;admitted
IF $PIECE(VPRX,U,17)
IF $GET(FILTER("status"))'["R"
QUIT
+5 ;out of date range
SET X=$PIECE(VPRX,U,2)
if X<BEG!(X>END)
QUIT
+6 KILL VPRITM
DO DGS(VPRA,.VPRITM)
if '$DATA(VPRITM)
QUIT
+7 DO XML(.VPRITM)
SET VPRCNT=VPRCNT+1
End DoDot:1
if VPRCNT'<MAX
QUIT
+8 QUIT
+9 ;
EN1(DATE,APPT) ; -- return an appointment in APPT("attribute")=value
+1 ; Expects ^TMP($J,"SDAMA301",DFN,DATE)
+2 NEW X,HLOC,STS,CLS,SV,PRV,SDOE
KILL APPT
+3 SET DATE=+$GET(DATE)
SET X=$GET(^TMP($JOB,"SDAMA301",DFN,DATE))
if X=""
QUIT
+4 SET HLOC=$PIECE(X,U,2)
SET APPT("type")=$TRANSLATE($PIECE(X,U,10),";","^")
+5 SET STS=$PIECE(X,U,3)
SET CLS=$SELECT($EXTRACT(STS)="I":"I",1:"O")
+6 if $PIECE(X,U,9)
SET APPT("checkIn")=$PIECE(X,U,9)
+7 if $PIECE(X,U,11)
SET APPT("checkOut")=$PIECE(X,U,11)
+8 if $PIECE(X,U,25)
SET APPT("cancelled")=$PIECE(X,U,25)
+9 SET SDOE=$PIECE(X,U,12)
IF SDOE
SET APPT("visit")=$PIECE($$GETOE^SDOE(SDOE),U,5)
+10 SET APPT("id")="A;"_DATE_";"_+HLOC
SET APPT("dateTime")=DATE
IF HLOC
Begin DoDot:1
+11 SET APPT("location")=$PIECE(HLOC,";",2)
+12 SET APPT("clinicStop")=$$AMIS^VPRDVSIT(+$PIECE(X,U,13))
+13 SET SV=$$GET1^DIQ(44,+HLOC_",",9.5,"I")
+14 IF SV
SET APPT("service")=$$SERV(SV)
+15 IF 'SV
SET APPT("service")=$$GET1^DIQ(44,+HLOC_",",9)
+16 ;find default provider
+17 SET PRV=+$$GET1^DIQ(44,+HLOC_",",16,"I")
IF 'PRV
Begin DoDot:2
+18 NEW VPRP,I,FIRST
+19 DO GETS^DIQ(44,+HLOC_",","2600*","I","VPRP")
+20 SET FIRST=$ORDER(VPRP(44.1,""))
SET I=""
+21 FOR
SET I=$ORDER(VPRP(44.1,I))
if I=""
QUIT
IF $GET(VPRP(44.1,I,.02,"I"))
SET PRV=$GET(VPRP(44.1,I,.01,"I"))
QUIT
+22 IF 'PRV
IF FIRST
SET PRV=$GET(VPRP(44.1,FIRST,.01,"I"))
End DoDot:2
+23 IF PRV
SET APPT("provider")=PRV_U_$PIECE($GET(^VA(200,PRV,0)),U)
QUIT
End DoDot:1
+24 SET APPT("facility")=$$FAC^VPRD(+HLOC)
+25 SET APPT("patientClass")=$SELECT(CLS="I":"IMP",1:"AMB")
+26 SET APPT("serviceCategory")=$SELECT(CLS="I":"I^INPATIENT VISIT",1:"A^AMBULATORY")
+27 SET APPT("apptStatus")=$PIECE(STS,";",2)
+28 SET APPT("visitString")=+HLOC_";"_DATE_";A"
+29 NEW X0
SET X0=$GET(^TMP($JOB,"SDAMA301",DFN,DATE,0))
+30 if $PIECE(X0,U,5)
SET APPT("cancelReason")=$PIECE($PIECE(X0,U,5),";",2)
+31 QUIT
+32 ;
SERV(FTS) ; -- Return #42.4 Service for a Facility Treating Specialty
+1 NEW Y
SET Y=""
SET FTS=+$GET(FTS)
+2 SET Y=$$GET1^DIQ(45.7,FTS_",","1:3","E")
+3 QUIT Y
+4 ;
DGS(IFN,ADM) ; -- return a scheduled admission in ADM("attribute")=value
+1 NEW X0,DATE,HLOC,SV,X
KILL ADM
+2 ;deleted
SET X0=$GET(^DGS(41.1,+$GET(IFN),0))
if X0=""
QUIT
+3 SET DATE=+$PIECE(X0,U,2)
SET HLOC=+$GET(^DIC(42,+$PIECE(X0,U,8),44))
+4 SET ADM("id")="H;"_DATE
SET ADM("dateTime")=DATE
IF HLOC
Begin DoDot:1
+5 SET ADM("id")=ADM("id")_";"_HLOC
SET ADM("visitString")=HLOC_";"_DATE_";H"
+6 SET ADM("location")=HLOC_U_$PIECE($GET(^SC(HLOC,0)),U)
+7 SET X=$$GET1^DIQ(44,HLOC_",",8,"I")
SET ADM("clinicStop")=$$AMIS^VPRDVSIT(X)
+8 SET SV=$$GET1^DIQ(44,HLOC_",",9.5,"I")
+9 IF SV
SET ADM("service")=$$SERV(SV)
+10 IF 'SV
SET ADM("service")=$$GET1^DIQ(44,+HLOC_",",9)
End DoDot:1
+11 SET ADM("facility")=$$FAC^VPRD(HLOC)
+12 SET X=$PIECE(X0,U,5)
IF X
SET ADM("provider")=X_U_$PIECE($GET(^VA(200,X,0)),U)
+13 SET ADM("patientClass")="IMP"
SET ADM("serviceCategory")="H^HOSPITALIZATION"
+14 SET ADM("apptStatus")=$SELECT($PIECE(X0,U,17):"ADMITTED",$PIECE(X0,U,13):"CANCELLED",1:"SCHEDULED")
+15 QUIT
+16 ;
DGIEN(DATE) ; -- find #41.1 ien for DFN and DATE
+1 NEW I,X,Y
SET Y=0
+2 SET I=0
FOR
SET I=$ORDER(^DGS(41.1,"B",DFN,I))
if I<1
QUIT
IF $PIECE($GET(^DGS(41.1,I,0)),U,2)=DATE
SET Y=I
QUIT
+3 QUIT Y
+4 ;
+5 ; ------------ Return data to middle tier ------------
+6 ;
XML(APPT) ; -- Return appointment as XML
+1 NEW ATT,X,Y,NAMES
+2 DO ADD("<appointment>")
SET VPRTOTL=$GET(VPRTOTL)+1
+3 SET ATT=""
FOR
SET ATT=$ORDER(APPT(ATT))
if ATT=""
QUIT
Begin DoDot:1
+4 SET X=$GET(APPT(ATT))
SET Y=""
if '$LENGTH(X)
QUIT
+5 IF X'["^"
SET Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />"
QUIT
+6 IF $LENGTH(X)>1
SET NAMES="code^name^Z"
SET Y="<"_ATT_" "_$$LOOP_"/>"
End DoDot:1
if $LENGTH(Y)
DO ADD(Y)
+7 DO ADD("</appointment>")
+8 QUIT
+9 ;
LOOP() ; -- build sub-items string from NAMES and X
+1 NEW STR,P,TAG
SET STR=""
+2 FOR P=1:1
SET TAG=$PIECE(NAMES,U,P)
if TAG="Z"
QUIT
IF $LENGTH($PIECE(X,U,P))
SET STR=STR_TAG_"='"_$$ESC^VPRD($PIECE(X,U,P))_"' "
+3 QUIT STR
+4 ;
ADD(X) ; -- Add a line @VPR@(n)=X
+1 SET VPRI=$GET(VPRI)+1
+2 SET @VPR@(VPRI)=X
+3 QUIT
