DG737PST ;BAY/JAT ;file #45 cleanup
;;5.3;Registration;**737**;Aug 13, 1993;Build 8
Q
; loosely based on PXRMINDD routine released in PX*2*4
CHECK ;Driver for making index date checks & stripping trailing zeros
N GBL,LIST,ROUTINE
W !,"Queue the Clinical Reminders Index date check and update."
S GBL(4)=45
S LIST="4,"
S ROUTINE(45)="CNTPTF^DG737PST"
D TASKIT(LIST,.GBL,.ROUTINE)
Q
;
CNTPTF(FILENUM,NSD) ;Check for string dates for PTF indexes where the
;date is at subscript 7. Works for file numbers:
;45
K ^TMP($J,"SDATE"),^TMP("PXRMXMZ",$J)
N DAS,DATE,DFN,IND,ITEM,NODE,TYPE
I '$D(ZTQUEUED) W !,"Checking file number "_FILENUM
S IND=0
; only procedure codes affected (file 80.1) therefore only
; sub-file 45.01 or 45.05 are involved
F TYPE="ICD0" D
. S DFN=""
. F S DFN=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN)) Q:DFN="" D
.. S IND=IND+1
.. I '$D(ZTQUEUED),(IND#10000=0) W "."
.. S NODE=""
.. F S NODE=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE)) Q:NODE="" D
... S ITEM=""
... F S ITEM=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM)) Q:ITEM="" D
.... S DATE=""
.... F S DATE=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM,DATE)) Q:DATE="" D
..... I +DATE=DATE Q
..... S DAS=""
..... F S DAS=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM,DATE,DAS)) Q:DAS="" D
...... S NSD=NSD+1
...... S ^TMP($J,"SDATE",NSD)="^PXRMINDX("_FILENUM_","_TYPE_",""PNI"","_DFN_","_NODE_","_ITEM_","""_DATE_""","_DAS_")"
...... D UPDATE
Q
;
UPDATE ; strip trailing zeros from date,e.g., 3031005.1340 or 3010816.134050
N DGNEWDT,DGFILE,DGDA,DGIENS,FDA
S DGNEWDT=+DATE
S DGFILE=$P(DAS,";",2)
I DGFILE'="P"&(DGFILE'="S") Q
I DGFILE="P" S DGFILE=45.05
I DGFILE="S" S DGFILE=45.01
; below patterned after UPD^DGENDBS
S DGDA=$P(DAS,";",3)
S DGDA(1)=+DAS
S DGIENS=$$IENS^DILF(.DGDA)
S FDA(DGFILE,DGIENS,.01)=DGNEWDT
D FILE^DIE("K","FDA")
Q
;
;========================================================
MESSAGE(FILENUM,NSD,START,END) ;Build the MailMan message giving the
;list of entries with string dates.
N IND,NAME,NL,TEXT,XMSUB
K ^TMP("PXRMXMZ",$J)
S XMSUB="CR Index string date check for file #"_FILENUM
S NAME=$$GET1^DID(FILENUM,"","","NAME")_", file #"_FILENUM
I NSD=0 S TEXT="No string dates were found for "_NAME_"."
I NSD>0 S TEXT="A total of "_NSD_" string dates were found for "_NAME_"."
S ^TMP("PXRMXMZ",$J,1,0)=TEXT
S ^TMP("PXRMXMZ",$J,2,0)="Check finished at "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
S ^TMP("PXRMXMZ",$J,3,0)=$$ETIME^DG737PST(START,END)
S ^TMP("PXRMXMZ",$J,4,0)=" "
I NSD=0,'$D(^PXRMINDX(FILENUM)) D
. S ^TMP("PXRMXMZ",$J,5,0)="The index for file number "_FILENUM_" does not exist."
. S ^TMP("PXRMXMZ",$J,6,0)=" "
I NSD>0 D
. S ^TMP("PXRMXMZ",$J,5,0)="The following entries with string dates were found:"
. S NL=5
. F IND=1:1:NSD D
.. S NL=NL+1
.. S ^TMP("PXRMXMZ",$J,NL,0)=" "_^TMP($J,"SDATE",IND)
. S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" "
D SEND^DG737PST(XMSUB,DUZ)
;K ^TMP($J,"SDATE"),^TMP("PXRMXMZ",$J)
Q
;
;===============================================================
RUNNOW(LIST,GBL) ;Run the routine now.
N END,FN,IND,LI,NSD,NUM,ROUTINE,RTN,START,TOTAL
K ^TMP($J,"SDATE")
S ROUTINE(45)="CNTPTF^DG737PST"
S NUM=$L(LIST,",")-1
F IND=1:1:NUM D
. S LI=$P(LIST,",",IND)
. S NSD=0
. S FN=GBL(LI)
. S RTN=ROUTINE(FN)
. S RTN=RTN_"("_FN_",.NSD)"
. S START=$H
. I $D(^PXRMINDX(FN)) D @RTN
. S END=$H
. D MESSAGE(FN,NSD,START,END)
Q
;
;===============================================================
TASKIT(LIST,GBL,ROUTINE) ;Check the indexes as a tasked job.
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,MINDT,SDTIME,X,Y
S MINDT=$$NOW^XLFDT
S DIR("A",1)="Enter the date and time you want the job to start."
S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
S DIR("A")="Start the task at: "
S DIR(0)="DAU"_U_MINDT_"::RSX"
D ^DIR
I $D(DIROUT)!$D(DIRUT) Q
I $D(DTOUT)!$D(DUOUT) Q
S SDTIME=Y
K DIR
;Put the task into the queue.
K ZTSAVE
S ZTSAVE("LIST")=""
S ZTSAVE("GBL(")=""
S ZTRTN="TASKJOB^DG737PST"
S ZTDESC="Clinical Reminders Index string date check and update"
S ZTDTH=SDTIME
S ZTIO=""
D ^%ZTLOAD
W !,"Task number ",ZTSK," queued."
Q
;
;===============================================================
TASKJOB ;Execute as tasked job. LIST and GBL come through ZTSAVE.
N IND,LI,NUM
S ZTREQ="@"
S ZTSTOP=0
S NUM=$L(LIST,",")-1
F IND=1:1:NUM D
.;Check to see if the task has had a stop request
. I $$S^%ZTLOAD S ZTSTOP=1,IND=NUM Q
. S LI=$P(LIST,",",IND)_","
. D RUNNOW^DG737PST(LI,.GBL)
Q
;
ETIME(START,END) ;Calculate and format the elapsed time.
;START and END are $H times.
N ETIME,TEXT
S ETIME=$$HDIFF^XLFDT(END,START,2)
I ETIME>90 D
. S ETIME=$$HDIFF^XLFDT(END,START,3)
. S TEXT="Elapsed time: "_ETIME
E S TEXT="Elapsed time: "_ETIME_" secs"
Q TEXT
SEND(XMSUB,USER) ;Send a MailMan message to the user. The text of the message is in
;^TMP("PXRMXMZ",$J,N,0), where there are N lines of text. The subject
;is the string XMSUB.
N MGIEN,MGROUP,NL,REF,XMDUZ,XMY,XMZ
;If this is a test run write out the message.
;I $G(PXRMDEBG) D
;. S REF="^TMP(""PXRMXMZ"",$J)"
;. D AWRITE^PXRMUTIL(REF)
;Make sure the subject does not exceed 64 characters.
S XMSUB=$E(XMSUB,1,64)
;Make the sender the Postmaster.
S XMDUZ=0.5
RETRY ;Get the message number.
D XMZ^XMA2
I XMZ<1 G RETRY
;Load the message
M ^XMB(3.9,XMZ,2)=^TMP("PXRMXMZ",$J)
K ^TMP("PXRMXMZ",$J)
S NL=$O(^XMB(3.9,XMZ,2,""),-1)
S ^XMB(3.9,XMZ,2,0)="^3.92^"_+NL_U_+NL_U_DT
;Send message to requestor if USER is defined
I $G(USER)'="" S XMY(DUZ)="" D ENT1^XMD Q
;Send the message to the site defined mail group or the user if
;there is no mail group.
;S MGIEN=$G(^PXRM(800,1,"MGFE"))
;I MGIEN'="" D
;. S MGROUP="G."_$$GET1^DIQ(3.8,MGIEN,.01)
;. S XMY(MGROUP)=""
;E S XMY(DUZ)=""
;D ENT1^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG737PST 5982 printed Sep 23, 2025@20:16:33 Page 2
DG737PST ;BAY/JAT ;file #45 cleanup
+1 ;;5.3;Registration;**737**;Aug 13, 1993;Build 8
+2 QUIT
+3 ; loosely based on PXRMINDD routine released in PX*2*4
CHECK ;Driver for making index date checks & stripping trailing zeros
+1 NEW GBL,LIST,ROUTINE
+2 WRITE !,"Queue the Clinical Reminders Index date check and update."
+3 SET GBL(4)=45
+4 SET LIST="4,"
+5 SET ROUTINE(45)="CNTPTF^DG737PST"
+6 DO TASKIT(LIST,.GBL,.ROUTINE)
+7 QUIT
+8 ;
CNTPTF(FILENUM,NSD) ;Check for string dates for PTF indexes where the
+1 ;date is at subscript 7. Works for file numbers:
+2 ;45
+3 KILL ^TMP($JOB,"SDATE"),^TMP("PXRMXMZ",$JOB)
+4 NEW DAS,DATE,DFN,IND,ITEM,NODE,TYPE
+5 IF '$DATA(ZTQUEUED)
WRITE !,"Checking file number "_FILENUM
+6 SET IND=0
+7 ; only procedure codes affected (file 80.1) therefore only
+8 ; sub-file 45.01 or 45.05 are involved
+9 FOR TYPE="ICD0"
Begin DoDot:1
+10 SET DFN=""
+11 FOR
SET DFN=$ORDER(^PXRMINDX(FILENUM,TYPE,"PNI",DFN))
if DFN=""
QUIT
Begin DoDot:2
+12 SET IND=IND+1
+13 IF '$DATA(ZTQUEUED)
IF (IND#10000=0)
WRITE "."
+14 SET NODE=""
+15 FOR
SET NODE=$ORDER(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE))
if NODE=""
QUIT
Begin DoDot:3
+16 SET ITEM=""
+17 FOR
SET ITEM=$ORDER(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM))
if ITEM=""
QUIT
Begin DoDot:4
+18 SET DATE=""
+19 FOR
SET DATE=$ORDER(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM,DATE))
if DATE=""
QUIT
Begin DoDot:5
+20 IF +DATE=DATE
QUIT
+21 SET DAS=""
+22 FOR
SET DAS=$ORDER(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM,DATE,DAS))
if DAS=""
QUIT
Begin DoDot:6
+23 SET NSD=NSD+1
+24 SET ^TMP($JOB,"SDATE",NSD)="^PXRMINDX("_FILENUM_","_TYPE_",""PNI"","_DFN_","_NODE_","_ITEM_","""_DATE_""","_DAS_")"
+25 DO UPDATE
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+26 QUIT
+27 ;
UPDATE ; strip trailing zeros from date,e.g., 3031005.1340 or 3010816.134050
+1 NEW DGNEWDT,DGFILE,DGDA,DGIENS,FDA
+2 SET DGNEWDT=+DATE
+3 SET DGFILE=$PIECE(DAS,";",2)
+4 IF DGFILE'="P"&(DGFILE'="S")
QUIT
+5 IF DGFILE="P"
SET DGFILE=45.05
+6 IF DGFILE="S"
SET DGFILE=45.01
+7 ; below patterned after UPD^DGENDBS
+8 SET DGDA=$PIECE(DAS,";",3)
+9 SET DGDA(1)=+DAS
+10 SET DGIENS=$$IENS^DILF(.DGDA)
+11 SET FDA(DGFILE,DGIENS,.01)=DGNEWDT
+12 DO FILE^DIE("K","FDA")
+13 QUIT
+14 ;
+15 ;========================================================
MESSAGE(FILENUM,NSD,START,END) ;Build the MailMan message giving the
+1 ;list of entries with string dates.
+2 NEW IND,NAME,NL,TEXT,XMSUB
+3 KILL ^TMP("PXRMXMZ",$JOB)
+4 SET XMSUB="CR Index string date check for file #"_FILENUM
+5 SET NAME=$$GET1^DID(FILENUM,"","","NAME")_", file #"_FILENUM
+6 IF NSD=0
SET TEXT="No string dates were found for "_NAME_"."
+7 IF NSD>0
SET TEXT="A total of "_NSD_" string dates were found for "_NAME_"."
+8 SET ^TMP("PXRMXMZ",$JOB,1,0)=TEXT
+9 SET ^TMP("PXRMXMZ",$JOB,2,0)="Check finished at "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
+10 SET ^TMP("PXRMXMZ",$JOB,3,0)=$$ETIME^DG737PST(START,END)
+11 SET ^TMP("PXRMXMZ",$JOB,4,0)=" "
+12 IF NSD=0
IF '$DATA(^PXRMINDX(FILENUM))
Begin DoDot:1
+13 SET ^TMP("PXRMXMZ",$JOB,5,0)="The index for file number "_FILENUM_" does not exist."
+14 SET ^TMP("PXRMXMZ",$JOB,6,0)=" "
End DoDot:1
+15 IF NSD>0
Begin DoDot:1
+16 SET ^TMP("PXRMXMZ",$JOB,5,0)="The following entries with string dates were found:"
+17 SET NL=5
+18 FOR IND=1:1:NSD
Begin DoDot:2
+19 SET NL=NL+1
+20 SET ^TMP("PXRMXMZ",$JOB,NL,0)=" "_^TMP($JOB,"SDATE",IND)
End DoDot:2
+21 SET NL=NL+1
SET ^TMP("PXRMXMZ",$JOB,NL,0)=" "
End DoDot:1
+22 DO SEND^DG737PST(XMSUB,DUZ)
+23 ;K ^TMP($J,"SDATE"),^TMP("PXRMXMZ",$J)
+24 QUIT
+25 ;
+26 ;===============================================================
RUNNOW(LIST,GBL) ;Run the routine now.
+1 NEW END,FN,IND,LI,NSD,NUM,ROUTINE,RTN,START,TOTAL
+2 KILL ^TMP($JOB,"SDATE")
+3 SET ROUTINE(45)="CNTPTF^DG737PST"
+4 SET NUM=$LENGTH(LIST,",")-1
+5 FOR IND=1:1:NUM
Begin DoDot:1
+6 SET LI=$PIECE(LIST,",",IND)
+7 SET NSD=0
+8 SET FN=GBL(LI)
+9 SET RTN=ROUTINE(FN)
+10 SET RTN=RTN_"("_FN_",.NSD)"
+11 SET START=$HOROLOG
+12 IF $DATA(^PXRMINDX(FN))
DO @RTN
+13 SET END=$HOROLOG
+14 DO MESSAGE(FN,NSD,START,END)
End DoDot:1
+15 QUIT
+16 ;
+17 ;===============================================================
TASKIT(LIST,GBL,ROUTINE) ;Check the indexes as a tasked job.
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,MINDT,SDTIME,X,Y
+2 SET MINDT=$$NOW^XLFDT
+3 SET DIR("A",1)="Enter the date and time you want the job to start."
+4 SET DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
+5 SET DIR("A")="Start the task at: "
+6 SET DIR(0)="DAU"_U_MINDT_"::RSX"
+7 DO ^DIR
+8 IF $DATA(DIROUT)!$DATA(DIRUT)
QUIT
+9 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+10 SET SDTIME=Y
+11 KILL DIR
+12 ;Put the task into the queue.
+13 KILL ZTSAVE
+14 SET ZTSAVE("LIST")=""
+15 SET ZTSAVE("GBL(")=""
+16 SET ZTRTN="TASKJOB^DG737PST"
+17 SET ZTDESC="Clinical Reminders Index string date check and update"
+18 SET ZTDTH=SDTIME
+19 SET ZTIO=""
+20 DO ^%ZTLOAD
+21 WRITE !,"Task number ",ZTSK," queued."
+22 QUIT
+23 ;
+24 ;===============================================================
TASKJOB ;Execute as tasked job. LIST and GBL come through ZTSAVE.
+1 NEW IND,LI,NUM
+2 SET ZTREQ="@"
+3 SET ZTSTOP=0
+4 SET NUM=$LENGTH(LIST,",")-1
+5 FOR IND=1:1:NUM
Begin DoDot:1
+6 ;Check to see if the task has had a stop request
+7 IF $$S^%ZTLOAD
SET ZTSTOP=1
SET IND=NUM
QUIT
+8 SET LI=$PIECE(LIST,",",IND)_","
+9 DO RUNNOW^DG737PST(LI,.GBL)
End DoDot:1
+10 QUIT
+11 ;
ETIME(START,END) ;Calculate and format the elapsed time.
+1 ;START and END are $H times.
+2 NEW ETIME,TEXT
+3 SET ETIME=$$HDIFF^XLFDT(END,START,2)
+4 IF ETIME>90
Begin DoDot:1
+5 SET ETIME=$$HDIFF^XLFDT(END,START,3)
+6 SET TEXT="Elapsed time: "_ETIME
End DoDot:1
+7 IF '$TEST
SET TEXT="Elapsed time: "_ETIME_" secs"
+8 QUIT TEXT
SEND(XMSUB,USER) ;Send a MailMan message to the user. The text of the message is in
+1 ;^TMP("PXRMXMZ",$J,N,0), where there are N lines of text. The subject
+2 ;is the string XMSUB.
+3 NEW MGIEN,MGROUP,NL,REF,XMDUZ,XMY,XMZ
+4 ;If this is a test run write out the message.
+5 ;I $G(PXRMDEBG) D
+6 ;. S REF="^TMP(""PXRMXMZ"",$J)"
+7 ;. D AWRITE^PXRMUTIL(REF)
+8 ;Make sure the subject does not exceed 64 characters.
+9 SET XMSUB=$EXTRACT(XMSUB,1,64)
+10 ;Make the sender the Postmaster.
+11 SET XMDUZ=0.5
RETRY ;Get the message number.
+1 DO XMZ^XMA2
+2 IF XMZ<1
GOTO RETRY
+3 ;Load the message
+4 MERGE ^XMB(3.9,XMZ,2)=^TMP("PXRMXMZ",$JOB)
+5 KILL ^TMP("PXRMXMZ",$JOB)
+6 SET NL=$ORDER(^XMB(3.9,XMZ,2,""),-1)
+7 SET ^XMB(3.9,XMZ,2,0)="^3.92^"_+NL_U_+NL_U_DT
+8 ;Send message to requestor if USER is defined
+9 IF $GET(USER)'=""
SET XMY(DUZ)=""
DO ENT1^XMD
QUIT
+10 ;Send the message to the site defined mail group or the user if
+11 ;there is no mail group.
+12 ;S MGIEN=$G(^PXRM(800,1,"MGFE"))
+13 ;I MGIEN'="" D
+14 ;. S MGROUP="G."_$$GET1^DIQ(3.8,MGIEN,.01)
+15 ;. S XMY(MGROUP)=""
+16 ;E S XMY(DUZ)=""
+17 ;D ENT1^XMD
+18 QUIT
