PRCHLO5 ;WOIFO/DAP/RLL-manual run for procurement reports ; 10/16/06 2:12pm
V ;;5.1;IFCAP;**83,98,139,172**;Oct 20, 2000;Build 2
;Per VHA Directive 2004-038, this routine should not be modified.
;
;Patch PRC*5.1*172 are modifications to CLRS transmission processing
;to support those sites that have migrated to Full LINUX OS
;
ENT ;This routine tasks out the execution of the procurement extract
;reports associated with PRC*5.1*83 (CLRS).
;
N ZTRTN,ZTDESC,ZTDTH,ZTIO,PRCHPRO,ZTSK,ZTREQ,PRCPMSG
S ZTRTN="RUNEXT^PRCHLO5"
S ZTDESC="PRCPLO CLO Procurement Reports CLRS"
S ZTDTH=$H
S ZTREQ="@"
S ZTIO=""
D ^%ZTLOAD
S PRCHPRO=ZTSK
;Calls mail group message generation and screen display with success
;or exception notification
I $D(PRCHPRO)[0 S PRCPMSG(1)="A task could not be created for the CLO Procurement Reports - please contact IRM." W ! D EN^DDIOL(PRCPMSG(1)) D MAIL^PRCHLO4A Q
;
S PRCPMSG(1)="Task # "_PRCHPRO_" entered for Procurement Reports."
W !
D EN^DDIOL(PRCPMSG(1))
;
;*98 Modified to move MAIL and MAILFTP tags to routine PRCHLO4A
;
D MAIL^PRCHLO4A
;
Q
PRCPCMP ; Notification of completion of building Procurement Report Data
N PRCPMSG
S PRCPMSG(1)="PO Procurement Data extract complete."
D EN^DDIOL(PRCPMSG(1))
D MAIL^PRCHLO4A
Q
;
PRCPTST ; Notification of termination of building Procurement Report Data due to test system task origin (added in PRC*5.1*139)
N PRCPMSG
S PRCPMSG(1)="PO Procurement Data extract TERMINATED due to running on TEST system."
D EN^DDIOL(PRCPMSG(1))
D MAIL^PRCHLO4A
K ^TMP($J),^TMP("PRCHLOG",$J)
Q
;
RUNEXT ; Run extract reports for PO Activity
I '$$PROD^XUPROD() G PRCPTST ;Check added in patch PRC*139 to not execute on test systems
N CLRSERR,CLRSTST1 ; error flag for exception handling,tst entry pt.
; CLRSERR will be set for the following conditions:
; 0 - Success, status message for completion is sent.
; 1 - Error creating ^TMP($J) data (i.e. disk full)
; 2 - Error creating Files(i.e. directory patch, VMS Space, etc.)
; 3 - Error creating .Com file for FTP transfer, permissions issue
; 4 - Error with FTP Transfer,ntwk/permissions, Report Server issue
; 5 - Error with file deletion/cleanup prior to processing
; 6 - Error, lock is present. Process already running
S CLRSERR=0
TSTMSG ; This entry point is used to test the messaging framework
; S SLRSTST1=1
S CLRSERR=0
; Check for O/S version
N CKOS
S CKOS=$$OS^%ZOSV()
; use lock to prevent mult. runs
L +^PRCP(446.7,"STATUS"):3 I $T=0 S CLRSERR=6
I CLRSERR=0 D DELRUN^PRCHLO5
I CLRSERR=5 D
. N PRCPMSG
. S PRCPMSG(1)="Error with file deletion/cleanup prior to processing. Please contact IRM."
. S PRCPMSG(2)=" "
. S PRCPMSG(3)="This error indicates the CLRS EXTRACT DIRECTORY has not"
. S PRCPMSG(4)="been properly set up during the installation of this patch."
. S PRCPMSG(5)=" "
. S PRCPMSG(6)="(Please refer to the pre installation instructions for PRC*5.1*83)"
. S PRCPMSG(7)=" "
. S PRCPMSG(8)="A valid directory must be set up with the"
. S PRCPMSG(9)="proper read/write/execute/delete privileges."
. S PRCPMSG(10)=" "
. S PRCPMSG(11)="In addition, the directory name which you create"
. S PRCPMSG(12)="must be added as the CLRS EXTRACT DIRECTORY"
. S PRCPMSG(13)="through the CLO System Parameters Option."
. S PRCPMSG(14)="If the field is blank, you will generate this error."
. S PRCPMSG(15)=" "
. S PRCPMSG(16)="Please confirm all steps have been performed"
. S PRCPMSG(17)="according to the pre installation instructions for patch PRC*5.1*83."
. D MAILFTP^PRCHLO4A
. Q
; Begin to build files
I CLRSERR=0 D INIT^PRCHLO
I CLRSERR=0 D PRCPCMP^PRCHLO5 ; PO activity Extract logic completed
I $D(CLRSTST1) D ; test point to generate message 1
. Q:CLRSTST1'=1
. S CLRSERR=1
. Q
I CLRSERR=1 D
. N PRCPMSG ; error building ^TMP($J)
. S PRCPMSG(1)="Error, No Data for PO Activity Files, contact IRM"
. D MAILFTP^PRCHLO4A
. Q
CRFILE ; Create .txt file to confirm write privileges to directory
I CLRSERR=0 D TSTF^PRCHLO4 ; will return CLRSERR=2 on error
I CLRSERR=0 D CLRSFIL^PRCHLO4
I CLRSERR=2 D
. N PRCPMSG
. S PRCPMSG(1)="Error, Problem with FTP File Creation, contact IRM"
. D MAILFTP^PRCHLO4A
. Q
I CLRSERR=0 D
. N PRCPMSG
. S PRCPMSG(1)="Built PO Activity Extracts and GIP Extracts for transfer"
. D MAILFTP^PRCHLO4A
. Q
I CKOS["VMS" D
. I CLRSERR=0 D CRTCOM^PRCHLO4
. Q
I CKOS["NT" D
. I CLRSERR=0 D CRTWIN^PRCHLO4A
. Q
;PRC*5.1*172 added check for Full Linux
I CKOS["UNIX" D
. I CLRSERR=0 D
. . D CRTUNX1^PRCHLO4
. . Q
. Q
I CLRSERR=6 D
. N PRCPMSG
. S PRCPMSG(1)="Error encountered when attempting to run CLO PO"
. S PRCPMSG(2)="activity reports due to other CLRS extracts in"
. S PRCPMSG(3)="progress. Please try again later."
. D MAILFTP^PRCHLO4A
. Q
I $D(CLRSTST1) D ; test point to generate message 3
. Q:CLRSTST1'=3
. S CLRSERR=3
. Q
I CLRSERR=0 D CKRPTSV^PRCHLO4A ;ping report server for availability
I CLRSERR=3 D
. N PRCPMSG
. S PRCPMSG(1)="Error, problem creating SETUP file for FTP Transfer, contact IRM."
. S PRCPMSG(2)="The Report Server may be unavailable for processing."
. D MAILFTP^PRCHLO4A
. Q
I CLRSERR=0 D
. N PRCPMSG,FILEDIR
. S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
. S PRCPMSG(1)="Final FTP Setup complete, beginning FTP Transfer"
. S PRCPMSG(2)=" "
. S PRCPMSG(3)="The file transfer to the report server has been initiated."
. S PRCPMSG(4)="You will be receiving a notification that the FTP"
. S PRCPMSG(5)="process has completed. The notification message"
. S PRCPMSG(6)="should be received within the hour. If you do not"
. S PRCPMSG(7)="receive the FTP process has completed message,"
. S PRCPMSG(8)="please contact IRM. IRM can confirm the process"
. S PRCPMSG(9)="is still running by performing the following"
. S PRCPMSG(10)="command:"
. S PRCPMSG(11)=" "
. S PRCPMSG(12)="At the MUMPS Programmer prompt, type D ^%SS"
. S PRCPMSG(13)=" "
. S PRCPMSG(14)="See if there are any PRCHLO* routines running."
. S PRCPMSG(15)=" "
. S PRCPMSG(16)="If these routines are present, the process is still"
. S PRCPMSG(17)="running. If you waited one hour, and did not get the"
. S PRCPMSG(18)="FTP process has completed message, a problem"
. S PRCPMSG(19)="was encountered. Further troubleshooting can be"
. S PRCPMSG(20)="performed by examining the LOGFILE CLRSxxxFTP1.LOG"
. S PRCPMSG(21)="where xxx is your station ID#. The logfile is"
. S PRCPMSG(22)="located in the following directory: "_FILEDIR
. S PRCPMSG(23)=" "
. D MAILFTP^PRCHLO4A
. Q
I CKOS["VMS" D
. I CLRSERR=0 D
. . D CRTCOM1^PRCHLO4
. . D FTPCOM^PRCHLO4
. . Q
. Q
;PRC*5.1*172 added check for Full Linux
I CKOS["UNIX" D
. I CLRSERR=0 D
. . D UNXFTP^PRCHLO4
. . Q
. Q
I CKOS["NT" D
. I CLRSERR=0 D
. . D CRTWIN^PRCHLO4A
. . D FTPCOM^PRCHLO4A
. . Q
. Q
; release the lock
L -^PRCP(446.7,"STATUS")
I CLRSERR=4 D
. N PRCPMSG,FILEDIR
. S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
. S PRCPMSG(1)="An Error occurred during the FTP Transfer "_$$HTE^XLFDT($H)
. S PRCPMSG(2)="Contact IRM to perform troubleshooting steps"
. S PRCPMSG(3)="by examining the logfile CLRSxxxFTP1.LOG where"
. S PRCPMSG(4)="xxx is your station number. The logfile is located"
. S PRCPMSG(5)="the FTP directory "_FILEDIR
. S PRCPMSG(6)=" "
. D MAILFTP^PRCHLO4A
. Q
I CLRSERR=0 D
. N PRCPMSG,FILEDIR
. S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
. S PRCPMSG(1)="The FTP Transfer process completed, "_$$HTE^XLFDT($H)
. S PRCPMSG(2)=" "
. S PRCPMSG(3)="The Clinical Logistics 0ffice should examine the Report Server"
. S PRCPMSG(4)="FTP directory for your files. If the files from your"
. S PRCPMSG(5)="station are not found, IRM can provide additional"
. S PRCPMSG(6)="troubleshooting steps by examining the LOGFILE"
. S PRCPMSG(7)="CLRSxxxFTP1.LOG where xxx is your station number."
. S PRCPMSG(8)="The logfile is located in the directory: "_FILEDIR
. S PRCPMSG(9)=" "
. S PRCPMSG(10)="The contents of the logfile are listed below:"
. D LOG2FILE^PRCHLO4A
. Q
; CLEAN UP
K ^TMP($J)
K ^TMP("PRCHLOG",$J)
Q
DELRUN ; delete previous run at the beginning of the program
;
N FILCK,FILDEL,TFILE1,TFILE2,OUTFL1,OUTFL2,POP,STID
; create, delete, then create files to clean up and confirm
; write / delete privileges to directory
S POP=""
S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
S OUTFL1="CLRS"_STID_"TST.TXT"
S OUTFL2="IFCP"_STID_"TST.TXT"
S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
I FILEDIR="" D
. S CLRSERR=5
. Q
I FILEDIR=" " D
. S CLRSERR=5
. Q
I CLRSERR=0 D OPEN^%ZISH("TFILE1",FILEDIR,OUTFL1,"W")
I POP D
. S CLRSERR=5
. Q
I CLRSERR=0 D
. D USE^%ZISUTL("TFILE1")
. W !,"$ ! This is a test file to confirm write/delete access"
. W !,"$ ! once file access is confirmed, file is deleted"
. W !,"$ EXIT"
. D CLOSE^%ZISH("TFILE1")
. D OPEN^%ZISH("TFILE2",FILEDIR,OUTFL2,"W")
. D USE^%ZISUTL("TFILE2")
. W !,"$ ! This is a test file to confirm write/delete access"
. W !,"$ ! once file access is confirmed, file is deleted"
. W !,"$ EXIT"
. D CLOSE^%ZISH("TFILE2")
. Q
;
DELWIN ; DELETE windows files, need to handle 1 file at a time
; SACC Exception received for usage of $ZF(-1) in PRC*5.1*83
; See IFCAP technical manual.
I CKOS["NT" D DELWIN^PRCHLO4A
DELFILS ; Delete the files / clean-up before processing
;
; SACC Exception received for usage of $ZF(-1) in PRC*5.1*83
; See IFCAP technical manual
I CKOS["VMS" D ;O/S IS VMS
. Q:CLRSERR'="0"
. N PV,PV1,XPV,XPV1
. S XPV="S PV=$ZF(-1,""DELETE "_FILEDIR_"*"_STID_"*.*;*"")"
. X XPV
. Q
;PRC*5.1*172 added check for Full Linux
I CKOS["UNIX" D
. D DELUNX^PRCHLO4A
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHLO5 10040 printed Dec 13, 2024@02:08:34 Page 2
PRCHLO5 ;WOIFO/DAP/RLL-manual run for procurement reports ; 10/16/06 2:12pm
V ;;5.1;IFCAP;**83,98,139,172**;Oct 20, 2000;Build 2
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;
+3 ;Patch PRC*5.1*172 are modifications to CLRS transmission processing
+4 ;to support those sites that have migrated to Full LINUX OS
+5 ;
ENT ;This routine tasks out the execution of the procurement extract
+1 ;reports associated with PRC*5.1*83 (CLRS).
+2 ;
+3 NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,PRCHPRO,ZTSK,ZTREQ,PRCPMSG
+4 SET ZTRTN="RUNEXT^PRCHLO5"
+5 SET ZTDESC="PRCPLO CLO Procurement Reports CLRS"
+6 SET ZTDTH=$HOROLOG
+7 SET ZTREQ="@"
+8 SET ZTIO=""
+9 DO ^%ZTLOAD
+10 SET PRCHPRO=ZTSK
+11 ;Calls mail group message generation and screen display with success
+12 ;or exception notification
+13 IF $DATA(PRCHPRO)[0
SET PRCPMSG(1)="A task could not be created for the CLO Procurement Reports - please contact IRM."
WRITE !
DO EN^DDIOL(PRCPMSG(1))
DO MAIL^PRCHLO4A
QUIT
+14 ;
+15 SET PRCPMSG(1)="Task # "_PRCHPRO_" entered for Procurement Reports."
+16 WRITE !
+17 DO EN^DDIOL(PRCPMSG(1))
+18 ;
+19 ;*98 Modified to move MAIL and MAILFTP tags to routine PRCHLO4A
+20 ;
+21 DO MAIL^PRCHLO4A
+22 ;
+23 QUIT
PRCPCMP ; Notification of completion of building Procurement Report Data
+1 NEW PRCPMSG
+2 SET PRCPMSG(1)="PO Procurement Data extract complete."
+3 DO EN^DDIOL(PRCPMSG(1))
+4 DO MAIL^PRCHLO4A
+5 QUIT
+6 ;
PRCPTST ; Notification of termination of building Procurement Report Data due to test system task origin (added in PRC*5.1*139)
+1 NEW PRCPMSG
+2 SET PRCPMSG(1)="PO Procurement Data extract TERMINATED due to running on TEST system."
+3 DO EN^DDIOL(PRCPMSG(1))
+4 DO MAIL^PRCHLO4A
+5 KILL ^TMP($JOB),^TMP("PRCHLOG",$JOB)
+6 QUIT
+7 ;
RUNEXT ; Run extract reports for PO Activity
+1 ;Check added in patch PRC*139 to not execute on test systems
IF '$$PROD^XUPROD()
GOTO PRCPTST
+2 ; error flag for exception handling,tst entry pt.
NEW CLRSERR,CLRSTST1
+3 ; CLRSERR will be set for the following conditions:
+4 ; 0 - Success, status message for completion is sent.
+5 ; 1 - Error creating ^TMP($J) data (i.e. disk full)
+6 ; 2 - Error creating Files(i.e. directory patch, VMS Space, etc.)
+7 ; 3 - Error creating .Com file for FTP transfer, permissions issue
+8 ; 4 - Error with FTP Transfer,ntwk/permissions, Report Server issue
+9 ; 5 - Error with file deletion/cleanup prior to processing
+10 ; 6 - Error, lock is present. Process already running
+11 SET CLRSERR=0
TSTMSG ; This entry point is used to test the messaging framework
+1 ; S SLRSTST1=1
+2 SET CLRSERR=0
+3 ; Check for O/S version
+4 NEW CKOS
+5 SET CKOS=$$OS^%ZOSV()
+6 ; use lock to prevent mult. runs
+7 LOCK +^PRCP(446.7,"STATUS"):3
IF $TEST=0
SET CLRSERR=6
+8 IF CLRSERR=0
DO DELRUN^PRCHLO5
+9 IF CLRSERR=5
Begin DoDot:1
+10 NEW PRCPMSG
+11 SET PRCPMSG(1)="Error with file deletion/cleanup prior to processing. Please contact IRM."
+12 SET PRCPMSG(2)=" "
+13 SET PRCPMSG(3)="This error indicates the CLRS EXTRACT DIRECTORY has not"
+14 SET PRCPMSG(4)="been properly set up during the installation of this patch."
+15 SET PRCPMSG(5)=" "
+16 SET PRCPMSG(6)="(Please refer to the pre installation instructions for PRC*5.1*83)"
+17 SET PRCPMSG(7)=" "
+18 SET PRCPMSG(8)="A valid directory must be set up with the"
+19 SET PRCPMSG(9)="proper read/write/execute/delete privileges."
+20 SET PRCPMSG(10)=" "
+21 SET PRCPMSG(11)="In addition, the directory name which you create"
+22 SET PRCPMSG(12)="must be added as the CLRS EXTRACT DIRECTORY"
+23 SET PRCPMSG(13)="through the CLO System Parameters Option."
+24 SET PRCPMSG(14)="If the field is blank, you will generate this error."
+25 SET PRCPMSG(15)=" "
+26 SET PRCPMSG(16)="Please confirm all steps have been performed"
+27 SET PRCPMSG(17)="according to the pre installation instructions for patch PRC*5.1*83."
+28 DO MAILFTP^PRCHLO4A
+29 QUIT
End DoDot:1
+30 ; Begin to build files
+31 IF CLRSERR=0
DO INIT^PRCHLO
+32 ; PO activity Extract logic completed
IF CLRSERR=0
DO PRCPCMP^PRCHLO5
+33 ; test point to generate message 1
IF $DATA(CLRSTST1)
Begin DoDot:1
+34 if CLRSTST1'=1
QUIT
+35 SET CLRSERR=1
+36 QUIT
End DoDot:1
+37 IF CLRSERR=1
Begin DoDot:1
+38 ; error building ^TMP($J)
NEW PRCPMSG
+39 SET PRCPMSG(1)="Error, No Data for PO Activity Files, contact IRM"
+40 DO MAILFTP^PRCHLO4A
+41 QUIT
End DoDot:1
CRFILE ; Create .txt file to confirm write privileges to directory
+1 ; will return CLRSERR=2 on error
IF CLRSERR=0
DO TSTF^PRCHLO4
+2 IF CLRSERR=0
DO CLRSFIL^PRCHLO4
+3 IF CLRSERR=2
Begin DoDot:1
+4 NEW PRCPMSG
+5 SET PRCPMSG(1)="Error, Problem with FTP File Creation, contact IRM"
+6 DO MAILFTP^PRCHLO4A
+7 QUIT
End DoDot:1
+8 IF CLRSERR=0
Begin DoDot:1
+9 NEW PRCPMSG
+10 SET PRCPMSG(1)="Built PO Activity Extracts and GIP Extracts for transfer"
+11 DO MAILFTP^PRCHLO4A
+12 QUIT
End DoDot:1
+13 IF CKOS["VMS"
Begin DoDot:1
+14 IF CLRSERR=0
DO CRTCOM^PRCHLO4
+15 QUIT
End DoDot:1
+16 IF CKOS["NT"
Begin DoDot:1
+17 IF CLRSERR=0
DO CRTWIN^PRCHLO4A
+18 QUIT
End DoDot:1
+19 ;PRC*5.1*172 added check for Full Linux
+20 IF CKOS["UNIX"
Begin DoDot:1
+21 IF CLRSERR=0
Begin DoDot:2
+22 DO CRTUNX1^PRCHLO4
+23 QUIT
End DoDot:2
+24 QUIT
End DoDot:1
+25 IF CLRSERR=6
Begin DoDot:1
+26 NEW PRCPMSG
+27 SET PRCPMSG(1)="Error encountered when attempting to run CLO PO"
+28 SET PRCPMSG(2)="activity reports due to other CLRS extracts in"
+29 SET PRCPMSG(3)="progress. Please try again later."
+30 DO MAILFTP^PRCHLO4A
+31 QUIT
End DoDot:1
+32 ; test point to generate message 3
IF $DATA(CLRSTST1)
Begin DoDot:1
+33 if CLRSTST1'=3
QUIT
+34 SET CLRSERR=3
+35 QUIT
End DoDot:1
+36 ;ping report server for availability
IF CLRSERR=0
DO CKRPTSV^PRCHLO4A
+37 IF CLRSERR=3
Begin DoDot:1
+38 NEW PRCPMSG
+39 SET PRCPMSG(1)="Error, problem creating SETUP file for FTP Transfer, contact IRM."
+40 SET PRCPMSG(2)="The Report Server may be unavailable for processing."
+41 DO MAILFTP^PRCHLO4A
+42 QUIT
End DoDot:1
+43 IF CLRSERR=0
Begin DoDot:1
+44 NEW PRCPMSG,FILEDIR
+45 SET FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
+46 SET PRCPMSG(1)="Final FTP Setup complete, beginning FTP Transfer"
+47 SET PRCPMSG(2)=" "
+48 SET PRCPMSG(3)="The file transfer to the report server has been initiated."
+49 SET PRCPMSG(4)="You will be receiving a notification that the FTP"
+50 SET PRCPMSG(5)="process has completed. The notification message"
+51 SET PRCPMSG(6)="should be received within the hour. If you do not"
+52 SET PRCPMSG(7)="receive the FTP process has completed message,"
+53 SET PRCPMSG(8)="please contact IRM. IRM can confirm the process"
+54 SET PRCPMSG(9)="is still running by performing the following"
+55 SET PRCPMSG(10)="command:"
+56 SET PRCPMSG(11)=" "
+57 SET PRCPMSG(12)="At the MUMPS Programmer prompt, type D ^%SS"
+58 SET PRCPMSG(13)=" "
+59 SET PRCPMSG(14)="See if there are any PRCHLO* routines running."
+60 SET PRCPMSG(15)=" "
+61 SET PRCPMSG(16)="If these routines are present, the process is still"
+62 SET PRCPMSG(17)="running. If you waited one hour, and did not get the"
+63 SET PRCPMSG(18)="FTP process has completed message, a problem"
+64 SET PRCPMSG(19)="was encountered. Further troubleshooting can be"
+65 SET PRCPMSG(20)="performed by examining the LOGFILE CLRSxxxFTP1.LOG"
+66 SET PRCPMSG(21)="where xxx is your station ID#. The logfile is"
+67 SET PRCPMSG(22)="located in the following directory: "_FILEDIR
+68 SET PRCPMSG(23)=" "
+69 DO MAILFTP^PRCHLO4A
+70 QUIT
End DoDot:1
+71 IF CKOS["VMS"
Begin DoDot:1
+72 IF CLRSERR=0
Begin DoDot:2
+73 DO CRTCOM1^PRCHLO4
+74 DO FTPCOM^PRCHLO4
+75 QUIT
End DoDot:2
+76 QUIT
End DoDot:1
+77 ;PRC*5.1*172 added check for Full Linux
+78 IF CKOS["UNIX"
Begin DoDot:1
+79 IF CLRSERR=0
Begin DoDot:2
+80 DO UNXFTP^PRCHLO4
+81 QUIT
End DoDot:2
+82 QUIT
End DoDot:1
+83 IF CKOS["NT"
Begin DoDot:1
+84 IF CLRSERR=0
Begin DoDot:2
+85 DO CRTWIN^PRCHLO4A
+86 DO FTPCOM^PRCHLO4A
+87 QUIT
End DoDot:2
+88 QUIT
End DoDot:1
+89 ; release the lock
+90 LOCK -^PRCP(446.7,"STATUS")
+91 IF CLRSERR=4
Begin DoDot:1
+92 NEW PRCPMSG,FILEDIR
+93 SET FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
+94 SET PRCPMSG(1)="An Error occurred during the FTP Transfer "_$$HTE^XLFDT($HOROLOG)
+95 SET PRCPMSG(2)="Contact IRM to perform troubleshooting steps"
+96 SET PRCPMSG(3)="by examining the logfile CLRSxxxFTP1.LOG where"
+97 SET PRCPMSG(4)="xxx is your station number. The logfile is located"
+98 SET PRCPMSG(5)="the FTP directory "_FILEDIR
+99 SET PRCPMSG(6)=" "
+100 DO MAILFTP^PRCHLO4A
+101 QUIT
End DoDot:1
+102 IF CLRSERR=0
Begin DoDot:1
+103 NEW PRCPMSG,FILEDIR
+104 SET FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
+105 SET PRCPMSG(1)="The FTP Transfer process completed, "_$$HTE^XLFDT($HOROLOG)
+106 SET PRCPMSG(2)=" "
+107 SET PRCPMSG(3)="The Clinical Logistics 0ffice should examine the Report Server"
+108 SET PRCPMSG(4)="FTP directory for your files. If the files from your"
+109 SET PRCPMSG(5)="station are not found, IRM can provide additional"
+110 SET PRCPMSG(6)="troubleshooting steps by examining the LOGFILE"
+111 SET PRCPMSG(7)="CLRSxxxFTP1.LOG where xxx is your station number."
+112 SET PRCPMSG(8)="The logfile is located in the directory: "_FILEDIR
+113 SET PRCPMSG(9)=" "
+114 SET PRCPMSG(10)="The contents of the logfile are listed below:"
+115 DO LOG2FILE^PRCHLO4A
+116 QUIT
End DoDot:1
+117 ; CLEAN UP
+118 KILL ^TMP($JOB)
+119 KILL ^TMP("PRCHLOG",$JOB)
+120 QUIT
DELRUN ; delete previous run at the beginning of the program
+1 ;
+2 NEW FILCK,FILDEL,TFILE1,TFILE2,OUTFL1,OUTFL2,POP,STID
+3 ; create, delete, then create files to clean up and confirm
+4 ; write / delete privileges to directory
+5 SET POP=""
+6 SET STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
+7 SET OUTFL1="CLRS"_STID_"TST.TXT"
+8 SET OUTFL2="IFCP"_STID_"TST.TXT"
+9 SET FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
+10 IF FILEDIR=""
Begin DoDot:1
+11 SET CLRSERR=5
+12 QUIT
End DoDot:1
+13 IF FILEDIR=" "
Begin DoDot:1
+14 SET CLRSERR=5
+15 QUIT
End DoDot:1
+16 IF CLRSERR=0
DO OPEN^%ZISH("TFILE1",FILEDIR,OUTFL1,"W")
+17 IF POP
Begin DoDot:1
+18 SET CLRSERR=5
+19 QUIT
End DoDot:1
+20 IF CLRSERR=0
Begin DoDot:1
+21 DO USE^%ZISUTL("TFILE1")
+22 WRITE !,"$ ! This is a test file to confirm write/delete access"
+23 WRITE !,"$ ! once file access is confirmed, file is deleted"
+24 WRITE !,"$ EXIT"
+25 DO CLOSE^%ZISH("TFILE1")
+26 DO OPEN^%ZISH("TFILE2",FILEDIR,OUTFL2,"W")
+27 DO USE^%ZISUTL("TFILE2")
+28 WRITE !,"$ ! This is a test file to confirm write/delete access"
+29 WRITE !,"$ ! once file access is confirmed, file is deleted"
+30 WRITE !,"$ EXIT"
+31 DO CLOSE^%ZISH("TFILE2")
+32 QUIT
End DoDot:1
+33 ;
DELWIN ; DELETE windows files, need to handle 1 file at a time
+1 ; SACC Exception received for usage of $ZF(-1) in PRC*5.1*83
+2 ; See IFCAP technical manual.
+3 IF CKOS["NT"
DO DELWIN^PRCHLO4A
DELFILS ; Delete the files / clean-up before processing
+1 ;
+2 ; SACC Exception received for usage of $ZF(-1) in PRC*5.1*83
+3 ; See IFCAP technical manual
+4 ;O/S IS VMS
IF CKOS["VMS"
Begin DoDot:1
+5 if CLRSERR'="0"
QUIT
+6 NEW PV,PV1,XPV,XPV1
+7 SET XPV="S PV=$ZF(-1,""DELETE "_FILEDIR_"*"_STID_"*.*;*"")"
+8 XECUTE XPV
+9 QUIT
End DoDot:1
+10 ;PRC*5.1*172 added check for Full Linux
+11 IF CKOS["UNIX"
Begin DoDot:1
+12 DO DELUNX^PRCHLO4A
+13 QUIT
End DoDot:1
+14 QUIT
