TIUP271 ;SMT - Clean up utility for TIU*271 ; 4/12/13 10:57am
;;1.0;TEXT INTEGRATION UTILITIES;**271**;Aug 23, 2012;Build 12
Q
; Utility By Seth Thompson - updated by Daniel Huffman
; Clean up String Dates in Field 1301 of file 8925
;
EN ;
N DIE,DA,DR,TIUDT,TIUDA,CNT,RECS,ERR
;
I $D(^TMP("TIU271")) W !,"Already Running! Only one instance allowed" Q
S ^TMP("TIU271",0)="TIU*1*271 CLEANUP RUNNING"
;
S TIUDT=9999999,ERR=0,CNT=1,RECS=0
F S TIUDT=$O(^TIU(8925,"D",TIUDT)) Q:'TIUDT D
. S DA=0 F S DA=$O(^TIU(8925,"D",TIUDT,DA)) Q:'DA D
. . S RECS=RECS+1 D LOCK^TIUSRVP(.ERR,DA)
. . I 'ERR D Q
. . . S DIE="^TIU(8925,",DR="1301///"_+TIUDT
. . . D ^DIE
. . . D UNLOCK^TIUSRVP(.ERR,DA)
. . I $D(^TIU(8925,"D",TIUDT,DA)) D ;If the node still exists...
. . . S ^TMP("TIU271",CNT)="TIU Document:"_DA_" Reference Date:"_$$GET1^DIQ(8925,DA,1301,"I"),CNT=CNT+1
. . . S ^TMP("TIU271",CNT)=" Reason: "_$S(ERR:$P(ERR,"^",2),1:"UNKNOWN"),CNT=CNT+1
D MAIL
K ^TMP("TIU271")
S $P(^XTMP("TIUP271",0,"LAST"),U)="COMPLETED" ; djh update Set Completed status
S $P(^XTMP("TIUP271",0,"LAST"),U,3)=$$NOW^XLFDT ; djh update Set completed date/time
Q
;
MAIL ;
; djh update - Change XMD to XMY in newed list
N CNT,MSG,XMY,XMDUZ,DIFROM,XMSUB,XMTEXT,I,NMSP,VAR
;
S CNT=1
S XMY(DUZ)="",XMY("G.TIU CACS")=""
; djh update add 'Patch ' to from text (XMDUZ) - fixes problem with mailman msg not being sent if any user name starts with TIU
S XMSUB="REFERENCE DATES CORRECTED",XMTEXT="MSG(",XMDUZ="Patch TIU*1.0*271"
S MSG(CNT)="This is a list of TIU Documents that had erroneous dates in the REFERENCE DATE ",CNT=CNT+1
S MSG(CNT)="field and could not be cleaned up.",CNT=CNT+1
S MSG(CNT)="For more information about the related issue, please see patch TIU*1*271",CNT=CNT+1
S MSG(CNT)="",CNT=CNT+1
;
S I=0 F S I=$O(^TMP("TIU271",I)) Q:'I S MSG(CNT)=^TMP("TIU271",I),CNT=CNT+1
S:$O(^TMP("TIU271",0))="" MSG(CNT)="No Problems in REFERENCE DATE correction."
D ^XMD
Q
;
QUE ; Entry point from kids Install
N NAMSP,PATCH,JOBN,DTOUT,DUOUT,ZTSK,ZTRTN,ZTIO,ZTDTH,ZTDESC,QUIT,Y,ZTQUEUED,ZTREQ,ZTSAVE
S NAMSP=$$NAMSP
S JOBN="REFERENCE DATE UPDATE"
S PATCH="TIU*1.0*271"
;
L +^XTMP(NAMSP):$G(DILOCKTM,3) I '$T D Q
. D BMES^XPDUTL(JOBN_" job is already running. Halting...")
. D MES^XPDUTL("")
. D QUIT
;
I '$D(^XTMP(NAMSP)) D INITXTMP(NAMSP,JOBN_", "_PATCH,90) ;90 day life
S QUIT=0
;
I $G(^XTMP(NAMSP,0,"LAST"))["COMPLETED" D Q
. W !!,*7,"This job has been run before to completion on "
. ; djh update - use completed date from piece 3
. W $$FMTE^XLFDT($P($G(^XTMP(NAMSP,0,"LAST")),"^",3)),!!
. W "If you want to run it again, the global subscript ^XTMP('"_NAMSP_"') must be",!
. W "deleted prior to doing so.",!!
. D QUIT
;
;ques 2, if running from mumps prompt
I '$D(XPDQUES("POS2")) D I 'ZTDTH D QUIT Q
. K DIR
. S DIR("A",1)=" Enter when to Queue the "_JOBN_" job to run"
. S DIR("A")=" in date@time format"
. S DIR("B")="NOW"
. S DIR(0)="D^::%DT"
. S DIR("?")=" Enter when to start the job. The default is Now. You can enter a date and time in the format like this: 021506@3:30p"
. D ^DIR I $D(DUOUT) W !,"Halting..." S ZTDTH="" Q
. S:$D(DTOUT) Y=$$NOW^XLFDT S ZTDTH=$$FMTH^XLFDT(Y)
. S $P(^XTMP(NAMSP,0,"LAST"),"^",1,2)="RUN^"_$$NOW^XLFDT
;
;ques 2, if running from kids install
I $D(XPDQUES("POS2")) S ZTDTH=$$FMTH^XLFDT(XPDQUES("POS2"))
;
D BMES^XPDUTL("=============================================================")
D MES^XPDUTL("Queuing background job for "_JOBN_"...")
D MES^XPDUTL("Start time: "_$$HTE^XLFDT(ZTDTH))
D MES^XPDUTL("==============================================================")
I ZTDTH="" D BMES^XPDUTL(JOBN_" NOT QUEUED") D QUIT Q
;
S:$D(^XTMP(NAMSP,0,"LAST")) ^XTMP(NAMSP,0,"ZAUDIT",$H)="RE-STARTED ON"_"^"_$$NOW^XLFDT_"^"_$P(^XTMP(NAMSP,0,"LAST"),"^",2,5)
;
I $P($G(^XTMP(NAMSP,0,"LAST")),"^")="STOP" D
. S $P(^XTMP(NAMSP,0,"LAST"),"^",1,2)="RUN^"_$$NOW^XLFDT
E D
. S ^XTMP(NAMSP,0,"LAST")="RUN^"_$$NOW^XLFDT_"^^^"
;
S ZTRTN="EN^"_NAMSP,ZTIO=""
S ZTDESC="Background job "_JOBN_" updated via "_PATCH
S ZTSAVE("JOBN")=""
L -^XTMP(NAMSP)
D ^%ZTLOAD
D:$D(ZTSK)
. D MES^XPDUTL("*** Task #"_ZTSK_" Queued! ***")
. D BMES^XPDUTL("")
D BMES^XPDUTL("")
K XPDQUES
Q
;
NAMSP() ;
Q $T(+0)
;
STOP ;stop job command
I $$ST S ^XTMP($$NAMSP,0,"STOP")="" D
. W !,"TALLY MISSING EXPIRATION DATES Job - set to STOP Soon"
. W !!,"Check Status to be sure it has stopped and is not running..."
. W !," (D STATUS^PSOTEXP1)"
Q
;
ST() ;status
L +^XTMP($$NAMSP):$G(DILOCKTM,3) I $T D Q 0
. L -^XTMP($$NAMSP)
. W !,"*** NOT CURRENTLY RUNNING! ***",!
Q 1
;
INITXTMP(NAMSP,TITLE,LIFE) ;create ^Xtmp according to SAC std
N BEGDT,PURGDT
S BEGDT=$$NOW^XLFDT()
S PURGDT=$$FMADD^XLFDT(BEGDT,LIFE)
I $G(^XTMP(NAMSP,0))']"" S ^XTMP(NAMSP,0)=PURGDT_"^"_BEGDT_"^"_TITLE
Q
;
QUIT ;
L -^XTMP(NAMSP)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUP271 5041 printed Dec 13, 2024@02:42:55 Page 2
TIUP271 ;SMT - Clean up utility for TIU*271 ; 4/12/13 10:57am
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**271**;Aug 23, 2012;Build 12
+2 QUIT
+3 ; Utility By Seth Thompson - updated by Daniel Huffman
+4 ; Clean up String Dates in Field 1301 of file 8925
+5 ;
EN ;
+1 NEW DIE,DA,DR,TIUDT,TIUDA,CNT,RECS,ERR
+2 ;
+3 IF $DATA(^TMP("TIU271"))
WRITE !,"Already Running! Only one instance allowed"
QUIT
+4 SET ^TMP("TIU271",0)="TIU*1*271 CLEANUP RUNNING"
+5 ;
+6 SET TIUDT=9999999
SET ERR=0
SET CNT=1
SET RECS=0
+7 FOR
SET TIUDT=$ORDER(^TIU(8925,"D",TIUDT))
if 'TIUDT
QUIT
Begin DoDot:1
+8 SET DA=0
FOR
SET DA=$ORDER(^TIU(8925,"D",TIUDT,DA))
if 'DA
QUIT
Begin DoDot:2
+9 SET RECS=RECS+1
DO LOCK^TIUSRVP(.ERR,DA)
+10 IF 'ERR
Begin DoDot:3
+11 SET DIE="^TIU(8925,"
SET DR="1301///"_+TIUDT
+12 DO ^DIE
+13 DO UNLOCK^TIUSRVP(.ERR,DA)
End DoDot:3
QUIT
+14 ;If the node still exists...
IF $DATA(^TIU(8925,"D",TIUDT,DA))
Begin DoDot:3
+15 SET ^TMP("TIU271",CNT)="TIU Document:"_DA_" Reference Date:"_$$GET1^DIQ(8925,DA,1301,"I")
SET CNT=CNT+1
+16 SET ^TMP("TIU271",CNT)=" Reason: "_$SELECT(ERR:$PIECE(ERR,"^",2),1:"UNKNOWN")
SET CNT=CNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+17 DO MAIL
+18 KILL ^TMP("TIU271")
+19 ; djh update Set Completed status
SET $PIECE(^XTMP("TIUP271",0,"LAST"),U)="COMPLETED"
+20 ; djh update Set completed date/time
SET $PIECE(^XTMP("TIUP271",0,"LAST"),U,3)=$$NOW^XLFDT
+21 QUIT
+22 ;
MAIL ;
+1 ; djh update - Change XMD to XMY in newed list
+2 NEW CNT,MSG,XMY,XMDUZ,DIFROM,XMSUB,XMTEXT,I,NMSP,VAR
+3 ;
+4 SET CNT=1
+5 SET XMY(DUZ)=""
SET XMY("G.TIU CACS")=""
+6 ; djh update add 'Patch ' to from text (XMDUZ) - fixes problem with mailman msg not being sent if any user name starts with TIU
+7 SET XMSUB="REFERENCE DATES CORRECTED"
SET XMTEXT="MSG("
SET XMDUZ="Patch TIU*1.0*271"
+8 SET MSG(CNT)="This is a list of TIU Documents that had erroneous dates in the REFERENCE DATE "
SET CNT=CNT+1
+9 SET MSG(CNT)="field and could not be cleaned up."
SET CNT=CNT+1
+10 SET MSG(CNT)="For more information about the related issue, please see patch TIU*1*271"
SET CNT=CNT+1
+11 SET MSG(CNT)=""
SET CNT=CNT+1
+12 ;
+13 SET I=0
FOR
SET I=$ORDER(^TMP("TIU271",I))
if 'I
QUIT
SET MSG(CNT)=^TMP("TIU271",I)
SET CNT=CNT+1
+14 if $ORDER(^TMP("TIU271",0))=""
SET MSG(CNT)="No Problems in REFERENCE DATE correction."
+15 DO ^XMD
+16 QUIT
+17 ;
QUE ; Entry point from kids Install
+1 NEW NAMSP,PATCH,JOBN,DTOUT,DUOUT,ZTSK,ZTRTN,ZTIO,ZTDTH,ZTDESC,QUIT,Y,ZTQUEUED,ZTREQ,ZTSAVE
+2 SET NAMSP=$$NAMSP
+3 SET JOBN="REFERENCE DATE UPDATE"
+4 SET PATCH="TIU*1.0*271"
+5 ;
+6 LOCK +^XTMP(NAMSP):$GET(DILOCKTM,3)
IF '$TEST
Begin DoDot:1
+7 DO BMES^XPDUTL(JOBN_" job is already running. Halting...")
+8 DO MES^XPDUTL("")
+9 DO QUIT
End DoDot:1
QUIT
+10 ;
+11 ;90 day life
IF '$DATA(^XTMP(NAMSP))
DO INITXTMP(NAMSP,JOBN_", "_PATCH,90)
+12 SET QUIT=0
+13 ;
+14 IF $GET(^XTMP(NAMSP,0,"LAST"))["COMPLETED"
Begin DoDot:1
+15 WRITE !!,*7,"This job has been run before to completion on "
+16 ; djh update - use completed date from piece 3
+17 WRITE $$FMTE^XLFDT($PIECE($GET(^XTMP(NAMSP,0,"LAST")),"^",3)),!!
+18 WRITE "If you want to run it again, the global subscript ^XTMP('"_NAMSP_"') must be",!
+19 WRITE "deleted prior to doing so.",!!
+20 DO QUIT
End DoDot:1
QUIT
+21 ;
+22 ;ques 2, if running from mumps prompt
+23 IF '$DATA(XPDQUES("POS2"))
Begin DoDot:1
+24 KILL DIR
+25 SET DIR("A",1)=" Enter when to Queue the "_JOBN_" job to run"
+26 SET DIR("A")=" in date@time format"
+27 SET DIR("B")="NOW"
+28 SET DIR(0)="D^::%DT"
+29 SET DIR("?")=" Enter when to start the job. The default is Now. You can enter a date and time in the format like this: 021506@3:30p"
+30 DO ^DIR
IF $DATA(DUOUT)
WRITE !,"Halting..."
SET ZTDTH=""
QUIT
+31 if $DATA(DTOUT)
SET Y=$$NOW^XLFDT
SET ZTDTH=$$FMTH^XLFDT(Y)
+32 SET $PIECE(^XTMP(NAMSP,0,"LAST"),"^",1,2)="RUN^"_$$NOW^XLFDT
End DoDot:1
IF 'ZTDTH
DO QUIT
QUIT
+33 ;
+34 ;ques 2, if running from kids install
+35 IF $DATA(XPDQUES("POS2"))
SET ZTDTH=$$FMTH^XLFDT(XPDQUES("POS2"))
+36 ;
+37 DO BMES^XPDUTL("=============================================================")
+38 DO MES^XPDUTL("Queuing background job for "_JOBN_"...")
+39 DO MES^XPDUTL("Start time: "_$$HTE^XLFDT(ZTDTH))
+40 DO MES^XPDUTL("==============================================================")
+41 IF ZTDTH=""
DO BMES^XPDUTL(JOBN_" NOT QUEUED")
DO QUIT
QUIT
+42 ;
+43 if $DATA(^XTMP(NAMSP,0,"LAST"))
SET ^XTMP(NAMSP,0,"ZAUDIT",$HOROLOG)="RE-STARTED ON"_"^"_$$NOW^XLFDT_"^"_$P(^XTMP(NAMSP,0,"LAST"),"^",2,5)
+44 ;
+45 IF $PIECE($GET(^XTMP(NAMSP,0,"LAST")),"^")="STOP"
Begin DoDot:1
+46 SET $PIECE(^XTMP(NAMSP,0,"LAST"),"^",1,2)="RUN^"_$$NOW^XLFDT
End DoDot:1
+47 IF '$TEST
Begin DoDot:1
+48 SET ^XTMP(NAMSP,0,"LAST")="RUN^"_$$NOW^XLFDT_"^^^"
End DoDot:1
+49 ;
+50 SET ZTRTN="EN^"_NAMSP
SET ZTIO=""
+51 SET ZTDESC="Background job "_JOBN_" updated via "_PATCH
+52 SET ZTSAVE("JOBN")=""
+53 LOCK -^XTMP(NAMSP)
+54 DO ^%ZTLOAD
+55 if $DATA(ZTSK)
Begin DoDot:1
+56 DO MES^XPDUTL("*** Task #"_ZTSK_" Queued! ***")
+57 DO BMES^XPDUTL("")
End DoDot:1
+58 DO BMES^XPDUTL("")
+59 KILL XPDQUES
+60 QUIT
+61 ;
NAMSP() ;
+1 QUIT $TEXT(+0)
+2 ;
STOP ;stop job command
+1 IF $$ST
SET ^XTMP($$NAMSP,0,"STOP")=""
Begin DoDot:1
+2 WRITE !,"TALLY MISSING EXPIRATION DATES Job - set to STOP Soon"
+3 WRITE !!,"Check Status to be sure it has stopped and is not running..."
+4 WRITE !," (D STATUS^PSOTEXP1)"
End DoDot:1
+5 QUIT
+6 ;
ST() ;status
+1 LOCK +^XTMP($$NAMSP):$G(DILOCKTM,3)
IF $TEST
Begin DoDot:1
+2 LOCK -^XTMP($$NAMSP)
+3 WRITE !,"*** NOT CURRENTLY RUNNING! ***",!
End DoDot:1
QUIT 0
+4 QUIT 1
+5 ;
INITXTMP(NAMSP,TITLE,LIFE) ;create ^Xtmp according to SAC std
+1 NEW BEGDT,PURGDT
+2 SET BEGDT=$$NOW^XLFDT()
+3 SET PURGDT=$$FMADD^XLFDT(BEGDT,LIFE)
+4 IF $GET(^XTMP(NAMSP,0))']""
SET ^XTMP(NAMSP,0)=PURGDT_"^"_BEGDT_"^"_TITLE
+5 QUIT
+6 ;
QUIT ;
+1 LOCK -^XTMP(NAMSP)
+2 QUIT
+3 ;
