- DG737PST ;BAY/JAT ;file #45 cleanup
- ;;5.3;Registration;**737,1015**;Aug 13, 1993;Build 21
- 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
- DG737PST ;BAY/JAT ;file #45 cleanup
- +1 ;;5.3;Registration;**737,1015**;Aug 13, 1993;Build 21
- +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
