DG53355A ;ALB/TM - NON TREATING PREFERRED FACILITY CLEAN UP ; 1/29/01 2:55pm
;;5.3;REGISTRATION;**355**;01/19/01
;
; This process will find all entries in the PATIENT file (#2) that
; have a PREFERRED FACILITY (#27.02) on file that is NOT a valid
; treating facility. The $$TF^XUAF4(IEN) API will be used to
; determine if a PREFERRED FACILITY is a treating facility.
;
; The process reads through all entries in the PATIENT file and
; excludes any entries that have no PREFERRED FACILITY on file.
; Only patient's with a non treating PREFERRED FACILITY will be
; included.
;
; This clean up process will be completed in the steps listed below.
; 1) Compiling the report
; 2) Printing the results
;
; A MailMan message will be sent to the user after the job completes.
; The purge date for the ^XTMP global is set for 30 days after the
; report is processed.
;
GBLDOC ;-----------------------------------------------------------------
; The report uses the ^XTMP("DG53355A") global to store the results.
; The format of the ^XTMP global is described below.
;
; XPFAC = IEN from the INSTITUTION file (#4)
; XIEN = IEN from the PATIENT file (#2)
;
; ^XTMP("DG53355A",0)=P1^P2^...
; P1 = Purge Date
; P2 = Date Processed
; P3 = Description
;
; ^XTMP("DG53355A",0,0)=P1^P2^...
; P1 = Status (0=Uncompiled,1=Compiling,2=Compile Complete)
; P2 = TaskMan Task #
; P3 = Compile Start Date/Time (FM format)
; P4 = Compile Finish Date/Time (FM format)
; P5 = Last IEN viewed from PATIENT file (#2)
; P6 = Last IEN filed in ^XTMP from PATIENT file (#2)
;
; ^XTMP("DG53355A",XPFAC,0)=P1^P2^...
; P1 = Total PATIENT file (#2) records for this NON treating
; Preferred Facility.
;
; ^XTMP("DG53355A",XPFAC,XIEN)=""
;-----------------------------------------------------------------
EP N DIFROM,XSTAT,XNODE,XDESC
;
S XDESC="NON TREATING PREFERRED FACILITY CLEAN UP REPORT"
S XNODE=$G(^XTMP("DG53355A",0,0))
S XSTAT=+$P(XNODE,U)
;
W @IOF ; clearn the screen
W !!," ",XDESC
W !,$$REPEAT^XLFSTR("*",65)
;
I 'XSTAT D Q ;Not compiled
. S X="ERROR^DG53355A" ;Error Trap
. Q:'$$USERDESC ;Display User Description
. D TASK Q:'$G(ZTSK) ;Task job
;
I XSTAT D ASKPRINT Q ;Compiled
Q
;
COMPILE ; Look at all entries in the PATIENT file (#2).
N XCTR,XIEN,XPFAC
;
K ^XTMP("DG53355A") ;Clean up old compile
S $P(XNODE,U)=1 ;Status=compiling
S $P(XNODE,U,2)=$G(ZTSK) ;TaskMan Task #
S $P(XNODE,U,3)=$$NOWDTTM() ;Compile Start Date/Time
S ^XTMP("DG53355A",0,0)=XNODE
;
; set up 0 node of ^XTMP to allow the system to purge after 30 days
S ^XTMP("DG53355A",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_ZTDESC
;
S (XIEN,XCTR,ZTSTOP)=0
F S XIEN=$O(^DPT(XIEN)) Q:XIEN<1 D Q:ZTSTOP
. S $P(^XTMP("DG53355A",0,0),U,5)=XIEN ;last XIEN viewed
. S XCTR=XCTR+1 S:XCTR#1000=0 ZTSTOP=$$S^ZTLOAD("") ;Stop Request
. S XPFAC=$P($G(^DPT(XIEN,"ENR")),U,2) Q:XPFAC=""
. Q:$$TF^XUAF4(XPFAC) ;Quit if valid 'treating' Preferred Facility
. S ^XTMP("DG53355A",XPFAC,0)=$G(^XTMP("DG53355A",XPFAC,0))+1
. S ^XTMP("DG53355A",XPFAC,XIEN)=""
. S $P(^XTMP("DG53355A",0,0),U,6)=XIEN ;last XIEN filed in ^XTMP
;
S $P(^XTMP("DG53355A",0,0),U,4)=$$NOWDTTM() ;Compile Stop Date/Time
S:'ZTSTOP $P(^XTMP("DG53355A",0,0),U)=2 ;Set status = compiled
;
D SNDMSG(ZTSTOP)
S ZTREQ="@" ; remove job from TaskMan task log
;
; return to default error trap
S X="" S:$G(ZTSK)'="" X=^%ZOSF("ERRTN")
S @^%ZOSF("TRAP")
Q
;
ASKPRINT ; Prompt user to print detail report.
N DIR,DTOUT,DUOUT,DIRUT,DIROUT
W !!,"Compile Start Date/Time: ",$$FMTE^XLFDT($P(XNODE,U,3))
I XSTAT=1 D Q
. W !!,"Report is currently compiling!"
. W !,"A MailMan message will be sent when the compile is complete."
. W !
W !," Compile Stop Date/Time: ",$$FMTE^XLFDT($P(XNODE,U,4))
W !
;
S DIR(0)="Y",DIR("A")="Print Detail Report",DIR("B")="YES"
D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)!'Y Q
;
; Prompt user for device and to task job to TaskMan.
W ! D EN^XUTMDEVQ("PRINT^DG53355A(ZTDESC)",XDESC)
I $G(ZTQUEUED) W !!,"TaskMan Task: ",$G(ZTSK)
Q
;
PRINT(XDESC) ; Print detail report.
N XPFAC,XIEN,XNODE,XLNCNT,XPGNUM
S XPGNUM=0
D PRNHEAD
;
I $D(^XTMP("DG53355A")) D
. S XPFAC=0 F S XPFAC=$O(^XTMP("DG53355A",XPFAC)) Q:XPFAC="" D
. . S XIEN=0 F S XIEN=$O(^XTMP("DG53355A",XPFAC,XIEN)) Q:XIEN="" D
. . . S XNODE=$G(^DPT(XIEN,0))
. . . W !,$P(XNODE,U,9)
. . . W ?15,$E($P(XNODE,U),1,30)
. . . W ?47,$E((XPFAC_" ("_$P($G(^DIC(4,XPFAC,0)),U)),1,30)_")"
. . . S XLNCNT=XLNCNT+1 D:XLNCNT=62 PRNHEAD
W !!,"*** END OF REPORT ***"
S ZTREQ="@" ; remove job from TaskMan task log
Q
;
SNDMSG(STAT) ; send MailMan message
N MSGDTM,QUIT,XLN,XMDUZ,XMSUB,XMTEXT,XMY,XTXT
;
S STAT=+$G(STAT)
S MSGDTM=$$HTE^XLFDT($H) ;Current Date/Time
S XMTEXT="^TMP(""DG53355A"",$J,"
S XMSUB="Patch DG*5.3*355 ("_ZTDESC_")"
S XMDUZ=.5 ;indicate PostMaster is the sender
S XMY(DUZ)="" ;Send message to user starting job
;
K ^TMP("DG53355A",$J)
D MSGADD(XMSUB)
D MSGADD("")
D MSGADD($S(STAT=-1:"Errored",STAT=1:"Stopped",1:"Finished")_" @ "_MSGDTM)
I STAT>-1 D
. D MSGADD("")
. D MSGADD("The compile process has completed. The detail report ")
. D MSGADD("can be viewed by returning to the original menu option.")
. D MSGADD("After 30 days the compiled data will be purged and the ")
. D MSGADD("report will have to be recompiled.")
. D MSGADD("")
. D MSGADD("Number of records for each non-treating Preferred Facility:")
. D MSGADD("")
. I $O(^XTMP("DG53355A",0))="" D MSGADD(" No Entries Found")
. S XPFAC=0 F S XPFAC=$O(^XTMP("DG53355A",XPFAC)) Q:XPFAC="" D
. . D MSGADD(" "_$P($G(^DIC(4,XPFAC,0)),U)_": "_+$G(^XTMP("DG53355A",XPFAC,0)))
D MSGADD("")
D MSGADD("*** End ***")
D ^XMD ;send Mailman message
K ^TMP("DG53355A",$J)
Q
;
MSGADD(XLINE) N MSGLINE
S MSGLINE=$O(^TMP("DG53355A",$J,""),-1)+1
S ^TMP("DG53355A",$J,MSGLINE)=$G(XLINE)
Q
;
TASK ;Task job using TaskMan
N ZTDESC,ZTIO,ZTRTN
S ZTIO="",ZTRTN="COMPILE^DG53355A",ZTDESC=XDESC
W ! D ^%ZTLOAD
W:$G(ZTSK) !!,"TaskMan Task: ",$G(ZTSK)
Q
;
NOWDTTM() N %,%H,%I,X D NOW^%DTC Q %
;
PRNHEAD ; Print report heading
N X
S XLNCNT=8,XPGNUM=XPGNUM+1
W @IOF,!!!,?(80-$L(XDESC)/2),XDESC
W !!,"Run Date: ",$$HTE^XLFDT($H),?68,"Page: ",XPGNUM
W !!,"Veteran SSN",?15,"Veteran Name"
W ?47,"Current Preferred Facility"
W !,"===========",?15,"============"
W ?47,"=========================="
Q
;
ERROR ; Record error and send MailMan message
N X S X=""
D SNDMSG(-1)
S:$G(ZTSK)'="" X=^%ZOSF("ERRTN")
S @^%ZOSF("TRAP")
D ^%ZTER ;call Kernel error trap
Q
;
USERDESC() ;Write description to the screen for the user
W !!,"This process will find all patients that have a non-treating"
W !,"Preferred Facility on file. All identified patients will need"
W !,"to have their Preferred Facility changed to a valid treating"
W !,"facility.",!
W !,"The clean up process will perform the following steps in order:"
W !," 1) Compile the patient data. (This step looks at "
W !," every patient in the PATIENT (#2) file.) A summary"
W !," MailMan message will be sent to the user when the"
W !," compile is complete."
W !," 2) The user will need to return to this option to print"
W !," the detail report within 30 days to avoid recompiling."
W !," NOTE: The system will purge the compiled data after 30"
W !," days!"
W !!,"All compiled data will be stored in the ^XTMP(""DG53355A"") "
W "global.",!
;
K DIR S DIR(0)="Y",DIR("A")="Do you want to continue",DIR("B")="NO"
D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)!'Y Q 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53355A 8117 printed Sep 23, 2025@20:13:05 Page 2
DG53355A ;ALB/TM - NON TREATING PREFERRED FACILITY CLEAN UP ; 1/29/01 2:55pm
+1 ;;5.3;REGISTRATION;**355**;01/19/01
+2 ;
+3 ; This process will find all entries in the PATIENT file (#2) that
+4 ; have a PREFERRED FACILITY (#27.02) on file that is NOT a valid
+5 ; treating facility. The $$TF^XUAF4(IEN) API will be used to
+6 ; determine if a PREFERRED FACILITY is a treating facility.
+7 ;
+8 ; The process reads through all entries in the PATIENT file and
+9 ; excludes any entries that have no PREFERRED FACILITY on file.
+10 ; Only patient's with a non treating PREFERRED FACILITY will be
+11 ; included.
+12 ;
+13 ; This clean up process will be completed in the steps listed below.
+14 ; 1) Compiling the report
+15 ; 2) Printing the results
+16 ;
+17 ; A MailMan message will be sent to the user after the job completes.
+18 ; The purge date for the ^XTMP global is set for 30 days after the
+19 ; report is processed.
+20 ;
GBLDOC ;-----------------------------------------------------------------
+1 ; The report uses the ^XTMP("DG53355A") global to store the results.
+2 ; The format of the ^XTMP global is described below.
+3 ;
+4 ; XPFAC = IEN from the INSTITUTION file (#4)
+5 ; XIEN = IEN from the PATIENT file (#2)
+6 ;
+7 ; ^XTMP("DG53355A",0)=P1^P2^...
+8 ; P1 = Purge Date
+9 ; P2 = Date Processed
+10 ; P3 = Description
+11 ;
+12 ; ^XTMP("DG53355A",0,0)=P1^P2^...
+13 ; P1 = Status (0=Uncompiled,1=Compiling,2=Compile Complete)
+14 ; P2 = TaskMan Task #
+15 ; P3 = Compile Start Date/Time (FM format)
+16 ; P4 = Compile Finish Date/Time (FM format)
+17 ; P5 = Last IEN viewed from PATIENT file (#2)
+18 ; P6 = Last IEN filed in ^XTMP from PATIENT file (#2)
+19 ;
+20 ; ^XTMP("DG53355A",XPFAC,0)=P1^P2^...
+21 ; P1 = Total PATIENT file (#2) records for this NON treating
+22 ; Preferred Facility.
+23 ;
+24 ; ^XTMP("DG53355A",XPFAC,XIEN)=""
+25 ;-----------------------------------------------------------------
EP NEW DIFROM,XSTAT,XNODE,XDESC
+1 ;
+2 SET XDESC="NON TREATING PREFERRED FACILITY CLEAN UP REPORT"
+3 SET XNODE=$GET(^XTMP("DG53355A",0,0))
+4 SET XSTAT=+$PIECE(XNODE,U)
+5 ;
+6 ; clearn the screen
WRITE @IOF
+7 WRITE !!," ",XDESC
+8 WRITE !,$$REPEAT^XLFSTR("*",65)
+9 ;
+10 ;Not compiled
IF 'XSTAT
Begin DoDot:1
+11 ;Error Trap
SET X="ERROR^DG53355A"
+12 ;Display User Description
if '$$USERDESC
QUIT
+13 ;Task job
DO TASK
if '$GET(ZTSK)
QUIT
End DoDot:1
QUIT
+14 ;
+15 ;Compiled
IF XSTAT
DO ASKPRINT
QUIT
+16 QUIT
+17 ;
COMPILE ; Look at all entries in the PATIENT file (#2).
+1 NEW XCTR,XIEN,XPFAC
+2 ;
+3 ;Clean up old compile
KILL ^XTMP("DG53355A")
+4 ;Status=compiling
SET $PIECE(XNODE,U)=1
+5 ;TaskMan Task #
SET $PIECE(XNODE,U,2)=$GET(ZTSK)
+6 ;Compile Start Date/Time
SET $PIECE(XNODE,U,3)=$$NOWDTTM()
+7 SET ^XTMP("DG53355A",0,0)=XNODE
+8 ;
+9 ; set up 0 node of ^XTMP to allow the system to purge after 30 days
+10 SET ^XTMP("DG53355A",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_ZTDESC
+11 ;
+12 SET (XIEN,XCTR,ZTSTOP)=0
+13 FOR
SET XIEN=$ORDER(^DPT(XIEN))
if XIEN<1
QUIT
Begin DoDot:1
+14 ;last XIEN viewed
SET $PIECE(^XTMP("DG53355A",0,0),U,5)=XIEN
+15 ;Stop Request
SET XCTR=XCTR+1
if XCTR#1000=0
SET ZTSTOP=$$S^ZTLOAD("")
+16 SET XPFAC=$PIECE($GET(^DPT(XIEN,"ENR")),U,2)
if XPFAC=""
QUIT
+17 ;Quit if valid 'treating' Preferred Facility
if $$TF^XUAF4(XPFAC)
QUIT
+18 SET ^XTMP("DG53355A",XPFAC,0)=$GET(^XTMP("DG53355A",XPFAC,0))+1
+19 SET ^XTMP("DG53355A",XPFAC,XIEN)=""
+20 ;last XIEN filed in ^XTMP
SET $PIECE(^XTMP("DG53355A",0,0),U,6)=XIEN
End DoDot:1
if ZTSTOP
QUIT
+21 ;
+22 ;Compile Stop Date/Time
SET $PIECE(^XTMP("DG53355A",0,0),U,4)=$$NOWDTTM()
+23 ;Set status = compiled
if 'ZTSTOP
SET $PIECE(^XTMP("DG53355A",0,0),U)=2
+24 ;
+25 DO SNDMSG(ZTSTOP)
+26 ; remove job from TaskMan task log
SET ZTREQ="@"
+27 ;
+28 ; return to default error trap
+29 SET X=""
if $GET(ZTSK)'=""
SET X=^%ZOSF("ERRTN")
+30 SET @^%ZOSF("TRAP")
+31 QUIT
+32 ;
ASKPRINT ; Prompt user to print detail report.
+1 NEW DIR,DTOUT,DUOUT,DIRUT,DIROUT
+2 WRITE !!,"Compile Start Date/Time: ",$$FMTE^XLFDT($PIECE(XNODE,U,3))
+3 IF XSTAT=1
Begin DoDot:1
+4 WRITE !!,"Report is currently compiling!"
+5 WRITE !,"A MailMan message will be sent when the compile is complete."
+6 WRITE !
End DoDot:1
QUIT
+7 WRITE !," Compile Stop Date/Time: ",$$FMTE^XLFDT($PIECE(XNODE,U,4))
+8 WRITE !
+9 ;
+10 SET DIR(0)="Y"
SET DIR("A")="Print Detail Report"
SET DIR("B")="YES"
+11 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)!'Y
QUIT
+12 ;
+13 ; Prompt user for device and to task job to TaskMan.
+14 WRITE !
DO EN^XUTMDEVQ("PRINT^DG53355A(ZTDESC)",XDESC)
+15 IF $GET(ZTQUEUED)
WRITE !!,"TaskMan Task: ",$GET(ZTSK)
+16 QUIT
+17 ;
PRINT(XDESC) ; Print detail report.
+1 NEW XPFAC,XIEN,XNODE,XLNCNT,XPGNUM
+2 SET XPGNUM=0
+3 DO PRNHEAD
+4 ;
+5 IF $DATA(^XTMP("DG53355A"))
Begin DoDot:1
+6 SET XPFAC=0
FOR
SET XPFAC=$ORDER(^XTMP("DG53355A",XPFAC))
if XPFAC=""
QUIT
Begin DoDot:2
+7 SET XIEN=0
FOR
SET XIEN=$ORDER(^XTMP("DG53355A",XPFAC,XIEN))
if XIEN=""
QUIT
Begin DoDot:3
+8 SET XNODE=$GET(^DPT(XIEN,0))
+9 WRITE !,$PIECE(XNODE,U,9)
+10 WRITE ?15,$EXTRACT($PIECE(XNODE,U),1,30)
+11 WRITE ?47,$EXTRACT((XPFAC_" ("_$PIECE($GET(^DIC(4,XPFAC,0)),U)),1,30)_")"
+12 SET XLNCNT=XLNCNT+1
if XLNCNT=62
DO PRNHEAD
End DoDot:3
End DoDot:2
End DoDot:1
+13 WRITE !!,"*** END OF REPORT ***"
+14 ; remove job from TaskMan task log
SET ZTREQ="@"
+15 QUIT
+16 ;
SNDMSG(STAT) ; send MailMan message
+1 NEW MSGDTM,QUIT,XLN,XMDUZ,XMSUB,XMTEXT,XMY,XTXT
+2 ;
+3 SET STAT=+$GET(STAT)
+4 ;Current Date/Time
SET MSGDTM=$$HTE^XLFDT($HOROLOG)
+5 SET XMTEXT="^TMP(""DG53355A"",$J,"
+6 SET XMSUB="Patch DG*5.3*355 ("_ZTDESC_")"
+7 ;indicate PostMaster is the sender
SET XMDUZ=.5
+8 ;Send message to user starting job
SET XMY(DUZ)=""
+9 ;
+10 KILL ^TMP("DG53355A",$JOB)
+11 DO MSGADD(XMSUB)
+12 DO MSGADD("")
+13 DO MSGADD($SELECT(STAT=-1:"Errored",STAT=1:"Stopped",1:"Finished")_" @ "_MSGDTM)
+14 IF STAT>-1
Begin DoDot:1
+15 DO MSGADD("")
+16 DO MSGADD("The compile process has completed. The detail report ")
+17 DO MSGADD("can be viewed by returning to the original menu option.")
+18 DO MSGADD("After 30 days the compiled data will be purged and the ")
+19 DO MSGADD("report will have to be recompiled.")
+20 DO MSGADD("")
+21 DO MSGADD("Number of records for each non-treating Preferred Facility:")
+22 DO MSGADD("")
+23 IF $ORDER(^XTMP("DG53355A",0))=""
DO MSGADD(" No Entries Found")
+24 SET XPFAC=0
FOR
SET XPFAC=$ORDER(^XTMP("DG53355A",XPFAC))
if XPFAC=""
QUIT
Begin DoDot:2
+25 DO MSGADD(" "_$PIECE($GET(^DIC(4,XPFAC,0)),U)_": "_+$GET(^XTMP("DG53355A",XPFAC,0)))
End DoDot:2
End DoDot:1
+26 DO MSGADD("")
+27 DO MSGADD("*** End ***")
+28 ;send Mailman message
DO ^XMD
+29 KILL ^TMP("DG53355A",$JOB)
+30 QUIT
+31 ;
MSGADD(XLINE) NEW MSGLINE
+1 SET MSGLINE=$ORDER(^TMP("DG53355A",$JOB,""),-1)+1
+2 SET ^TMP("DG53355A",$JOB,MSGLINE)=$GET(XLINE)
+3 QUIT
+4 ;
TASK ;Task job using TaskMan
+1 NEW ZTDESC,ZTIO,ZTRTN
+2 SET ZTIO=""
SET ZTRTN="COMPILE^DG53355A"
SET ZTDESC=XDESC
+3 WRITE !
DO ^%ZTLOAD
+4 if $GET(ZTSK)
WRITE !!,"TaskMan Task: ",$GET(ZTSK)
+5 QUIT
+6 ;
NOWDTTM() NEW %,%H,%I,X
DO NOW^%DTC
QUIT %
+1 ;
PRNHEAD ; Print report heading
+1 NEW X
+2 SET XLNCNT=8
SET XPGNUM=XPGNUM+1
+3 WRITE @IOF,!!!,?(80-$LENGTH(XDESC)/2),XDESC
+4 WRITE !!,"Run Date: ",$$HTE^XLFDT($HOROLOG),?68,"Page: ",XPGNUM
+5 WRITE !!,"Veteran SSN",?15,"Veteran Name"
+6 WRITE ?47,"Current Preferred Facility"
+7 WRITE !,"===========",?15,"============"
+8 WRITE ?47,"=========================="
+9 QUIT
+10 ;
ERROR ; Record error and send MailMan message
+1 NEW X
SET X=""
+2 DO SNDMSG(-1)
+3 if $GET(ZTSK)'=""
SET X=^%ZOSF("ERRTN")
+4 SET @^%ZOSF("TRAP")
+5 ;call Kernel error trap
DO ^%ZTER
+6 QUIT
+7 ;
USERDESC() ;Write description to the screen for the user
+1 WRITE !!,"This process will find all patients that have a non-treating"
+2 WRITE !,"Preferred Facility on file. All identified patients will need"
+3 WRITE !,"to have their Preferred Facility changed to a valid treating"
+4 WRITE !,"facility.",!
+5 WRITE !,"The clean up process will perform the following steps in order:"
+6 WRITE !," 1) Compile the patient data. (This step looks at "
+7 WRITE !," every patient in the PATIENT (#2) file.) A summary"
+8 WRITE !," MailMan message will be sent to the user when the"
+9 WRITE !," compile is complete."
+10 WRITE !," 2) The user will need to return to this option to print"
+11 WRITE !," the detail report within 30 days to avoid recompiling."
+12 WRITE !," NOTE: The system will purge the compiled data after 30"
+13 WRITE !," days!"
+14 WRITE !!,"All compiled data will be stored in the ^XTMP(""DG53355A"") "
+15 WRITE "global.",!
+16 ;
+17 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Do you want to continue"
SET DIR("B")="NO"
+18 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)!'Y
QUIT 0
+19 QUIT 1
