- 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 Jan 18, 2025@02:54:48 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 ;