HMPDJFSM ;SLC/KCM,ASMR/BL,CK-PROTOCOLS & API's FOR MONITORING ;Sep 23, 2016 10:44:23
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**1,2,3**;Sep 01, 2011;Build 15
;Per VA Directive 6402, this routine should not be modified.
;
Q ; no entry at top
;DE4611, routine cleanup to bring it up to eHMP standards, 22 September 2016
;
;subroutines that support API^HMPDJFS
; HLTHCHK: check health of VistA Server subscription
; $$HLTHINFO = domain progress (Health Info) in JSON
; $$HLTHHDR = domain-progress (Health Header) header in JSON
;
;subroutines that support SRV^HMPEQ & EVTS^HMPEQ
; $$LSTREAM = latest stream for this server
; $$WAIT = # seconds the batch has been waiting
; $$LOBJ = last domain>count retrieved for this batch
;
;subroutines that support protocol menu HMPM EVT QUE MGR MENU
; $$GETSRV = protocol HMPM EVT QUE CHANGE SERVER [Change Server]
; EMERSTOP: protocol HMPM EVT QUE EMERGENCY STOP [not distributed]
; RSTRTFR: protocol HMPM EVT QUE RESTART FRESHNESS [not distributed]
; SETFRUP: set flag for freshness updates
; CHGFTYP: change the freshness update flag for domain
; STOPFTYP: stop freshness updates for domain
; STRTFTYP: resume freshness updates for domain
; $$GETFTYP = select & return domain from list
; SHOWFTYP: show freshness domains
; EVNTYPS: protocol HMPM EVT QUE CHANGE DOMAIN [Change Domain]
;
ADDPT(PAT) ; Add patient to server
N ARGS,RESULT,SRV,Y
I '$G(PAT) S PAT=$$GETPAT() Q:'PAT
S SRV=$$GETSRV() Q:SRV'>0
I $G(^HMP(800000,"AITEM",PAT,SRV))>0 W !,"Patient "_PAT_" already synched."
;
S ARGS("command")="putPtSubscription"
S ARGS("server")=$P(^HMP(800000,SRV,0),"^")
S ARGS("localId")=PAT
D API^HMPDJFS(.RESULT,.ARGS)
;IA10035, DE2818
S Y=$S(^TMP("HMPF",$J,1)["location":$P($G(^DPT(PAT,0)),"^")_" is being synched.",1:"Subscription failed.")_" DFN: "_PAT
W !,Y
Q
;
GETPAT() ; Return DFN for a patient
N DIC,Y
S DIC=2,DIC(0)="AEMQ" ; DE2818, changed to file number, not global
D ^DIC
Q +Y
;
HLTHCHK(ARGS) ; check health of VistA Server subscription
; called by:
; API^HMPDJFS: asynchronous extracts & freshness via stream
; calls:
; SETERR^HMPDJFS: log error
; $$HLTHINFO = progress for this domain
; $$HLTHHDR = JSON header for progress report
; input:
; .ARGS("server") = HMP Server Id
; also these, created by API^HMPDJFS, passed thru symbol table:
; HMPFRSP = [unused?]
; HMPFHMP = server name
; HMPSYS = system id
; output: in ^TMP("HMPF",$job,node): list of active extracts
; {pid="ABCD;229",domainsCompleted=8,domainsPending=20,
; objectCount=137,subscribeTime=20140609112734,
; extractStatus="initializing"}
;
; DE4611 begin, 21 September 2016
N DFN,HMPIEN,NXTDFN,STS,TIME
S HMPIEN=$O(^HMP(800000,"B",HMPFHMP,0))
I 'HMPIEN D SETERR^HMPDJFS("Server not registered") Q
; NODE - count of nodes in returned JSON
; NXTDFN - next DFN in queue using naked reference, if found append comma to each JSON node
S NODE=0,STS=""
F S STS=$O(^HMP(800000,HMPIEN,1,"AP",STS)) Q:'$L(STS) D
. S TIME="" F S TIME=$O(^HMP(800000,HMPIEN,1,"AP",STS,TIME)) Q:'$L(TIME) D
.. S DFN="" F S DFN=$O(^HMP(800000,HMPIEN,1,"AP",STS,TIME,DFN)) Q:'DFN S NXTDFN=$O(^(DFN)) D
... S NODE=NODE+1,^TMP("HMPF",$J,NODE)=$$HLTHINFO(HMPFHMP,HMPIEN,DFN)_$S(NXTDFN:",",1:"")
; DE4611 end
S ^TMP("HMPF",$J,.5)=$$HLTHHDR(NODE)
S ^TMP("HMPF",$J,NODE+1)="]}}"
Q
;
;
HLTHINFO(SRV,SRVIEN,DFN) ;function, return domain progress in JSON
; called by:
; HLTHCHK
; input:
; SRV = name of server, to use in ^XTMP subscripts
; SRVIEN = record # in file HMP Subscription (800000)
; DFN = record # in file Patient (2)
; output = string of JSON reporting progress for this domain
; {pid,domainsCompleted,domainsPending,objectCount,queuedTime,
; phase(waiting,extracting)
;
N BATCH,CNT,DOM,DONE,HMPERR,INFO,JSON,PEND,QTIME,STS
S BATCH="HMPFX~"_SRV_"~"_DFN
S QTIME=$G(^XTMP(BATCH,0,"time")) S:$L(QTIME) QTIME=$$HTFM^XLFDT(QTIME)
S DONE=0,PEND=0,CNT=0
S DOM="" F S DOM=$O(^XTMP(BATCH,0,"status",DOM)) Q:DOM="" D
. S CNT=CNT+$G(^XTMP(BATCH,0,"count",DOM))
. I $G(^XTMP(BATCH,0,"status",DOM)) S DONE=DONE+1 Q
. S PEND=PEND+1
S INFO("pid")=$$PID^HMPDJFS(DFN)
S INFO("domainsCompleted")=DONE,INFO("domainsPending")=PEND,INFO("objectCount")=CNT
I $L(QTIME) S INFO("queuedTime")=$$FMTHL7^HMPSTMP(QTIME) ; DE5016
S STS=$P($G(^HMP(800000,SRVIEN,1,DFN,0)),"^",2)
S INFO("extractStatus")=$S(STS=1:"initializing",STS=2:"initialized",1:"uninitialized")
D ENCODE^HMPJSON("INFO","JSON","HMPERR")
I $D(HMPERR) Q HMPERR ; encoding error, return that
Q JSON(1) ; return domain progress
;
;
HLTHHDR(COUNT) ; function, domain-progress header (health header) as JSON
; COUNT = total # items
; HMPSYS = system id (in symbol table)
N X ; $$KSP^XUPARAM = return kernel system parameter WHERE (domain)
S X="{""apiVersion"":1.02,""params"":{""domain"":"""_$$KSP^XUPARAM("WHERE")_""""
S X=X_",""systemId"":"""_HMPSYS_"""},""data"":{""updated"":"""_$$HL7NOW^HMPDJ_""""
S X=X_",""totalItems"":"_COUNT
S X=X_",""items"":["
Q X ; return domain-progress header
;
LSTREAM(SRV) ;function, latest stream for this server
; called by:
; EVTS^HMPEQ: return events for server's last stream
; SRV^HMPEQ: process one server
; calls: none
; input:
; SRV = ien of server in file HMP Subscription (8000000)
;
N STREAM
S STREAM="HMPFS~"_$P($G(^HMP(800000,SRV,0)),"^")_"~9999999999"
Q $O(^XTMP(STREAM),-1) ; return last stream ID for this server
;
WAIT(BATCH) ; function, number of seconds the batch has been waiting
; called by:
; SRV^HMPEQ: process one server
; BATCH = extract batch in ^XTMP
N START S START=$G(^XTMP(BATCH,0,"time")) Q:'START 0
Q $$HDIFF^XLFDT($H,START,2) ; return # seconds waiting
;
LOBJ(BATCH,TASK) ;function, last item in domain or <finished> if none
; called by SRV^HMPEQ process one server
; BATCH = extract batch
; TASK = extract-batch task id
Q:'$G(TASK) "no task" ; must have task
N DOMAIN,LASTITM,NUM S (DOMAIN,LASTITM,NUM)=""
F S DOMAIN=$O(^XTMP(BATCH,0,"status",DOMAIN)) Q:'$L(DOMAIN) D Q:$L(LASTITM)
. Q:$G(^XTMP(BATCH,0,"status",DOMAIN)) ; domain complete
. S NUM=$O(^XTMP(BATCH,TASK,DOMAIN,""),-1),LASTITM=DOMAIN_$S(NUM:" #"_NUM,1:"")
;
Q $S('$L(LASTITM):"<finished>",1:LASTITM) ; return last domain item
;
; subroutines that support protocol menu HMPM EVT QUE MGR MENU
GETSRV() ;extrinsic variable, interactive protocol HMPM EVT QUE CHANGE SERVER [Change Server]
; called by:
; protocol unwinder
; output = IEN of server to monitor
;
N DIC,Y
S DIC="^HMP(800000,",DIC(0)="AEMQ",DIC("A")="Select HMP server instance: "
D ^DIC Q +Y ; return IEN for the server to monitor
;
;
EMERSTOP ; protocol HMPM EVT QUE EMERGENCY STOP [not distributed]
; called by:
; protocol unwinder
; user selects a domain to stop freshness updates
; Emergency Stop for Freshness
D SETFRUP(0) Q
;
RSTRTFR ; protocol HMPM EVT QUE RESTART FRESHNESS [not distributed]
; called by:
; protocol unwinder:
; user selects a domain to resume freshness updates
; Re-start freshness updates
D SETFRUP(1) Q
;
SETFRUP(START) ; set flag for freshness updates
; called by:
; EMERSTOP
; RSTRTFR
; input:
; START = 0 to stop, 1 to resume
; user selects a domain to stop or resume freshness updates
; output:
; freshness updates stopped or resumed for selected domain
;
D:'START
. W !,"WARNING! This will stop freshness updates for the HMP."
. W !," It will be necessary to re-synch patient data.",!
D:START
. W !,"This will --RESUME-- freshness updates for the HMP."
. W !,"It may be necessary to re-synch patient and operational data.",!
N TYPLST,DMNLST,I,TYPE
D EVNTYPS(.TYPLST)
S I=0 F S I=$O(TYPLST(I)) Q:'I S DMNLST(TYPLST(I))=""
S TYPE=$$GETFTYP(.DMNLST,START)
Q:TYPE=""
I TYPE="*" D Q ; all types
. S TYPE="" F S TYPE=$O(DMNLST(TYPE)) Q:TYPE="" D CHGFTYP(TYPE,START)
D CHGFTYP(TYPE,START) Q
;
CHGFTYP(TYPE,ACTN) ; change the freshness update flag for a type
; input:
; TYPE = domain to change
; ACTN = 0 to stop, 1 to resume
I ACTN D STRTFTYP(TYPE) Q
; otherwise
D STOPFTYP(TYPE) Q
;
STOPFTYP(DMN) ; stop freshness updates for domain, DMN = domain to stop
; create ^XTMP zero node if needed, save data for 30 days
D:'$D(^XTMP("HMP-off",0)) NEWXTMP^HMPDJFS("HMP-off",30,"Switch off HMP freshness updates")
W !,"Stopping freshness updates for: "_DMN
S ^XTMP("HMP-off",DMN)=1 Q
;
STRTFTYP(DMN) ; resume freshness updates for domain, DMN = domain to resume
W !,"Resuming freshness updates for: "_DMN
K ^XTMP("HMP-off",DMN) Q
;
GETFTYP(DMNLST,ACTN) ;function, select & return domain from list, DMNLST passed by ref.
; input:
; DMNLST(domain name) = "" for all selectable domains
; ACTN = 0 to stop, 1 to resume
; user prompted to select a domain
;
N P,T,X
S P=$S(ACTN:"start",1:"stop")
F D Q:X'["?"
. D SHOWFTYP(.DMNLST)
. W !!,"Choose domain to "_P_". (* "_P_"s all): "
. R X:DTIME S:X["^" X="" Q:X="" Q:X="*"
. S X=$$LOW^XLFSTR(X) Q:$D(DMNLST(X)) ; match found
. S T=$O(DMNLST(X)) ; check for partial match
. I X=$E(T,1,$L(X)) W " "_T S X=T Q ; partial match found
. W " ??",! S X="?" ; set X to ? to keep asking
;
Q X ; return selected domain
;
;
SHOWFTYP(DMNLST) ; show freshness domains
; DMNLST(domain name) = "" for all selectable domains, passed by ref.
;list of domains displayed on current device
N C,DM,Y
S C=0,(DM,Y)="" F S DM=$O(DMNLST(DM)) Q:'$L(DM) D
. S C=C+1 I C<3 S Y=Y_DM_$J(" ",26-$L(DM)) Q ; 3 domains per line padded
. S Y=Y_DM W !,Y S C=0,Y="" ; write the line
;
I $L(Y) W !,Y ; in case any domains are left
Q
;
;
EVNTYPS(LIST) ; protocol HMPM EVT QUE CHANGE DOMAIN [Change Domain], LIST passed by ref.
;;allergy
;;appointment
;;auxiliary
;;consult
;;cpt
;;diagnosis
;;diet
;;document
;;education
;;exam
;;factor
;;image
;;immunization
;;lab
;;med
;;mh
;;obs
;;order
;;patient
;;pov
;;problem
;;procedure
;;pt-select
;;ptf
;;roadtrip
;;roster
;;skin
;;surgery
;;task
;;treatment
;;user
;;visit
;;vital
;
; list above ends with single semi-colon comment
;called by: protocol unwinder
; output: LIST(#) = domain name
N I,X
F I=1:1 S X=$P($T(EVNTYPS+I),";;",2,99) Q:X="" S LIST(I)=X
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPDJFSM 10548 printed Apr 09, 2024@20:58:31 Page 2
HMPDJFSM ;SLC/KCM,ASMR/BL,CK-PROTOCOLS & API's FOR MONITORING ;Sep 23, 2016 10:44:23
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**1,2,3**;Sep 01, 2011;Build 15
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; no entry at top
QUIT
+5 ;DE4611, routine cleanup to bring it up to eHMP standards, 22 September 2016
+6 ;
+7 ;subroutines that support API^HMPDJFS
+8 ; HLTHCHK: check health of VistA Server subscription
+9 ; $$HLTHINFO = domain progress (Health Info) in JSON
+10 ; $$HLTHHDR = domain-progress (Health Header) header in JSON
+11 ;
+12 ;subroutines that support SRV^HMPEQ & EVTS^HMPEQ
+13 ; $$LSTREAM = latest stream for this server
+14 ; $$WAIT = # seconds the batch has been waiting
+15 ; $$LOBJ = last domain>count retrieved for this batch
+16 ;
+17 ;subroutines that support protocol menu HMPM EVT QUE MGR MENU
+18 ; $$GETSRV = protocol HMPM EVT QUE CHANGE SERVER [Change Server]
+19 ; EMERSTOP: protocol HMPM EVT QUE EMERGENCY STOP [not distributed]
+20 ; RSTRTFR: protocol HMPM EVT QUE RESTART FRESHNESS [not distributed]
+21 ; SETFRUP: set flag for freshness updates
+22 ; CHGFTYP: change the freshness update flag for domain
+23 ; STOPFTYP: stop freshness updates for domain
+24 ; STRTFTYP: resume freshness updates for domain
+25 ; $$GETFTYP = select & return domain from list
+26 ; SHOWFTYP: show freshness domains
+27 ; EVNTYPS: protocol HMPM EVT QUE CHANGE DOMAIN [Change Domain]
+28 ;
ADDPT(PAT) ; Add patient to server
+1 NEW ARGS,RESULT,SRV,Y
+2 IF '$GET(PAT)
SET PAT=$$GETPAT()
if 'PAT
QUIT
+3 SET SRV=$$GETSRV()
if SRV'>0
QUIT
+4 IF $GET(^HMP(800000,"AITEM",PAT,SRV))>0
WRITE !,"Patient "_PAT_" already synched."
+5 ;
+6 SET ARGS("command")="putPtSubscription"
+7 SET ARGS("server")=$PIECE(^HMP(800000,SRV,0),"^")
+8 SET ARGS("localId")=PAT
+9 DO API^HMPDJFS(.RESULT,.ARGS)
+10 ;IA10035, DE2818
+11 SET Y=$SELECT(^TMP("HMPF",$JOB,1)["location":$PIECE($GET(^DPT(PAT,0)),"^")_" is being synched.",1:"Subscription failed.")_" DFN: "_PAT
+12 WRITE !,Y
+13 QUIT
+14 ;
GETPAT() ; Return DFN for a patient
+1 NEW DIC,Y
+2 ; DE2818, changed to file number, not global
SET DIC=2
SET DIC(0)="AEMQ"
+3 DO ^DIC
+4 QUIT +Y
+5 ;
HLTHCHK(ARGS) ; check health of VistA Server subscription
+1 ; called by:
+2 ; API^HMPDJFS: asynchronous extracts & freshness via stream
+3 ; calls:
+4 ; SETERR^HMPDJFS: log error
+5 ; $$HLTHINFO = progress for this domain
+6 ; $$HLTHHDR = JSON header for progress report
+7 ; input:
+8 ; .ARGS("server") = HMP Server Id
+9 ; also these, created by API^HMPDJFS, passed thru symbol table:
+10 ; HMPFRSP = [unused?]
+11 ; HMPFHMP = server name
+12 ; HMPSYS = system id
+13 ; output: in ^TMP("HMPF",$job,node): list of active extracts
+14 ; {pid="ABCD;229",domainsCompleted=8,domainsPending=20,
+15 ; objectCount=137,subscribeTime=20140609112734,
+16 ; extractStatus="initializing"}
+17 ;
+18 ; DE4611 begin, 21 September 2016
+19 NEW DFN,HMPIEN,NXTDFN,STS,TIME
+20 SET HMPIEN=$ORDER(^HMP(800000,"B",HMPFHMP,0))
+21 IF 'HMPIEN
DO SETERR^HMPDJFS("Server not registered")
QUIT
+22 ; NODE - count of nodes in returned JSON
+23 ; NXTDFN - next DFN in queue using naked reference, if found append comma to each JSON node
+24 SET NODE=0
SET STS=""
+25 FOR
SET STS=$ORDER(^HMP(800000,HMPIEN,1,"AP",STS))
if '$LENGTH(STS)
QUIT
Begin DoDot:1
+26 SET TIME=""
FOR
SET TIME=$ORDER(^HMP(800000,HMPIEN,1,"AP",STS,TIME))
if '$LENGTH(TIME)
QUIT
Begin DoDot:2
+27 SET DFN=""
FOR
SET DFN=$ORDER(^HMP(800000,HMPIEN,1,"AP",STS,TIME,DFN))
if 'DFN
QUIT
SET NXTDFN=$ORDER(^(DFN))
Begin DoDot:3
+28 SET NODE=NODE+1
SET ^TMP("HMPF",$JOB,NODE)=$$HLTHINFO(HMPFHMP,HMPIEN,DFN)_$SELECT(NXTDFN:",",1:"")
End DoDot:3
End DoDot:2
End DoDot:1
+29 ; DE4611 end
+30 SET ^TMP("HMPF",$JOB,.5)=$$HLTHHDR(NODE)
+31 SET ^TMP("HMPF",$JOB,NODE+1)="]}}"
+32 QUIT
+33 ;
+34 ;
HLTHINFO(SRV,SRVIEN,DFN) ;function, return domain progress in JSON
+1 ; called by:
+2 ; HLTHCHK
+3 ; input:
+4 ; SRV = name of server, to use in ^XTMP subscripts
+5 ; SRVIEN = record # in file HMP Subscription (800000)
+6 ; DFN = record # in file Patient (2)
+7 ; output = string of JSON reporting progress for this domain
+8 ; {pid,domainsCompleted,domainsPending,objectCount,queuedTime,
+9 ; phase(waiting,extracting)
+10 ;
+11 NEW BATCH,CNT,DOM,DONE,HMPERR,INFO,JSON,PEND,QTIME,STS
+12 SET BATCH="HMPFX~"_SRV_"~"_DFN
+13 SET QTIME=$GET(^XTMP(BATCH,0,"time"))
if $LENGTH(QTIME)
SET QTIME=$$HTFM^XLFDT(QTIME)
+14 SET DONE=0
SET PEND=0
SET CNT=0
+15 SET DOM=""
FOR
SET DOM=$ORDER(^XTMP(BATCH,0,"status",DOM))
if DOM=""
QUIT
Begin DoDot:1
+16 SET CNT=CNT+$GET(^XTMP(BATCH,0,"count",DOM))
+17 IF $GET(^XTMP(BATCH,0,"status",DOM))
SET DONE=DONE+1
QUIT
+18 SET PEND=PEND+1
End DoDot:1
+19 SET INFO("pid")=$$PID^HMPDJFS(DFN)
+20 SET INFO("domainsCompleted")=DONE
SET INFO("domainsPending")=PEND
SET INFO("objectCount")=CNT
+21 ; DE5016
IF $LENGTH(QTIME)
SET INFO("queuedTime")=$$FMTHL7^HMPSTMP(QTIME)
+22 SET STS=$PIECE($GET(^HMP(800000,SRVIEN,1,DFN,0)),"^",2)
+23 SET INFO("extractStatus")=$SELECT(STS=1:"initializing",STS=2:"initialized",1:"uninitialized")
+24 DO ENCODE^HMPJSON("INFO","JSON","HMPERR")
+25 ; encoding error, return that
IF $DATA(HMPERR)
QUIT HMPERR
+26 ; return domain progress
QUIT JSON(1)
+27 ;
+28 ;
HLTHHDR(COUNT) ; function, domain-progress header (health header) as JSON
+1 ; COUNT = total # items
+2 ; HMPSYS = system id (in symbol table)
+3 ; $$KSP^XUPARAM = return kernel system parameter WHERE (domain)
NEW X
+4 SET X="{""apiVersion"":1.02,""params"":{""domain"":"""_$$KSP^XUPARAM("WHERE")_""""
+5 SET X=X_",""systemId"":"""_HMPSYS_"""},""data"":{""updated"":"""_$$HL7NOW^HMPDJ_""""
+6 SET X=X_",""totalItems"":"_COUNT
+7 SET X=X_",""items"":["
+8 ; return domain-progress header
QUIT X
+9 ;
LSTREAM(SRV) ;function, latest stream for this server
+1 ; called by:
+2 ; EVTS^HMPEQ: return events for server's last stream
+3 ; SRV^HMPEQ: process one server
+4 ; calls: none
+5 ; input:
+6 ; SRV = ien of server in file HMP Subscription (8000000)
+7 ;
+8 NEW STREAM
+9 SET STREAM="HMPFS~"_$PIECE($GET(^HMP(800000,SRV,0)),"^")_"~9999999999"
+10 ; return last stream ID for this server
QUIT $ORDER(^XTMP(STREAM),-1)
+11 ;
WAIT(BATCH) ; function, number of seconds the batch has been waiting
+1 ; called by:
+2 ; SRV^HMPEQ: process one server
+3 ; BATCH = extract batch in ^XTMP
+4 NEW START
SET START=$GET(^XTMP(BATCH,0,"time"))
if 'START
QUIT 0
+5 ; return # seconds waiting
QUIT $$HDIFF^XLFDT($HOROLOG,START,2)
+6 ;
LOBJ(BATCH,TASK) ;function, last item in domain or <finished> if none
+1 ; called by SRV^HMPEQ process one server
+2 ; BATCH = extract batch
+3 ; TASK = extract-batch task id
+4 ; must have task
if '$GET(TASK)
QUIT "no task"
+5 NEW DOMAIN,LASTITM,NUM
SET (DOMAIN,LASTITM,NUM)=""
+6 FOR
SET DOMAIN=$ORDER(^XTMP(BATCH,0,"status",DOMAIN))
if '$LENGTH(DOMAIN)
QUIT
Begin DoDot:1
+7 ; domain complete
if $GET(^XTMP(BATCH,0,"status",DOMAIN))
QUIT
+8 SET NUM=$ORDER(^XTMP(BATCH,TASK,DOMAIN,""),-1)
SET LASTITM=DOMAIN_$SELECT(NUM:" #"_NUM,1:"")
End DoDot:1
if $LENGTH(LASTITM)
QUIT
+9 ;
+10 ; return last domain item
QUIT $SELECT('$LENGTH(LASTITM):"<finished>",1:LASTITM)
+11 ;
+12 ; subroutines that support protocol menu HMPM EVT QUE MGR MENU
GETSRV() ;extrinsic variable, interactive protocol HMPM EVT QUE CHANGE SERVER [Change Server]
+1 ; called by:
+2 ; protocol unwinder
+3 ; output = IEN of server to monitor
+4 ;
+5 NEW DIC,Y
+6 SET DIC="^HMP(800000,"
SET DIC(0)="AEMQ"
SET DIC("A")="Select HMP server instance: "
+7 ; return IEN for the server to monitor
DO ^DIC
QUIT +Y
+8 ;
+9 ;
EMERSTOP ; protocol HMPM EVT QUE EMERGENCY STOP [not distributed]
+1 ; called by:
+2 ; protocol unwinder
+3 ; user selects a domain to stop freshness updates
+4 ; Emergency Stop for Freshness
+5 DO SETFRUP(0)
QUIT
+6 ;
RSTRTFR ; protocol HMPM EVT QUE RESTART FRESHNESS [not distributed]
+1 ; called by:
+2 ; protocol unwinder:
+3 ; user selects a domain to resume freshness updates
+4 ; Re-start freshness updates
+5 DO SETFRUP(1)
QUIT
+6 ;
SETFRUP(START) ; set flag for freshness updates
+1 ; called by:
+2 ; EMERSTOP
+3 ; RSTRTFR
+4 ; input:
+5 ; START = 0 to stop, 1 to resume
+6 ; user selects a domain to stop or resume freshness updates
+7 ; output:
+8 ; freshness updates stopped or resumed for selected domain
+9 ;
+10 if 'START
Begin DoDot:1
+11 WRITE !,"WARNING! This will stop freshness updates for the HMP."
+12 WRITE !," It will be necessary to re-synch patient data.",!
End DoDot:1
+13 if START
Begin DoDot:1
+14 WRITE !,"This will --RESUME-- freshness updates for the HMP."
+15 WRITE !,"It may be necessary to re-synch patient and operational data.",!
End DoDot:1
+16 NEW TYPLST,DMNLST,I,TYPE
+17 DO EVNTYPS(.TYPLST)
+18 SET I=0
FOR
SET I=$ORDER(TYPLST(I))
if 'I
QUIT
SET DMNLST(TYPLST(I))=""
+19 SET TYPE=$$GETFTYP(.DMNLST,START)
+20 if TYPE=""
QUIT
+21 ; all types
IF TYPE="*"
Begin DoDot:1
+22 SET TYPE=""
FOR
SET TYPE=$ORDER(DMNLST(TYPE))
if TYPE=""
QUIT
DO CHGFTYP(TYPE,START)
End DoDot:1
QUIT
+23 DO CHGFTYP(TYPE,START)
QUIT
+24 ;
CHGFTYP(TYPE,ACTN) ; change the freshness update flag for a type
+1 ; input:
+2 ; TYPE = domain to change
+3 ; ACTN = 0 to stop, 1 to resume
+4 IF ACTN
DO STRTFTYP(TYPE)
QUIT
+5 ; otherwise
+6 DO STOPFTYP(TYPE)
QUIT
+7 ;
STOPFTYP(DMN) ; stop freshness updates for domain, DMN = domain to stop
+1 ; create ^XTMP zero node if needed, save data for 30 days
+2 if '$DATA(^XTMP("HMP-off",0))
DO NEWXTMP^HMPDJFS("HMP-off",30,"Switch off HMP freshness updates")
+3 WRITE !,"Stopping freshness updates for: "_DMN
+4 SET ^XTMP("HMP-off",DMN)=1
QUIT
+5 ;
STRTFTYP(DMN) ; resume freshness updates for domain, DMN = domain to resume
+1 WRITE !,"Resuming freshness updates for: "_DMN
+2 KILL ^XTMP("HMP-off",DMN)
QUIT
+3 ;
GETFTYP(DMNLST,ACTN) ;function, select & return domain from list, DMNLST passed by ref.
+1 ; input:
+2 ; DMNLST(domain name) = "" for all selectable domains
+3 ; ACTN = 0 to stop, 1 to resume
+4 ; user prompted to select a domain
+5 ;
+6 NEW P,T,X
+7 SET P=$SELECT(ACTN:"start",1:"stop")
+8 FOR
Begin DoDot:1
+9 DO SHOWFTYP(.DMNLST)
+10 WRITE !!,"Choose domain to "_P_". (* "_P_"s all): "
+11 READ X:DTIME
if X["^"
SET X=""
if X=""
QUIT
if X="*"
QUIT
+12 ; match found
SET X=$$LOW^XLFSTR(X)
if $DATA(DMNLST(X))
QUIT
+13 ; check for partial match
SET T=$ORDER(DMNLST(X))
+14 ; partial match found
IF X=$EXTRACT(T,1,$LENGTH(X))
WRITE " "_T
SET X=T
QUIT
+15 ; set X to ? to keep asking
WRITE " ??",!
SET X="?"
End DoDot:1
if X'["?"
QUIT
+16 ;
+17 ; return selected domain
QUIT X
+18 ;
+19 ;
SHOWFTYP(DMNLST) ; show freshness domains
+1 ; DMNLST(domain name) = "" for all selectable domains, passed by ref.
+2 ;list of domains displayed on current device
+3 NEW C,DM,Y
+4 SET C=0
SET (DM,Y)=""
FOR
SET DM=$ORDER(DMNLST(DM))
if '$LENGTH(DM)
QUIT
Begin DoDot:1
+5 ; 3 domains per line padded
SET C=C+1
IF C<3
SET Y=Y_DM_$JUSTIFY(" ",26-$LENGTH(DM))
QUIT
+6 ; write the line
SET Y=Y_DM
WRITE !,Y
SET C=0
SET Y=""
End DoDot:1
+7 ;
+8 ; in case any domains are left
IF $LENGTH(Y)
WRITE !,Y
+9 QUIT
+10 ;
+11 ;
EVNTYPS(LIST) ; protocol HMPM EVT QUE CHANGE DOMAIN [Change Domain], LIST passed by ref.
+1 ;;allergy
+2 ;;appointment
+3 ;;auxiliary
+4 ;;consult
+5 ;;cpt
+6 ;;diagnosis
+7 ;;diet
+8 ;;document
+9 ;;education
+10 ;;exam
+11 ;;factor
+12 ;;image
+13 ;;immunization
+14 ;;lab
+15 ;;med
+16 ;;mh
+17 ;;obs
+18 ;;order
+19 ;;patient
+20 ;;pov
+21 ;;problem
+22 ;;procedure
+23 ;;pt-select
+24 ;;ptf
+25 ;;roadtrip
+26 ;;roster
+27 ;;skin
+28 ;;surgery
+29 ;;task
+30 ;;treatment
+31 ;;user
+32 ;;visit
+33 ;;vital
+34 ;
+35 ; list above ends with single semi-colon comment
+36 ;called by: protocol unwinder
+37 ; output: LIST(#) = domain name
+38 NEW I,X
+39 FOR I=1:1
SET X=$PIECE($TEXT(EVNTYPS+I),";;",2,99)
if X=""
QUIT
SET LIST(I)=X
+40 QUIT
+41 ;
