Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: HMPDJFSM

HMPDJFSM.m

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