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

MDCPURG.m

Go to the documentation of this file. 
  1. MDCPURG ;HINES OIFO/DP - CP Nightly Purge Options;27 Jan 2008
  1.  ;;1.0;CLINICAL PROCEDURES;**16**;Apr 01, 2004;Build 280
  1.  ;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1.  ; This routine uses the following IAs:
  1.  ;  #10063       - %ZTLOAD calls                Kernel                         (supported)
  1.  ;  # 2263       - XPAR calls                   Toolkit                        (supported)
  1.  ;
  1.  ;
  1.  ;
  1. EN ; Not called interactively
  1.  Q
  1.  ;
  1. CP ; CP Legacy Cleanup
  1.  N ZTREQ
  1.  S ZTREQ=$$ZTREQ("CP_CLEANUP")
  1.  S MDSTOP=+$$GET^XPAR("SYS","MD PARAMETERS","INSTRUMENT_DATA_RETENTION") Q:'MDSTOP
  1.  S MDSTOP=$$FMADD^XLFDT(DT\1,MDSTOP*-1)
  1.  S MDDT=""
  1.  F  S MDDT=$O(^MDD(703.1,"ADTP",MDDT)) Q:MDDT=""  D:+MDDT<MDSTOP
  1.  .F X1=0:0 S X1=$O(^MDD(703.1,"ADTP",MDDT,X1)) Q:'X1  D
  1.  ..S MDFDA(703.1,X1_",",.4)="@"
  1.  ..F X2=0:0 S X2=$O(^MDD(703.1,X1,.1,X2)) Q:'X2  D
  1.  ...S MDFDA(703.11,X2_","_X1_",",.01)="@"
  1.  ..D FILE^DIE("","MDFDA") K MDFDA
  1.  Q
  1.  ;
  1. CLIO ; CliO Background Cleanup
  1.  S ZTREQ=$$ZTREQ("CLIO_CLEANUP")
  1.  S MDSTOP=+$$GET^XPAR("SYS","MD PARAMETERS","UNVERIFIED_OBS_RETENTION") Q:'MDSTOP
  1.  S MDSTOP=$$FMADD^XLFDT(DT,MDSTOP*-1)
  1.  F MDDT=0:0 S MDDT=$O(^MDC(704.117,"AUV",0,MDDT)) Q:'MDDT!(MDDT>MDSTOP)  D
  1.  .F MDDA=0:0 S MDDA=$O(^MDC(704.117,"AUV",0,MDDT,MDDA)) Q:'MDDA  D
  1.  ..D PURGEOBS(MDDA)
  1.  ..; Checking for child observations as well
  1.  ..S MDGBL=$NA(^MDC(704.117,"AP",MDDA))
  1.  ..F  S MDGBL=$Q(@MDGBL) Q:MDGBL=""  Q:$QS(MDGBL,3)'=MDDA  D
  1.  ...D PURGEOBS($QS(MDGBL,5))
  1.  ..D FILE^DIE("K","MDFDA") ; Bang!
  1.  ..K MDFDA
  1.  Q
  1.  ;
  1. PURGEOBS(MDDA) ; Gathers the pointers for a single observation
  1.  N MDGBL
  1.  S MDFDA(704.117,MDDA_",",.01)="@"
  1.  ;
  1.  ; Get the SET pointers
  1.  S MDGBL=$NA(^MDC(704.1161,"AS",MDDA))
  1.  F  S MDGBL=$Q(@MDGBL) Q:MDGBL=""  Q:$QS(MDGBL,3)'=MDDA  D
  1.  .S MDFDA(704.1161,$QS(MDGBL,5)_",",.01)="@"
  1.  ;
  1.  ; Get the QUALIFIER pointers
  1.  S MDGBL=$NA(^MDC(704.118,"PK",MDDA))
  1.  F  S MDGBL=$Q(@MDGBL) Q:MDGBL=""  Q:$QS(MDGBL,3)'=MDDA  D
  1.  .S MDFDA(704.118,$QS(MDGBL,5)_",",.01)="@"
  1.  Q
  1.  ;
  1. HL7 ; Purges HL7 data from 704.002
  1.  S ZTREQ=$$ZTREQ("HL7_CLEANUP")
  1.  S MDCSTOP=+$$GET^XPAR("SYS","MD PARAMETERS","GATEWAY_DATA_RETENTION") Q:'MDCSTOP
  1.  D NOW^%DTC S MDCSTOP=$$FMADD^XLFDT(%,-MDCSTOP,0,0,0)
  1.  N MDCDTTM,MDCIEN S (MDCDTTM,MDCIEN)=0
  1.  F  S MDCDTTM=$O(^MDC(704.002,"PURGE","4",MDCDTTM)) Q:$G(MDCDTTM)=""  Q:(MDCDTTM>MDCSTOP)  D
  1.  .N MDCIEN S MDCIEN=0
  1.  .F  S MDCIEN=$O(^MDC(704.002,"PURGE","4",MDCDTTM,MDCIEN)) Q:$G(MDCIEN)=""  D
  1.  ..N MDCFDA,MDCSIEN S MDCSIEN=0
  1.  ..S MDCFDA(704.002,MDCIEN_",",.01)="@"
  1.  ..F  S MDCSIEN=$O(^MDC(704.004,"B",MDCIEN,MDCSIEN)) Q:$G(MDCSIEN)=""  D
  1.  ...S MDCFDA(704.004,MDCSIEN_",",.01)="@"
  1.  ..D FILE^DIE("K","MDCFDA")
  1.  K MDCSTOP
  1.  Q
  1.  ;
  1. QUERIES ; Clear the cached queries nightly
  1.  S ZTREQ=$$ZTREQ("CACHE_QUERIES")
  1.  N MDOPT,MDQ,MDCMD,MDERR,MDNAME
  1.  ; First, clear out all queries
  1.  D CLEARQ
  1.  ; Now re-build them :)
  1.  D GETLST^XPAR(.MDOPT,"SYS","MD COMMANDS","Q")
  1.  F MDQ=0:0 S MDQ=$O(MDOPT(MDQ)) Q:'MDQ  D
  1.  .S MDNAME=$P(MDOPT(MDQ),"^",1),MDNODE="MDCACHE_"_MDNAME
  1.  .D GETWP^XPAR(.MDCMD,"SYS","MD COMMANDS",MDNAME,.MDERR)
  1.  .I $P(MDCMD(1,0),";",7)'=1 Q
  1.  .L +(^XTMP(MDNODE)):60 E  Q
  1.  .K ^XTMP(MDNODE)
  1.  .D RPC^MDCLIO(.MDRET,"EXECUTE",MDNAME)
  1.  .S ^XTMP(MDNODE,0)=$$FMADD^XLFDT(DT,1)_U_DT
  1.  .M ^XTMP(MDNODE,1)=@MDRET
  1.  .L -(^XTMP(MDNODE))
  1.  Q
  1.  ;
  1. CLEARQ ; Clear Queries Cache - Ignores script settings
  1.  N MDQ
  1.  S MDQ="MDCACHE_"
  1.  F  S MDQ=$O(^XTMP(MDQ)) Q:MDQ'?1"MDCACHE_".E  D
  1.  .L +(^XTMP(MDQ)):60 E  Q  ; Will try again next time ...
  1.  .K ^XTMP(MDQ)
  1.  .L -(^XTMP(MDQ))
  1.  Q
  1.  ;
  1. GETPAR(TASKID) ; Get Task in Parameter File
  1.  Q $$GET^XPAR("SYS","MD PARAMETERS","TASK_"_TASKID)
  1.  ;
  1. SETPAR(TASKID,ZTSK,NAME,RTN,RECUR) ;
  1.  D EN^XPAR("SYS","MD PARAMETERS","TASK_"_TASKID,+$G(ZTSK)_";"_$G(NAME,"Task Has No Name")_";"_$TR($G(RTN),"^"," ")_";"_(+$G(RECUR)))
  1.  Q
  1.  ;
  1. ZTSK(TASKID) ; Taskman ID - According to MD PARAMETERS, creates one if missing
  1.  N ZTSK
  1.  Q:$$GETPAR(TASKID)="" -1 ; Error state, TASKID not in XPAR
  1.  S ZTSK=+$P($$GETPAR(TASKID),";")
  1.  D STAT^%ZTLOAD I ZTSK(0)=1 Q ZTSK
  1.  Q 0
  1.  ;
  1. DESC(TASKID) ; Task Description
  1.  Q $P($$GETPAR(TASKID),";",2)
  1.  ;
  1. RTN(TASKID) ; Task Routine
  1.  Q $TR($P($$GETPAR(TASKID),";",3)," ",U)
  1.  ;
  1. ZTREQ(TASKID) ; Taskman re-queue identifier
  1.  Q $P("@^1H^1D^7D^30D^365D",U,$$RECUR(TASKID)+1)
  1.  ;
  1. RECUR(TASKID) ; Task Recurrence
  1.  Q +$P($$GETPAR(TASKID),";",4)
  1.  ;
  1. START ; Queue the task to be ran @ P2(0)
  1.  ; P2(0)=TASK ID as stored in XPAR (i.e. the name of the background task)
  1.  N ZTSK,ZTRTN,ZTDESC,ZTDTH,ZTIO
  1.  S ZTSK=$$ZTSK(P2(0))
  1.  D:'ZTSK  ; Create unscheduled task
  1.  .S ZTRTN=$$RTN(P2(0))
  1.  .S ZTDESC=$$DESC(P2(0))
  1.  .S ZTDTH="@"
  1.  .S ZTIO=""
  1.  .D ^%ZTLOAD
  1.  D ISQED^%ZTLOAD D:ZTSK(0)=1 DQ^%ZTLOAD ; Just to be safe DQ the task first
  1.  S ZTDESC=$$DESC(P2(0)),ZTRTN=$$RTN(P2(0)),ZTIO=""
  1.  S ZTDTH=$$FMDT^MDCLIO(P2(1))
  1.  D REQ^%ZTLOAD
  1.  D SETPAR(P2(0),ZTSK,$$DESC(P2(0)),$$RTN(P2(0)),+$G(P2(2)))
  1.  S @RESULTS@(0)="1^RESCHEDULED"
  1.  Q
  1.  ;
  1. STOP ; Stop the task (i.e. dequeue)
  1.  N ZTSK
  1.  S ZTSK=$$ZTSK(P2(0))
  1.  D ISQED^%ZTLOAD D:ZTSK(0)=1 DQ^%ZTLOAD
  1.  D STAT
  1.  Q
  1.  ;
  1. STAT ; GET THE STATUS OF THE PURGE JOB
  1.  D NEWDOC^MDCLIO("RESULTS")
  1.  D XMLHDR^MDCLIO("RECORD")
  1.  D XMLDATA^MDCLIO("TASK_ID",P2(0))
  1.  S ZTSK=$$ZTSK(P2(0))
  1.  I ZTSK<0 D  Q
  1.  .D XMLDATA^MDCLIO("TASK",-1)
  1.  .D XMLDATA^MDCLIO("STATUS","-1")
  1.  .D XMLDATA^MDCLIO("MESSAGE","No task ID parameter settings.")
  1.  .D XMLFTR^MDCLIO("RECORD")
  1.  .D ENDDOC^MDCLIO("RESULTS")
  1.  ;
  1.  D XMLDATA^MDCLIO("TASK",ZTSK)
  1.  D XMLDATA^MDCLIO("TASK_NAME",$$DESC(P2(0)))
  1.  D XMLDATA^MDCLIO("TASK_ROUTINE",$$RTN(P2(0)))
  1.  D XMLDATA^MDCLIO("RECURRENCE",$$RECUR(P2(0)))
  1.  ;
  1.  D STAT^%ZTLOAD
  1.  I '$G(ZTSK(0)) D  Q
  1.  .D XMLDATA^MDCLIO("STATUS",0)
  1.  .D XMLDATA^MDCLIO("MESSAGE","Task ID not found in Taskman.")
  1.  .D XMLFTR^MDCLIO("RECORD")
  1.  .D ENDDOC^MDCLIO("RESULTS")
  1.  ;
  1.  D XMLDATA^MDCLIO("STATUS",ZTSK(1))
  1.  D XMLDATA^MDCLIO("MESSAGE",ZTSK(2))
  1.  I ZTSK(1)=1 D
  1.  .D ISQED^%ZTLOAD
  1.  .I $G(ZTSK("D"))]"" D XMLDT^MDCLIO("SCHEDULED",$$HTFM^XLFDT(ZTSK("D")))
  1.  D XMLFTR^MDCLIO("RECORD")
  1.  D ENDDOC^MDCLIO("RESULTS")
  1.  Q
  1.  ;
  1. GETTASKS ; Get list of the known tasks
  1.  N MDLIST,MDERR,MDTASK
  1.  D BLD
  1.  D GETLST^XPAR(.MDLIST,"SYS","MD PARAMETERS","Q",.MDERR)
  1.  D NEWDOC^MDCLIO("RESULTS")
  1.  F MDTASK=0:0 S MDTASK=$O(MDLIST(MDTASK)) Q:'MDTASK  D
  1.  .Q:MDLIST(MDTASK)'?1"TASK_".E
  1.  .D XMLHDR^MDCLIO("RECORD")
  1.  .D XMLDATA^MDCLIO("TASK_ID",$P($P(MDLIST(MDTASK),"^",1),"TASK_",2))
  1.  .D XMLDATA^MDCLIO("TASK_NAME",$P(MDLIST(MDTASK),";",2))
  1.  .D XMLDATA^MDCLIO("TASK",+$P(MDLIST(MDTASK),"^",2))
  1.  .D XMLFTR^MDCLIO("RECORD")
  1.  D ENDDOC^MDCLIO("RESULTS")
  1.  Q
  1.  ;
  1. BLD ; Build the known tasks
  1.  I $$GETPAR("CLIO_CLEANUP")="" D SETPAR("CLIO_CLEANUP",0,"CliO Cleanup","CLIO^MDCPURG")
  1.  I $$GETPAR("CP_CLEANUP")="" D SETPAR("CP_CLEANUP",0,"CP Legacy Cleanup","CP^MDCPURG")
  1.  I $$GETPAR("HL7_CLEANUP")="" D SETPAR("HL7_CLEANUP",0,"HL7 Log Cleanup","HL7^MDCPURG")
  1.  Q