HMPDSDAM ;SLC/MKB,ASMR/RRB,BL - Appointment extract;8/2/11 15:29
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**3**;Sep 01, 2011;Build 15
;Per VA Directive 6402, 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
Q
; ------------ Get appointment(s) from VistA ------------
;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's [future] appointments
N HMPX,HMPNUM,HMPDT,HMPCNT,HMPITM,HMPA,X
S DFN=+$G(DFN) Q:DFN<1
S BEG=$G(BEG,DT),END=$G(END,4141015),MAX=$G(MAX,9999)
S HMPX(1)=BEG_";"_END,HMPX(4)=DFN,HMPX("FLDS")="1;2;3;10;13",HMPX("SORT")="P"
;
; get one appt
I $L($G(ID)) D Q
. S (BEG,END)=$P(ID,";",2),HMPX(1)=BEG_";"_END,HMPX(2)=$P(ID,";",3)
. S HMPNUM=$$SDAPI^SDAMA301(.HMPX) Q:HMPNUM<1
. D EN1(BEG,.HMPITM),XML(.HMPITM)
. K ^TMP($J,"SDAMA301",DFN)
;
; get all [future] appointments
S HMPX(3)="R;I;NS;NSR;NT" ;no cancelled appt's
S HMPNUM=$$SDAPI^SDAMA301(.HMPX),(HMPDT,HMPCNT)=0
F S HMPDT=$O(^TMP($J,"SDAMA301",DFN,HMPDT)) Q:HMPDT<1 D Q:HMPCNT'<MAX
. S X=$P($G(^TMP($J,"SDAMA301",DFN,HMPDT)),U,3)
. I HMPDT<DT,$P(X,";")'["NS" Q ;no prior kept appt's
. K HMPITM D EN1(HMPDT,.HMPITM) Q:'$D(HMPITM)
. D XML(.HMPITM) S HMPCNT=HMPCNT+1
K ^TMP($J,"SDAMA301",DFN)
;
; get scheduled admissions
S HMPA=0 F S HMPA=$O(^DGS(41.1,"B",DFN,HMPA)) Q:HMPA<1 D Q:HMPCNT'<MAX ;ICR 3796 DE2818 ASF 11/20/15
. S HMPX=$G(^DGS(41.1,HMPA,0))
. Q:$P(HMPX,U,13) Q:$P(HMPX,U,17) ;cancelled or admitted
. S X=$P(HMPX,U,2) Q:X<BEG!(X>END) ;out of date range
. K HMPITM D DGS(HMPA,.HMPITM) Q:'$D(HMPITM)
. D XML(.HMPITM) S HMPCNT=HMPCNT+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 K APPT
S X=$G(^TMP($J,"SDAMA301",DFN,DATE))
S DATE=+$G(DATE),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 APPT("id")="A;"_DATE_";"_+HLOC,APPT("dateTime")=DATE I HLOC D
. S APPT("location")=$P(HLOC,";",2)
. S APPT("clinicStop")=$$AMIS^HMPDVSIT(+$P(X,U,13))
. S SV=$$GET1^DIQ(44,+HLOC_",",9.5,"I")
. I SV S APPT("service")=$$SERV(SV)
. ;find default provider
. S PRV=+$$GET1^DIQ(44,+HLOC_",",16,"I") I 'PRV D
.. N HMPP,I,FIRST
.. D GETS^DIQ(44,+HLOC_",","2600*","I","HMPP")
.. S FIRST=$O(HMPP(44.1,"")),I=""
.. F S I=$O(HMPP(44.1,I)) Q:I="" I $G(HMPP(44.1,I,.02,"I")) S PRV=$G(HMPP(44.1,I,.01,"I")) Q
.. I 'PRV,FIRST S PRV=$G(HMPP(44.1,FIRST,.01,"I"))
. I PRV S APPT("provider")=PRV_U_$P($G(^VA(200,PRV,0)),U) Q ;ICR 10060 DEE2818 ASF 11/20/15
S APPT("facility")=$$FAC^HMPD(+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"
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 ICR 3796 DE2818 ASF 11/20/15
S DATE=+$P(X0,U,2),HLOC=+$G(^DIC(42,+$P(X0,U,8),44)) ;ICR 10039 DE2818 ASF 11/20/15
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) ;ICR 10040 DE2818 ASF 11/20/15
. S X=$$GET1^DIQ(44,HLOC_",",8,"I"),ADM("clinicStop")=$$AMIS^HMPDVSIT(X)
. S SV=$$GET1^DIQ(44,HLOC_",",9.5,"I")
. I SV S ADM("service")=$$SERV(SV)
S ADM("facility")=$$FAC^HMPD(HLOC)
S X=$P(X0,U,5) I X S ADM("provider")=X_U_$P($G(^VA(200,X,0)),U) ;ICR 10060 DEE2818 ASF 11/20/15
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
;
; ------------ Return data to middle tier ------------
;
XML(APPT) ; -- Return appointment as XML
N ATT,X,Y,NAMES
D ADD("<appointment>") S HMPTOTL=$G(HMPTOTL)+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^HMPD(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^HMPD($P(X,U,P))_"' "
Q STR
;
ADD(X) ; -- Add a line @HMP@(n)=X
S HMPI=$G(HMPI)+1
S @HMP@(HMPI)=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPDSDAM 4898 printed Sep 02, 2024@18:39 Page 2
HMPDSDAM ;SLC/MKB,ASMR/RRB,BL - Appointment extract;8/2/11 15:29
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**3**;Sep 01, 2011;Build 15
+2 ;Per VA Directive 6402, 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 QUIT
+13 ; ------------ Get appointment(s) from VistA ------------
+14 ;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's [future] appointments
+1 NEW HMPX,HMPNUM,HMPDT,HMPCNT,HMPITM,HMPA,X
+2 SET DFN=+$GET(DFN)
if DFN<1
QUIT
+3 SET BEG=$GET(BEG,DT)
SET END=$GET(END,4141015)
SET MAX=$GET(MAX,9999)
+4 SET HMPX(1)=BEG_";"_END
SET HMPX(4)=DFN
SET HMPX("FLDS")="1;2;3;10;13"
SET HMPX("SORT")="P"
+5 ;
+6 ; get one appt
+7 IF $LENGTH($GET(ID))
Begin DoDot:1
+8 SET (BEG,END)=$PIECE(ID,";",2)
SET HMPX(1)=BEG_";"_END
SET HMPX(2)=$PIECE(ID,";",3)
+9 SET HMPNUM=$$SDAPI^SDAMA301(.HMPX)
if HMPNUM<1
QUIT
+10 DO EN1(BEG,.HMPITM)
DO XML(.HMPITM)
+11 KILL ^TMP($JOB,"SDAMA301",DFN)
End DoDot:1
QUIT
+12 ;
+13 ; get all [future] appointments
+14 ;no cancelled appt's
SET HMPX(3)="R;I;NS;NSR;NT"
+15 SET HMPNUM=$$SDAPI^SDAMA301(.HMPX)
SET (HMPDT,HMPCNT)=0
+16 FOR
SET HMPDT=$ORDER(^TMP($JOB,"SDAMA301",DFN,HMPDT))
if HMPDT<1
QUIT
Begin DoDot:1
+17 SET X=$PIECE($GET(^TMP($JOB,"SDAMA301",DFN,HMPDT)),U,3)
+18 ;no prior kept appt's
IF HMPDT<DT
IF $PIECE(X,";")'["NS"
QUIT
+19 KILL HMPITM
DO EN1(HMPDT,.HMPITM)
if '$DATA(HMPITM)
QUIT
+20 DO XML(.HMPITM)
SET HMPCNT=HMPCNT+1
End DoDot:1
if HMPCNT'<MAX
QUIT
+21 KILL ^TMP($JOB,"SDAMA301",DFN)
+22 ;
+23 ; get scheduled admissions
+24 ;ICR 3796 DE2818 ASF 11/20/15
SET HMPA=0
FOR
SET HMPA=$ORDER(^DGS(41.1,"B",DFN,HMPA))
if HMPA<1
QUIT
Begin DoDot:1
+25 SET HMPX=$GET(^DGS(41.1,HMPA,0))
+26 ;cancelled or admitted
if $PIECE(HMPX,U,13)
QUIT
if $PIECE(HMPX,U,17)
QUIT
+27 ;out of date range
SET X=$PIECE(HMPX,U,2)
if X<BEG!(X>END)
QUIT
+28 KILL HMPITM
DO DGS(HMPA,.HMPITM)
if '$DATA(HMPITM)
QUIT
+29 DO XML(.HMPITM)
SET HMPCNT=HMPCNT+1
End DoDot:1
if HMPCNT'<MAX
QUIT
+30 QUIT
+31 ;
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
KILL APPT
+3 SET X=$GET(^TMP($JOB,"SDAMA301",DFN,DATE))
+4 SET DATE=+$GET(DATE)
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 SET APPT("id")="A;"_DATE_";"_+HLOC
SET APPT("dateTime")=DATE
IF HLOC
Begin DoDot:1
+7 SET APPT("location")=$PIECE(HLOC,";",2)
+8 SET APPT("clinicStop")=$$AMIS^HMPDVSIT(+$PIECE(X,U,13))
+9 SET SV=$$GET1^DIQ(44,+HLOC_",",9.5,"I")
+10 IF SV
SET APPT("service")=$$SERV(SV)
+11 ;find default provider
+12 SET PRV=+$$GET1^DIQ(44,+HLOC_",",16,"I")
IF 'PRV
Begin DoDot:2
+13 NEW HMPP,I,FIRST
+14 DO GETS^DIQ(44,+HLOC_",","2600*","I","HMPP")
+15 SET FIRST=$ORDER(HMPP(44.1,""))
SET I=""
+16 FOR
SET I=$ORDER(HMPP(44.1,I))
if I=""
QUIT
IF $GET(HMPP(44.1,I,.02,"I"))
SET PRV=$GET(HMPP(44.1,I,.01,"I"))
QUIT
+17 IF 'PRV
IF FIRST
SET PRV=$GET(HMPP(44.1,FIRST,.01,"I"))
End DoDot:2
+18 ;ICR 10060 DEE2818 ASF 11/20/15
IF PRV
SET APPT("provider")=PRV_U_$PIECE($GET(^VA(200,PRV,0)),U)
QUIT
End DoDot:1
+19 SET APPT("facility")=$$FAC^HMPD(+HLOC)
+20 SET APPT("patientClass")=$SELECT(CLS="I":"IMP",1:"AMB")
+21 SET APPT("serviceCategory")=$SELECT(CLS="I":"I^INPATIENT VISIT",1:"A^AMBULATORY")
+22 SET APPT("apptStatus")=$PIECE(STS,";",2)
+23 SET APPT("visitString")=+HLOC_";"_DATE_";A"
+24 QUIT
+25 ;
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 ICR 3796 DE2818 ASF 11/20/15
SET X0=$GET(^DGS(41.1,+$GET(IFN),0))
if X0=""
QUIT
+3 ;ICR 10039 DE2818 ASF 11/20/15
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 ;ICR 10040 DE2818 ASF 11/20/15
SET ADM("location")=HLOC_U_$PIECE($GET(^SC(HLOC,0)),U)
+7 SET X=$$GET1^DIQ(44,HLOC_",",8,"I")
SET ADM("clinicStop")=$$AMIS^HMPDVSIT(X)
+8 SET SV=$$GET1^DIQ(44,HLOC_",",9.5,"I")
+9 IF SV
SET ADM("service")=$$SERV(SV)
End DoDot:1
+10 SET ADM("facility")=$$FAC^HMPD(HLOC)
+11 ;ICR 10060 DEE2818 ASF 11/20/15
SET X=$PIECE(X0,U,5)
IF X
SET ADM("provider")=X_U_$PIECE($GET(^VA(200,X,0)),U)
+12 SET ADM("patientClass")="IMP"
SET ADM("serviceCategory")="H^HOSPITALIZATION"
+13 SET ADM("apptStatus")=$SELECT($PIECE(X0,U,17):"ADMITTED",$PIECE(X0,U,13):"CANCELLED",1:"SCHEDULED")
+14 QUIT
+15 ;
+16 ; ------------ Return data to middle tier ------------
+17 ;
XML(APPT) ; -- Return appointment as XML
+1 NEW ATT,X,Y,NAMES
+2 DO ADD("<appointment>")
SET HMPTOTL=$GET(HMPTOTL)+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^HMPD(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^HMPD($PIECE(X,U,P))_"' "
+3 QUIT STR
+4 ;
ADD(X) ; -- Add a line @HMP@(n)=X
+1 SET HMPI=$GET(HMPI)+1
+2 SET @HMP@(HMPI)=X
+3 QUIT
