HMPCAC ;SLC/AGP,ASMR/RRB - HMP CAC Tools;Nov 24, 2015 20:05:06
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**;Feb 06, 2014;Build 63
;Per VA Directive 6402, this routine should not be modified.
;
Q
;
ASK(YESNO,PROMPT) ;
N X,Y,TEXT
K DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="YA0"
S DIR("A")=PROMPT
S DIR("B")="N"
S DIR("?")="Enter Y or N. For detailed help type ??"
W !
D ^DIR K DIR
I $D(DIROUT) S DTOUT=1
I $D(DTOUT)!($D(DUOUT)) Q
S YESNO=$E(Y(0))
Q
;
ADDSVR() ;
N DEF,DIC,DLAYGO,SITE,SYS,Y
S SITE=$$SITE^VASITE()
S SYS=$$SYS^HMPUTILS()
W !,"Station Number: "_$P(SITE,U,3)
W !,"HMP System Identifier: "_SYS
S DEF=$S($P($G(^HMP(800000,0)),U,4)=1:$P($G(^HMP(800000,1,0)),U),1:"") I DEF'="" S DIC("B")=DEF
S DIC="^HMP(800000,",DIC(0)="AEMQL",DIC("A")="Select HMP server instance: ",DLAYGO=800000
D ^DIC
Q Y
;
;DE2818, documented code below
OPTASGN() ; called by Option: Add Health Management Platform User [HMPM ADD HMP USER]
N ARGS,DIC,DLAYGO,FDA,HASOPT,HMPERR,HMPOPT,IEN,LIST,MSG,OPTNAME,PAT,RESULT,SVR,Y,YESNO
S OPTNAME="HMP UI CONTEXT"
S HMPOPT=$$FIND1^DIC(19,"","B",OPTNAME,,,"MSG") I HMPOPT'>0 W !,"Error: Could not find 'HMP UI CONTEXT' option." Q
;
S Y=$$ADDSVR() I Y<0 Q
S SVR=$P($G(^HMP(800000,+Y,0)),U)
;
K DLAYGO
S DIC="^VA(200,",DIC(0)="AEMQ",DIC("A")="Select user to provide access to HMP: "
D ^DIC
I Y<0 Q
S IEN=+Y
;
S HASOPT=$$ACCESS^XQCHK(IEN,HMPOPT)
I +HASOPT>0 D Q
.W !,"User has 'HMP UI CONTEXT' already assigned." D ASK(.YESNO,"Sync user default CPRS patient list: ") I YESNO'="Y" Q
.I $G(YESNO)="Y" D GETPATS(.RESULT,IEN,SVR)
;
K YESNO
D ASK(.YESNO,"Assign 'HMP UI CONTEXT': ")
I YESNO'="Y" Q
S FDA(200.03,"+2,"_IEN_",",.01)=HMPOPT
D UPDATE^DIE("","FDA","","HMPERR")
I $D(HMPERR) D Q
.D EN^DDIOL("Update failed, UPDATE^DIE returned the following error message.")
.S IC="HMPERR"
.F S IC=$Q(@IC) Q:IC="" W !,IC,"=",@IC
D GETPATS(.RESULT,IEN,SVR)
Q
;
GETPATS(RESULT,IEN,SRV) ;
N ARGS,LIST,PAT
D GETDFLST(.LIST,IEN)
I '$D(LIST) W !,"No default patient list found." Q
S ARGS("command")="putPtSubscription"
S ARGS("server")=SRV
S PAT=0 F S PAT=$O(LIST(PAT)) Q:PAT'>0 D
.;check to see if patient is already sync for the server.
.I $G(^HMP(800000,"AITEM",PAT,SRV))>0 W !,"Patient "_PAT_" already synced." Q
.S ARGS("localId")=PAT
.W !,"Starting sync on patient: "_PAT
.D API^HMPDJFS(.RESULT,.ARGS)
Q
;
;
BLDLIST(LIST,HMPY) ;
N I,CNT,NODE
S I=0 F S I=$O(HMPY(I)) Q:I'>0 D
.S NODE=$G(HMPY(I)) I +NODE'>0 Q
.;S CNT=$O(HMPY(I),-1)+1
.S LIST(+$P(NODE,U))=""
Q
;
;
;The appointment list date range is designed to query for full dates,
;so when the search result exceeds 200 appointments,
;the display will end with the last appointment of the last day before the maximum was reached.
CLINPTS2(Y,USER,CLIN,BDATE,EDATE) ; WRAPPER FUNCTION FOR USE BY RPC CALL ORQPT CLINIC PATIENTS
N MAXAPPTS,APPTBGN,APPTEND,NUMAPPTS
S MAXAPPTS=200 I BDATE=EDATE S MAXAPPTS=0 ; if we only want one day, don't limit answer.
D CLINPTS(.Y,USER,CLIN,BDATE,EDATE,MAXAPPTS,.APPTBGN,.APPTEND)
S NUMAPPTS=$O(Y(""),-1)
I MAXAPPTS,NUMAPPTS'<MAXAPPTS D
. N ORI
. S ORI=0 S APPTEND=$P(APPTEND,".")
. F S ORI=$O(Y(ORI)) Q:'ORI D ;erase last day's appts since we assume it to be partial
.. I APPTEND<$P(Y(ORI),U,4) K Y(ORI) S NUMAPPTS=NUMAPPTS-1 ;erase an appointment
. S Y(MAXAPPTS+1)="^ *** UNABLE TO SHOW ALL APPOINTMENTS ***"
. S Y(MAXAPPTS+2)="^ Showing the first "_NUMAPPTS_" appointments from "_$$FMTE^XLFDT(APPTBGN,"D")_" to "_$$FMTE^XLFDT(APPTEND-1,"D")
. S Y(MAXAPPTS+3)="^"_$C(160)_" Modify the appointment list date range to start on "_$$FMTE^XLFDT(APPTEND,"D")_" to see additional appointments." ;add blank line
. S Y(MAXAPPTS+4)="^"_$C(160)_$C(160) ;add blank line
;
Q ; DE2818, added QUIT here to prevent code falling through
;
CLINPTS(Y,USER,CLIN,BDATE,EDATE,MAXAPPTS,APPTBGN,APPTEND) ; RETURN LIST OF PTS W/CLINIC APPT W/IN BEGINNING AND END DATES
; PKS-8/2003: Modified for new scheduling pkg APIs.
I $G(CLIN)<1 S Y(1)="^No clinic identified" Q
I $$ACTLOC^ORWU(CLIN)'=1 S Y(1)="^Clinic is inactive or Occasion Of Service" Q
N ORSRV,ORRESULT,ORERR,ORI,ORPT,ORPTSTAT,ORAPPT,ORCLIN,SDARRAY,NODE
I $L($G(MAXAPPTS))=0 S MAXAPPTS=200
S ORSRV=$G(^VA(200,USER,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U)
I BDATE="" S BDATE=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_+$G(ORSRV)_"^DIV^SYS^PKG","ORLP DEFAULT CLINIC START DATE",1,"E"))
I EDATE="" S EDATE=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_+$G(ORSRV)_"^DIV^SYS^PKG","ORLP DEFAULT CLINIC STOP DATE",1,"E"))
;
; Convert BDATE, EDATE to FM Date/Time:
D DT^DILF("T",BDATE,.BDATE,"","")
D DT^DILF("T",EDATE,.EDATE,"","")
I (BDATE=-1)!(EDATE=-1) S Y(1)="^Error in date range." Q
S EDATE=$P(EDATE,".")_.5 ; Add 1/2 day to end date.
;
K ^TMP($J,"SDAMA301") ; clear residual data
S ORRESULT=""
S ORCLIN=+CLIN
S SDARRAY(1)=BDATE_";"_EDATE
S SDARRAY(2)=+CLIN
S SDARRAY(3)="R;I;NT"
S SDARRAY("SORT")="P" ;no clinic index
S SDARRAY("FLDS")="3;4" ;ApptStatus^IEN;PtName
I MAXAPPTS S SDARRAY("MAX")=MAXAPPTS
;
S ORRESULT=$$SDAPI^SDAMA301(.SDARRAY) ; DBIA 4433
;
; Deal with server errors:
I ORRESULT<0 D S Y(1)=U_ORERR Q
.S ORERR=""
.N IDXERR S IDXERR=$O(^TMP($J,"SDAMA301","")) Q:IDXERR'>0
.S ORERR=^TMP($J,"SDAMA301",IDXERR)
;
; add ^TMP results to local array
S (ORPT,ORI)=0
I ORRESULT'>0 S Y(1)="^No appointments." Q
F S ORPT=$O(^TMP($J,"SDAMA301",ORPT)) Q:ORPT="" D
.S ORAPPT=""
.F S ORAPPT=$O(^TMP($J,"SDAMA301",ORPT,ORAPPT)) Q:ORAPPT="" D
..S ORI=ORI+1
..S NODE=^TMP($J,"SDAMA301",ORPT,ORAPPT)
..S Y(ORI)=$TR($P(NODE,U,4),";","^") ; IEN^Name.
..S Y(ORI)=Y(ORI)_U_ORCLIN ; ^Clinic IEN.
..S Y(ORI)=Y(ORI)_U_ORAPPT ; App't.
..I $L($G(APPTEND))=0 S APPTEND=ORAPPT,APPTBGN=ORAPPT
..I ORAPPT>APPTEND S APPTEND=ORAPPT
..I ORAPPT<APPTBGN S APPTBGN=ORAPPT
..S ORPTSTAT=$P($P(NODE,U,3),";",1) ;appt status, will be transformed to pt status.
..S ORPTSTAT=$S(ORPTSTAT="I":"IPT",ORPTSTAT="R":"OPT",ORPTSTAT="NT":"OPT",1:"") ; Pt Status.
..S Y(ORI)=Y(ORI)_U_U_U_U_U_ORPTSTAT ; Pt I or O status (or "NT").
K ^TMP($J,"SDAMA301") ; Clean house after finishing.
;
Q
;
COMBPTS(LIST,USER,PTR,BDATE,EDATE) ;
N FILE,MAXAPPTS,MSG,PTR,RTN,SRC,TXT,HMPERR,HMPY
;
; Do preliminary settings, cleanup, look for an existing user record:
S MSG="" ; Default.
S MAXAPPTS=$S(BDATE=EDATE:0,1:200) ; If date range is only one day then no max, otherwise 200
S RTN=$$FIND1^DIC(100.24,"","QX",USER,"","","HMPERR")
K HMPERR
D CLEAN^DILF ; Clean up after DB call.
;
; If no combination record, then punt:
I +RTN<1 S MSG="No combination entry." Q
;
;
; Order through the user's combination source entries:
S SORT="A" ; Required variable for PTSCOMBO^ORQPTQ5.
S SRC=0
;DE2818, ^OR(100.24) - ICR 6283
F S SRC=$O(^OR(100.24,RTN,.01,SRC)) Q:'SRC D
.K ORY ; Clean up each time.
.S TXT=$G(^OR(100.24,RTN,.01,SRC,0)) ; Get record's value.
.;
.; In case of error, punt:
.I TXT="" S MSG="Combination source entry error." Q
.S PTR=$P(TXT,";") ; Get pointer.
.S FILE="^"_$P(TXT,";",2) ; Get file.
.;
.; Get info for each source entry and build HMPY array accordingly.
.I FILE="^DIC(42," D Q ; Wards
..D WARDPTS^ORQPTQ2(.HMPY,PTR)
..I $D(HMPY) D BLDLIST(.LIST,.HMPY)
.I FILE="^VA(200," D Q ; Providers
..D PROVPTS^ORQPTQ2(.HMPY,PTR)
..I $D(HMPY) D BLDLIST(.LIST,.HMPY)
.I FILE="^DIC(45.7," D Q ; Specialties
..D SPECPTS^ORQPTQ2(.HMPY,PTR)
..I $D(HMPY) D BLDLIST(.LIST,.HMPY)
.I FILE="^OR(100.21," D Q ; Team Lists
..D TEAMPTS^ORQPTQ1(.HMPY,PTR)
..I $D(HMPY) D BLDLIST(.LIST,.HMPY)
.I FILE="^SC(" D Q ; Clinics
..N APPTBGN,APPTEND S (APPTBGN,APPTEND)=""
..D CLINPTS^ORQPTQ2(.HMPY,PTR,BDATE,EDATE,MAXAPPTS,.APPTBGN,.APPTEND)
..I $D(HMPY) D BLDLIST(.LIST,.HMPY)
;
Q
;
GETDFLST(LIST,USER) ;
N API,BEG,END,IEN,SRC,SRV,HMPSRC,HMPY,X
S SRV=$G(^VA(200,USER,5)) I +SRV>0 S SRV=$P(SRV,U)
S SRC=$$GET^XPAR("USR.`"_USER_"^SRV.`"_+$G(SRV),"ORLP DEFAULT LIST SOURCE",1,"Q")
;
I SRC="T" S IEN=$$GET^XPAR("USR.`"_USER_"^SRV.`"_+$G(SRV),"ORLP DEFAULT TEAM",1,"Q") D:+$G(IEN)>0 TEAMPTS^ORQPTQ1(.HMPY,IEN)
I SRC="W" S IEN=$$GET^XPAR("USR.`"_USER_"^SRV.`"_+$G(SRV),"ORLP DEFAULT WARD",1,"Q") D:+$G(IEN)>0 BYWARD^ORWPT(.HMPY,IEN)
I SRC="P" S IEN=$$GET^XPAR("USR.`"_USER_"^SRV.`"_+$G(SRV),"ORLP DEFAULT PROVIDER",1,"Q") D:+$G(IEN)>0 PROVPTS^ORQPTQ2(.HMPY,IEN)
I SRC="S" S IEN=$$GET^XPAR("USR.`"_USER_"^SRV.`"_+$G(SRV),"ORLP DEFAULT SPECIALTY",1,"Q") D:+$G(IEN)>0 SPECPTS^ORQPTQ2(.HMPY,IEN)
I SRC'="C",SRC'="M" D BLDLIST(.LIST,.HMPY) Q
;
I SRC="C" D Q
.F X="Monday","Tuesday","Wednesday","Thursday","Friday","Saturday","Sunday" D
..S API="ORLP DEFAULT CLINIC "_$$UP^XLFSTR(X),IEN=$$GET^XPAR("USR.`"_USER_"^SRV.`"_+$G(SRV),API,1,"Q") I +$G(IEN)>0 D
...S BEG=$$UP^XLFSTR($$GET^XPAR("USR.`"_USER_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORLP DEFAULT CLINIC START DATE",1,"E"))
...I BEG="T+0" S BEG=$$FMTE^XLFDT(DT,BEG)
...S END=$$UP^XLFSTR($$GET^XPAR("USR.`"_USER_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORLP DEFAULT CLINIC STOP DATE",1,"E"))
...I END="T+0" S END=$$FMTE^XLFDT(DT,END)
...D CLINPTS2(.HMPY,USER,+$G(IEN),BEG,END)
...D BLDLIST(.LIST,.HMPY)
I SRC="M" D Q ;DE2818, ^OR(100.24) - ICR 6283
.S IEN=$D(^OR(100.24,USER,0)) I +$G(IEN)>0 S IEN=USER D
..S BEG=$$UP^XLFSTR($$GET^XPAR("USR.`"_USER_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORLP DEFAULT CLINIC START DATE",1,"E"))
..I BEG="T+0" S BEG=$$FMTE^XLFDT(DT,BEG)
..S END=$$UP^XLFSTR($$GET^XPAR("USR.`"_USER_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORLP DEFAULT CLINIC STOP DATE",1,"E"))
..I END="T+0" S END=$$FMTE^XLFDT(DT,END)
..D COMBPTS(.LIST,USER,+$G(IEN),BEG,END) ; "0"= GUI RPC call.
Q
;
;
;REMOPT(IEN,OPT) ;
;Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPCAC 9967 printed Apr 09, 2024@20:59:46 Page 2
HMPCAC ;SLC/AGP,ASMR/RRB - HMP CAC Tools;Nov 24, 2015 20:05:06
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**;Feb 06, 2014;Build 63
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
ASK(YESNO,PROMPT) ;
+1 NEW X,Y,TEXT
+2 KILL DIROUT,DIRUT,DTOUT,DUOUT
+3 SET DIR(0)="YA0"
+4 SET DIR("A")=PROMPT
+5 SET DIR("B")="N"
+6 SET DIR("?")="Enter Y or N. For detailed help type ??"
+7 WRITE !
+8 DO ^DIR
KILL DIR
+9 IF $DATA(DIROUT)
SET DTOUT=1
+10 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+11 SET YESNO=$EXTRACT(Y(0))
+12 QUIT
+13 ;
ADDSVR() ;
+1 NEW DEF,DIC,DLAYGO,SITE,SYS,Y
+2 SET SITE=$$SITE^VASITE()
+3 SET SYS=$$SYS^HMPUTILS()
+4 WRITE !,"Station Number: "_$PIECE(SITE,U,3)
+5 WRITE !,"HMP System Identifier: "_SYS
+6 SET DEF=$SELECT($PIECE($GET(^HMP(800000,0)),U,4)=1:$PIECE($GET(^HMP(800000,1,0)),U),1:"")
IF DEF'=""
SET DIC("B")=DEF
+7 SET DIC="^HMP(800000,"
SET DIC(0)="AEMQL"
SET DIC("A")="Select HMP server instance: "
SET DLAYGO=800000
+8 DO ^DIC
+9 QUIT Y
+10 ;
+11 ;DE2818, documented code below
OPTASGN() ; called by Option: Add Health Management Platform User [HMPM ADD HMP USER]
+1 NEW ARGS,DIC,DLAYGO,FDA,HASOPT,HMPERR,HMPOPT,IEN,LIST,MSG,OPTNAME,PAT,RESULT,SVR,Y,YESNO
+2 SET OPTNAME="HMP UI CONTEXT"
+3 SET HMPOPT=$$FIND1^DIC(19,"","B",OPTNAME,,,"MSG")
IF HMPOPT'>0
WRITE !,"Error: Could not find 'HMP UI CONTEXT' option."
QUIT
+4 ;
+5 SET Y=$$ADDSVR()
IF Y<0
QUIT
+6 SET SVR=$PIECE($GET(^HMP(800000,+Y,0)),U)
+7 ;
+8 KILL DLAYGO
+9 SET DIC="^VA(200,"
SET DIC(0)="AEMQ"
SET DIC("A")="Select user to provide access to HMP: "
+10 DO ^DIC
+11 IF Y<0
QUIT
+12 SET IEN=+Y
+13 ;
+14 SET HASOPT=$$ACCESS^XQCHK(IEN,HMPOPT)
+15 IF +HASOPT>0
Begin DoDot:1
+16 WRITE !,"User has 'HMP UI CONTEXT' already assigned."
DO ASK(.YESNO,"Sync user default CPRS patient list: ")
IF YESNO'="Y"
QUIT
+17 IF $GET(YESNO)="Y"
DO GETPATS(.RESULT,IEN,SVR)
End DoDot:1
QUIT
+18 ;
+19 KILL YESNO
+20 DO ASK(.YESNO,"Assign 'HMP UI CONTEXT': ")
+21 IF YESNO'="Y"
QUIT
+22 SET FDA(200.03,"+2,"_IEN_",",.01)=HMPOPT
+23 DO UPDATE^DIE("","FDA","","HMPERR")
+24 IF $DATA(HMPERR)
Begin DoDot:1
+25 DO EN^DDIOL("Update failed, UPDATE^DIE returned the following error message.")
+26 SET IC="HMPERR"
+27 FOR
SET IC=$QUERY(@IC)
if IC=""
QUIT
WRITE !,IC,"=",@IC
End DoDot:1
QUIT
+28 DO GETPATS(.RESULT,IEN,SVR)
+29 QUIT
+30 ;
GETPATS(RESULT,IEN,SRV) ;
+1 NEW ARGS,LIST,PAT
+2 DO GETDFLST(.LIST,IEN)
+3 IF '$DATA(LIST)
WRITE !,"No default patient list found."
QUIT
+4 SET ARGS("command")="putPtSubscription"
+5 SET ARGS("server")=SRV
+6 SET PAT=0
FOR
SET PAT=$ORDER(LIST(PAT))
if PAT'>0
QUIT
Begin DoDot:1
+7 ;check to see if patient is already sync for the server.
+8 IF $GET(^HMP(800000,"AITEM",PAT,SRV))>0
WRITE !,"Patient "_PAT_" already synced."
QUIT
+9 SET ARGS("localId")=PAT
+10 WRITE !,"Starting sync on patient: "_PAT
+11 DO API^HMPDJFS(.RESULT,.ARGS)
End DoDot:1
+12 QUIT
+13 ;
+14 ;
BLDLIST(LIST,HMPY) ;
+1 NEW I,CNT,NODE
+2 SET I=0
FOR
SET I=$ORDER(HMPY(I))
if I'>0
QUIT
Begin DoDot:1
+3 SET NODE=$GET(HMPY(I))
IF +NODE'>0
QUIT
+4 ;S CNT=$O(HMPY(I),-1)+1
+5 SET LIST(+$PIECE(NODE,U))=""
End DoDot:1
+6 QUIT
+7 ;
+8 ;
+9 ;The appointment list date range is designed to query for full dates,
+10 ;so when the search result exceeds 200 appointments,
+11 ;the display will end with the last appointment of the last day before the maximum was reached.
CLINPTS2(Y,USER,CLIN,BDATE,EDATE) ; WRAPPER FUNCTION FOR USE BY RPC CALL ORQPT CLINIC PATIENTS
+1 NEW MAXAPPTS,APPTBGN,APPTEND,NUMAPPTS
+2 ; if we only want one day, don't limit answer.
SET MAXAPPTS=200
IF BDATE=EDATE
SET MAXAPPTS=0
+3 DO CLINPTS(.Y,USER,CLIN,BDATE,EDATE,MAXAPPTS,.APPTBGN,.APPTEND)
+4 SET NUMAPPTS=$ORDER(Y(""),-1)
+5 IF MAXAPPTS
IF NUMAPPTS'<MAXAPPTS
Begin DoDot:1
+6 NEW ORI
+7 SET ORI=0
SET APPTEND=$PIECE(APPTEND,".")
+8 ;erase last day's appts since we assume it to be partial
FOR
SET ORI=$ORDER(Y(ORI))
if 'ORI
QUIT
Begin DoDot:2
+9 ;erase an appointment
IF APPTEND<$PIECE(Y(ORI),U,4)
KILL Y(ORI)
SET NUMAPPTS=NUMAPPTS-1
End DoDot:2
+10 SET Y(MAXAPPTS+1)="^ *** UNABLE TO SHOW ALL APPOINTMENTS ***"
+11 SET Y(MAXAPPTS+2)="^ Showing the first "_NUMAPPTS_" appointments from "_$$FMTE^XLFDT(APPTBGN,"D")_" to "_$$FMTE^XLFDT(APPTEND-1,"D")
+12 ;add blank line
SET Y(MAXAPPTS+3)="^"_$CHAR(160)_" Modify the appointment list date range to start on "_$$FMTE^XLFDT(APPTEND,"D")_" to see additional appointments."
+13 ;add blank line
SET Y(MAXAPPTS+4)="^"_$CHAR(160)_$CHAR(160)
End DoDot:1
+14 ;
+15 ; DE2818, added QUIT here to prevent code falling through
QUIT
+16 ;
CLINPTS(Y,USER,CLIN,BDATE,EDATE,MAXAPPTS,APPTBGN,APPTEND) ; RETURN LIST OF PTS W/CLINIC APPT W/IN BEGINNING AND END DATES
+1 ; PKS-8/2003: Modified for new scheduling pkg APIs.
+2 IF $GET(CLIN)<1
SET Y(1)="^No clinic identified"
QUIT
+3 IF $$ACTLOC^ORWU(CLIN)'=1
SET Y(1)="^Clinic is inactive or Occasion Of Service"
QUIT
+4 NEW ORSRV,ORRESULT,ORERR,ORI,ORPT,ORPTSTAT,ORAPPT,ORCLIN,SDARRAY,NODE
+5 IF $LENGTH($GET(MAXAPPTS))=0
SET MAXAPPTS=200
+6 SET ORSRV=$GET(^VA(200,USER,5))
IF +ORSRV>0
SET ORSRV=$PIECE(ORSRV,U)
+7 IF BDATE=""
SET BDATE=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_+$GET(ORSRV)_"^DIV^SYS^PKG","ORLP DEFAULT CLINIC START DATE",1,"E"))
+8 IF EDATE=""
SET EDATE=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_+$GET(ORSRV)_"^DIV^SYS^PKG","ORLP DEFAULT CLINIC STOP DATE",1,"E"))
+9 ;
+10 ; Convert BDATE, EDATE to FM Date/Time:
+11 DO DT^DILF("T",BDATE,.BDATE,"","")
+12 DO DT^DILF("T",EDATE,.EDATE,"","")
+13 IF (BDATE=-1)!(EDATE=-1)
SET Y(1)="^Error in date range."
QUIT
+14 ; Add 1/2 day to end date.
SET EDATE=$PIECE(EDATE,".")_.5
+15 ;
+16 ; clear residual data
KILL ^TMP($JOB,"SDAMA301")
+17 SET ORRESULT=""
+18 SET ORCLIN=+CLIN
+19 SET SDARRAY(1)=BDATE_";"_EDATE
+20 SET SDARRAY(2)=+CLIN
+21 SET SDARRAY(3)="R;I;NT"
+22 ;no clinic index
SET SDARRAY("SORT")="P"
+23 ;ApptStatus^IEN;PtName
SET SDARRAY("FLDS")="3;4"
+24 IF MAXAPPTS
SET SDARRAY("MAX")=MAXAPPTS
+25 ;
+26 ; DBIA 4433
SET ORRESULT=$$SDAPI^SDAMA301(.SDARRAY)
+27 ;
+28 ; Deal with server errors:
+29 IF ORRESULT<0
Begin DoDot:1
+30 SET ORERR=""
+31 NEW IDXERR
SET IDXERR=$ORDER(^TMP($JOB,"SDAMA301",""))
if IDXERR'>0
QUIT
+32 SET ORERR=^TMP($JOB,"SDAMA301",IDXERR)
End DoDot:1
SET Y(1)=U_ORERR
QUIT
+33 ;
+34 ; add ^TMP results to local array
+35 SET (ORPT,ORI)=0
+36 IF ORRESULT'>0
SET Y(1)="^No appointments."
QUIT
+37 FOR
SET ORPT=$ORDER(^TMP($JOB,"SDAMA301",ORPT))
if ORPT=""
QUIT
Begin DoDot:1
+38 SET ORAPPT=""
+39 FOR
SET ORAPPT=$ORDER(^TMP($JOB,"SDAMA301",ORPT,ORAPPT))
if ORAPPT=""
QUIT
Begin DoDot:2
+40 SET ORI=ORI+1
+41 SET NODE=^TMP($JOB,"SDAMA301",ORPT,ORAPPT)
+42 ; IEN^Name.
SET Y(ORI)=$TRANSLATE($PIECE(NODE,U,4),";","^")
+43 ; ^Clinic IEN.
SET Y(ORI)=Y(ORI)_U_ORCLIN
+44 ; App't.
SET Y(ORI)=Y(ORI)_U_ORAPPT
+45 IF $LENGTH($GET(APPTEND))=0
SET APPTEND=ORAPPT
SET APPTBGN=ORAPPT
+46 IF ORAPPT>APPTEND
SET APPTEND=ORAPPT
+47 IF ORAPPT<APPTBGN
SET APPTBGN=ORAPPT
+48 ;appt status, will be transformed to pt status.
SET ORPTSTAT=$PIECE($PIECE(NODE,U,3),";",1)
+49 ; Pt Status.
SET ORPTSTAT=$SELECT(ORPTSTAT="I":"IPT",ORPTSTAT="R":"OPT",ORPTSTAT="NT":"OPT",1:"")
+50 ; Pt I or O status (or "NT").
SET Y(ORI)=Y(ORI)_U_U_U_U_U_ORPTSTAT
End DoDot:2
End DoDot:1
+51 ; Clean house after finishing.
KILL ^TMP($JOB,"SDAMA301")
+52 ;
+53 QUIT
+54 ;
COMBPTS(LIST,USER,PTR,BDATE,EDATE) ;
+1 NEW FILE,MAXAPPTS,MSG,PTR,RTN,SRC,TXT,HMPERR,HMPY
+2 ;
+3 ; Do preliminary settings, cleanup, look for an existing user record:
+4 ; Default.
SET MSG=""
+5 ; If date range is only one day then no max, otherwise 200
SET MAXAPPTS=$SELECT(BDATE=EDATE:0,1:200)
+6 SET RTN=$$FIND1^DIC(100.24,"","QX",USER,"","","HMPERR")
+7 KILL HMPERR
+8 ; Clean up after DB call.
DO CLEAN^DILF
+9 ;
+10 ; If no combination record, then punt:
+11 IF +RTN<1
SET MSG="No combination entry."
QUIT
+12 ;
+13 ;
+14 ; Order through the user's combination source entries:
+15 ; Required variable for PTSCOMBO^ORQPTQ5.
SET SORT="A"
+16 SET SRC=0
+17 ;DE2818, ^OR(100.24) - ICR 6283
+18 FOR
SET SRC=$ORDER(^OR(100.24,RTN,.01,SRC))
if 'SRC
QUIT
Begin DoDot:1
+19 ; Clean up each time.
KILL ORY
+20 ; Get record's value.
SET TXT=$GET(^OR(100.24,RTN,.01,SRC,0))
+21 ;
+22 ; In case of error, punt:
+23 IF TXT=""
SET MSG="Combination source entry error."
QUIT
+24 ; Get pointer.
SET PTR=$PIECE(TXT,";")
+25 ; Get file.
SET FILE="^"_$PIECE(TXT,";",2)
+26 ;
+27 ; Get info for each source entry and build HMPY array accordingly.
+28 ; Wards
IF FILE="^DIC(42,"
Begin DoDot:2
+29 DO WARDPTS^ORQPTQ2(.HMPY,PTR)
+30 IF $DATA(HMPY)
DO BLDLIST(.LIST,.HMPY)
End DoDot:2
QUIT
+31 ; Providers
IF FILE="^VA(200,"
Begin DoDot:2
+32 DO PROVPTS^ORQPTQ2(.HMPY,PTR)
+33 IF $DATA(HMPY)
DO BLDLIST(.LIST,.HMPY)
End DoDot:2
QUIT
+34 ; Specialties
IF FILE="^DIC(45.7,"
Begin DoDot:2
+35 DO SPECPTS^ORQPTQ2(.HMPY,PTR)
+36 IF $DATA(HMPY)
DO BLDLIST(.LIST,.HMPY)
End DoDot:2
QUIT
+37 ; Team Lists
IF FILE="^OR(100.21,"
Begin DoDot:2
+38 DO TEAMPTS^ORQPTQ1(.HMPY,PTR)
+39 IF $DATA(HMPY)
DO BLDLIST(.LIST,.HMPY)
End DoDot:2
QUIT
+40 ; Clinics
IF FILE="^SC("
Begin DoDot:2
+41 NEW APPTBGN,APPTEND
SET (APPTBGN,APPTEND)=""
+42 DO CLINPTS^ORQPTQ2(.HMPY,PTR,BDATE,EDATE,MAXAPPTS,.APPTBGN,.APPTEND)
+43 IF $DATA(HMPY)
DO BLDLIST(.LIST,.HMPY)
End DoDot:2
QUIT
End DoDot:1
+44 ;
+45 QUIT
+46 ;
GETDFLST(LIST,USER) ;
+1 NEW API,BEG,END,IEN,SRC,SRV,HMPSRC,HMPY,X
+2 SET SRV=$GET(^VA(200,USER,5))
IF +SRV>0
SET SRV=$PIECE(SRV,U)
+3 SET SRC=$$GET^XPAR("USR.`"_USER_"^SRV.`"_+$GET(SRV),"ORLP DEFAULT LIST SOURCE",1,"Q")
+4 ;
+5 IF SRC="T"
SET IEN=$$GET^XPAR("USR.`"_USER_"^SRV.`"_+$GET(SRV),"ORLP DEFAULT TEAM",1,"Q")
if +$GET(IEN)>0
DO TEAMPTS^ORQPTQ1(.HMPY,IEN)
+6 IF SRC="W"
SET IEN=$$GET^XPAR("USR.`"_USER_"^SRV.`"_+$GET(SRV),"ORLP DEFAULT WARD",1,"Q")
if +$GET(IEN)>0
DO BYWARD^ORWPT(.HMPY,IEN)
+7 IF SRC="P"
SET IEN=$$GET^XPAR("USR.`"_USER_"^SRV.`"_+$GET(SRV),"ORLP DEFAULT PROVIDER",1,"Q")
if +$GET(IEN)>0
DO PROVPTS^ORQPTQ2(.HMPY,IEN)
+8 IF SRC="S"
SET IEN=$$GET^XPAR("USR.`"_USER_"^SRV.`"_+$GET(SRV),"ORLP DEFAULT SPECIALTY",1,"Q")
if +$GET(IEN)>0
DO SPECPTS^ORQPTQ2(.HMPY,IEN)
+9 IF SRC'="C"
IF SRC'="M"
DO BLDLIST(.LIST,.HMPY)
QUIT
+10 ;
+11 IF SRC="C"
Begin DoDot:1
+12 FOR X="Monday","Tuesday","Wednesday","Thursday","Friday","Saturday","Sunday"
Begin DoDot:2
+13 SET API="ORLP DEFAULT CLINIC "_$$UP^XLFSTR(X)
SET IEN=$$GET^XPAR("USR.`"_USER_"^SRV.`"_+$GET(SRV),API,1,"Q")
IF +$GET(IEN)>0
Begin DoDot:3
+14 SET BEG=$$UP^XLFSTR($$GET^XPAR("USR.`"_USER_"^SRV.`"_+$GET(SRV)_"^DIV^SYS^PKG","ORLP DEFAULT CLINIC START DATE",1,"E"))
+15 IF BEG="T+0"
SET BEG=$$FMTE^XLFDT(DT,BEG)
+16 SET END=$$UP^XLFSTR($$GET^XPAR("USR.`"_USER_"^SRV.`"_+$GET(SRV)_"^DIV^SYS^PKG","ORLP DEFAULT CLINIC STOP DATE",1,"E"))
+17 IF END="T+0"
SET END=$$FMTE^XLFDT(DT,END)
+18 DO CLINPTS2(.HMPY,USER,+$GET(IEN),BEG,END)
+19 DO BLDLIST(.LIST,.HMPY)
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+20 ;DE2818, ^OR(100.24) - ICR 6283
IF SRC="M"
Begin DoDot:1
+21 SET IEN=$DATA(^OR(100.24,USER,0))
IF +$GET(IEN)>0
SET IEN=USER
Begin DoDot:2
+22 SET BEG=$$UP^XLFSTR($$GET^XPAR("USR.`"_USER_"^SRV.`"_+$GET(SRV)_"^DIV^SYS^PKG","ORLP DEFAULT CLINIC START DATE",1,"E"))
+23 IF BEG="T+0"
SET BEG=$$FMTE^XLFDT(DT,BEG)
+24 SET END=$$UP^XLFSTR($$GET^XPAR("USR.`"_USER_"^SRV.`"_+$GET(SRV)_"^DIV^SYS^PKG","ORLP DEFAULT CLINIC STOP DATE",1,"E"))
+25 IF END="T+0"
SET END=$$FMTE^XLFDT(DT,END)
+26 ; "0"= GUI RPC call.
DO COMBPTS(.LIST,USER,+$GET(IEN),BEG,END)
End DoDot:2
End DoDot:1
QUIT
+27 QUIT
+28 ;
+29 ;
+30 ;REMOPT(IEN,OPT) ;
+31 ;Q
+32 ;
