PRCHLO4A ;WOIFO/RLL/DAP-EXTRACT ROUTINE CLO REPORT SERVER ;12/30/10 14:58
;;5.1;IFCAP;**83,104,98,130,154,172**;Oct 20, 2000;Build 2
;Per VHA Directive 2004-038, this routine should not be modified.
; Continuation of PRCHLO4
;
; PRCHLO4A routines are used to Write out the Header and data
;
;Patch PRC*5.1*172 are modifications to CLRS transmission processing
;to support those sites that have migrated to Full LINUX OS
;
Q
GETDIR ; Get directory from PRCPLO EXTRACT DIRECTORY system parameter for CLRS
N FILEDIR,STID
S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
;
Q
;
CRTWIN ; Create CLRSxxxWFTP.TXT file to transfer file(s)
;*98 Modified to work with PRC CLRS ADDRESS parameter
N FILEDIR,POP,STID,OUTFLL1,ADDR
; PRC*5.1*130 begin
N PRCHUSN,PRCHPSW
; PRC*5.1*130 end
S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
S POP="" ; POP is returned by OPEN^%ZISH
S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
; RLL/PRC*5.1*104 change logic to create separate FTP
; transfer files (1 for each file for Windows/Cache)
S ADDR=$$GET^XPAR("SYS","PRC CLRS ADDRESS",1,"Q")
I ADDR="" S PRCPMSG(1)="There is no address identified in the CLRS Adress Parameter.",PRCPMSG(2)="Please correct and retry." D MAILFTP S CLRSERR=1 Q
; PRC*5.1*130 begin
S PRCHUSN=$$GET^XPAR("SYS","PRCPLO USER NAME",1,"Q")
I PRCHUSN="" S PRCPMSG(1)="There is no user name identified in the CLRS USER NAME Parameter.",PRCPMSG(2)="Please correct and retry." D MAILFTP S CLRSERR=1 Q
S PRCHUSN=$$DECRYP^XUSRB1(PRCHUSN)
S PRCHPSW=$$GET^XPAR("SYS","PRCPLO PASSWORD",1,"Q")
I PRCHPSW="" S PRCPMSG(1)="There is no password identified in the CLRS PASSWORD Parameter.",PRCPMSG(2)="Please correct and retry." D MAILFTP S CLRSERR=1 Q
S PRCHPSW=$$DECRYP^XUSRB1(PRCHPSW)
; PRC*5.1*130 end
;
I CLRSERR'=3 D
. N PONN ; File number for File type
. S PONN=1
. F PONN=1:1:27 D
. . N FTY ; File type F=Po Activity , G=GIP
. . ;
. . S FTY="F"
. . S OUTFLL1="CLRS"_STID_FTY_PONN_"WFTP.TXT"
. . D OPEN^%ZISH("FILE1",FILEDIR,OUTFLL1,"W")
. . I POP D
. . . S CLRSERR=3
. . . Q
. . D USE^%ZISUTL("FILE1")
. . D BLDF1
. . D CLOSE^%ZISH("FILE1")
. . Q
. Q
;
I CLRSERR'=3 D
. ; RLL/PRC*5.1*104 change logic to create separate FTP
. ; tranfer files (1 for each file for Windows/Cache)
. N PONN ; File number for file type
. S PONN=1
. F PONN=1:1:2 D
. . N FTY ; File type F=Po Activity , G=GIP
. . S FTY="G"
. . S OUTFLL1="CLRS"_STID_FTY_PONN_"WFTP.TXT"
. . D OPEN^%ZISH("FILE1",FILEDIR,OUTFLL1,"W")
. . I POP D
. . . S CLRSERR=3
. . . Q
. . D USE^%ZISUTL("FILE1")
. . D BLDF1
. . D CLOSE^%ZISH("FILE1")
. . Q
. Q
Q
BLDF1 ; RLL/PRC*5.1*104 added logic to create separate FTP
; transfers (1 for each file)
;
W "open "_ADDR,! ;Connect to the Report Server
; PRC*5.1*130 begin
; Enter user name for Report Server Login
W PRCHUSN,!
; Enter P/W for Report Server Login
W PRCHPSW,!
; PRC*5.1*130 end
W "PUT "_FILEDIR_"IFCP"_STID_FTY_PONN_".TXT",!
W "bye",! ; Exit FTP
;
Q
CKRPTSV ; Check for availability of report server
; Several steps need to be performed
; 1. Set up script to perform PING
; 2. Capture log file during PING
; 3. Read logfile into working global
; 4. Determine Success/Failure of PING to server
; 5. If successful, continue processing (CLRSERR=0)
; 6. If problem occurs, S CLRSERR=3 and generate message
;
I CKOS["VMS" D VMSPING ; CKOS set in PRCHLO5
I CKOS["NT" D WINPING ; CKOS set in PRCHLO5
I CKOS["UNIX" D UNXPING ; added for UNIX LINUX PING ;PRC*5.1*172 added check for Full Linux
Q
VMSPING ; need to PING report server to make sure it is available
;
; 1. Create .COM file to execute
;*98 Modified to work with PRC CLRS ADDRESS parameter
N FILEDIR,STID,OUTFLL2,ADDR
S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
S ADDR=$$GET^XPAR("SYS","PRC CLRS ADDRESS",1,"Q")
I ADDR="" S PRCPMSG(1)="There is no address identified in the CLRS Address Parameter.",PRCPMSG(2)="Please correct and retry." D MAILFTP S CLRSERR=1 Q
;
S OUTFLL2="CLRS"_STID_"PING.COM"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFLL2,"W")
D USE^%ZISUTL("FILE1")
W "$ SET VERIFY=(PROCEDURE,IMAGE)",!
W "$ SET DEFAULT "_FILEDIR,!
W "$ TCPIP",!
W "PING "_ADDR,!
W "EXIT",!
W "$ EXIT 3",!
D CLOSE^%ZISH("FILE1")
;
; 2. Execute .COM file, create logfile
S XPV1="S PV=$ZF(-1,""@"_FILEDIR_"CLRS"_STID_"PING.COM/OUTPUT="_FILEDIR_"CLRS"_STID_"PING.LOG"")"
X XPV1 ; Run the .com file
;
; 3. Read Logfile into working global
N FNAME,XLOG
S FNAME="CLRS"_STID_"PING.LOG"
S XLOG=$$FTG^%ZISH(FILEDIR,FNAME,$NAME(^TMP("PRCLRSLOG",$J,1)),3)
; Check global for %SYSTEM or 0 packets received
N PNG,PNG1,PNG2,PNG3
S PNG=0,PNG1=0,PNG2=0
F S PNG=$O(^TMP("PRCLRSLOG",$J,PNG)) Q:PNG="" D
. S PNG1=$G(^TMP("PRCLRSLOG",$J,PNG))
. I PNG1["0 packets received" S CLRSERR=3
. I PNG1["%SYSTEM" S CLRSERR=3
. Q
Q
UNXPING ;PRC*5.1*172 added logic for Full Linux
; UNIX/LINUX PING
;
; PING report server to make sure it is available
;*98 Modified to work with PRC CLRS ADDRESS parameter
N PV,XPV1,FILEDIR,STID,XLOG,ADDR
S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
S ADDR=$$GET^XPAR("SYS","PRC CLRS ADDRESS",1,"Q")
I ADDR="" S PRCPMSG(1)="There is no address identified in the CLRS Adress Parameter.",PRCPMSG(2)="Please correct and retry." D MAILFTP S CLRSERR=1 Q
;
S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
S XPV1="S PV=$ZF(-1,""ping -c 3 "_ADDR_">"_FILEDIR_"CLRS"_STID_"PING.LOG"")"
X XPV1
S FNAME="CLRS"_STID_"PING.LOG"
S XLOG=$$FTG^%ZISH(FILEDIR,FNAME,$NAME(^TMP("PRCLRSLOG",$J,1)),3)
N PNG,PNG1,PNG2,PNG3
S PNG=0,PNG1=0,PNG2=0
F S PNG=$O(^TMP("PRCLRSLOG",$J,PNG)) Q:PNG="" D
. S PNG1=$G(^TMP("PRCLRSLOG",$J,PNG))
. I PNG1["0 received" S CLRSERR=3
. Q
Q
;
WINPING ; PING report server to make sure it is available
;*98 Modified to work with PRC CLRS ADDRESS parameter
N PV,XPV1,FILEDIR,STID,XLOG,ADDR
S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
S ADDR=$$GET^XPAR("SYS","PRC CLRS ADDRESS",1,"Q")
I ADDR="" S PRCPMSG(1)="There is no address identified in the CLRS Adress Parameter.",PRCPMSG(2)="Please correct and retry." D MAILFTP S CLRSERR=1 Q
;
S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
S XPV1="S PV=$ZF(-1,""PING "_ADDR_">"_FILEDIR_"CLRS"_STID_"PING.LOG"")"
X XPV1
S FNAME="CLRS"_STID_"PING.LOG"
S XLOG=$$FTG^%ZISH(FILEDIR,FNAME,$NAME(^TMP("PRCLRSLOG",$J,1)),3)
N PNG,PNG1,PNG2,PNG3
S PNG=0,PNG1=0,PNG2=0
F S PNG=$O(^TMP("PRCLRSLOG",$J,PNG)) Q:PNG="" D
. S PNG1=$G(^TMP("PRCLRSLOG",$J,PNG))
. I PNG1["Received = 0" S CLRSERR=3
. Q
Q
;
LOG2FILE ; Set logfile to global, add to mail message
;
;
N FILEDIR,STID,FNAME,XLOG
S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
I CKOS["VMS" S FNAME="CLRS"_STID_"FTP1.LOG"
I CKOS["NT" S FNAME="CLRS"_STID_"F1FTP1.LOG"
I CKOS["UNIX" S FNAME="UNIXFTP.LOG" ;PRC*5.1*172 added check for Full Linux
S XLOG=$$FTG^%ZISH(FILEDIR,FNAME,$NAME(^TMP("PRCHLOG",$J,1)),3)
; Log file is in the global ^TMP("PRCHLOG", lets put it in
; the message beginning at PRCPMSG(11)
;
N LG1,LG2,LG3,LG4,LGCNT
S LG1=0,LG2=0,LG3=0,LG4=0,LGCNT=11
F S LG1=$O(^TMP("PRCHLOG",$J,LG1)) Q:LG1="" D
. S LG3=$G(^TMP("PRCHLOG",$J,LG1))
. S PRCPMSG(LGCNT)=LG3
. S LGCNT=LGCNT+1
. Q
D MAILFTP
Q
FTPCOM ; Issue the FTP command after CLRSxxxWFTP.TXT file is built
; remain in CACHE during FTP Process using
; $ZF(-1) call
;
; rll/ 8/30/2006 Change logic to initiate transfer one file
; at a time to the report server for Windows/Cache stations
; This was done after a hang was observed between transfers.
;
N LPP1,LPP2
S LPP1=0,LPP2="F"
F LPP1=1:1:27 D ; run the FTP command for the 27 PO files
. D RUNFTPT
. Q
S LPP1=0,LPP2="G"
F LPP1=1:1:2 D ; run the FTP command for the 2 GIP files
. D RUNFTPT
. Q
Q
;
RUNFTPT ; Run the FTP transfer for Windows
N PV,XPV1,FILEDIR,STID
;
S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
; SACC Exception received for usage of $ZF(-1) in PRC*5.1*83
; See IFCAP Technical Manual
S XPV1="S PV=$ZF(-1,""ftp -s:"_FILEDIR_"CLRS"_STID_LPP2_LPP1_"WFTP.TXT>"_FILEDIR_"CLRS"_STID_LPP2_LPP1_"FTP1.LOG"")"
X XPV1 ; FTP the files, Comment out for testing
;
; error flag logic
I PV=-1 D ; Note, this error is logged on system error during xfer
. S CLRSERR=1
. Q
Q
DELWIN ; Delete windows files
;
;
I CKOS["NT" D
. N LPP1,LPP2
. S LPP1=0,LPP2="F"
. F LPP1=1:1:27 D ; run the FTP command for the 27 PO files
. . D DELFTPF
. . Q
. Q
S LPP1=0,LPP2="G"
F LPP1=1:1:2 D
. D DELFTPF ; Delete the GIP files
. Q
Q
DELUNX ;PRC*5.1*172 added logic for Full Linux
; Delete the FTP files, logs , and .TXT files
;
S OUTFLL2="CLRSCLNUP.SH"
N FILEDIR,STID,XPV
S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
; delete previous extract
D OPEN^%ZISH("FILE1",FILEDIR,OUTFLL2,"W")
D USE^%ZISUTL("FILE1")
; add syntax here to create shell script
;
;
;
; add Linux code below
W "#!/bin/bash",!
W !
W "cd ",FILEDIR,!
; W !
W "rm -f CLRS*.TXT",!
W "rm -f IFCP*.TXT",!
W "rm -f CLRS*UNX*",!
W "rm -f CLRSCLNUP*",!
W "exit 0",!
D CLOSE^%ZISH("FILE1")
; get ready to delete files
;
; NOTE: This is a test entry point if problems occur with directory permissions
; if the directory is set up properly, the begin/end code in not needed
; this code was left in for troubleshooting via M/Cache
; begin troubleshooting code
; peform CHMOD on SHELL SCRIPT to make it executable
; S XPV1="S PV=$ZF(-1,""CHMOD 755 "_FILEDIR_"CLRS"_"CLNUP.SH"")"
; S XPV1="S PV=$ZF(-1,"""_FILEDIR_"CLRS"_"CLNUP.SH"")"
; X XPV1
; end troubleshooting code
D DELUNX1
Q
;
;
;
DELUNX1 ;PRC*5.1*172 added logic for Full Linux
; Delete UNIX Files
;
; S XPV1="S PV=$ZF(-1,"""_FILEDIR_"CLRS"_STID_"UNX.SH"")"
S XPV1="S PV=$ZF(-1,"""_FILEDIR_"CLRS"_"CLNUP.SH"")"
X XPV1
Q
DELFTPF ; Delete the FTP files, logs , and .TXT files
;
N FILEDIR,STID,XPV
S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
; delete previous extract
S XPV="S PV=$ZF(-1,""DEL "_FILEDIR_"IFCP"_STID_LPP2_LPP1_".TXT"")"
X XPV ; comment out for testing
; delete previous logfile
;
S XPV="S PV=$ZF(-1,""DEL "_FILEDIR_"CLRS"_STID_LPP2_LPP1_"FTP1.LOG"")"
X XPV ; comment out for testing
; delete previous ftp file for transfer
;
S XPV="S PV=$ZF(-1,""DEL "_FILEDIR_"CLRS"_STID_LPP2_LPP1_"WFTP.TXT"")"
X XPV
Q
;
MAIL ;Builds mail messages to a defined mail group to notify users of the
;success or failure of the TaskMan scheduling for the CLO Procurement
;Reports
;
;*98 Modified code to work with PRC CLRS OUTLOOK MAILGROUP parameter
N XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ,PRCPMG,PRCPMG2
S XMSUB="CLO Procurement Report Status for "_$$HTE^XLFDT($H)
S XMDUZ="Clinical Logistics Report Server"
S XMTEXT="PRCPMSG("
S XMY("G.PRCPLO CLRS NOTIFICATIONS")=""
S PRCPMG=$$GET^XPAR("SYS","PRC CLRS OUTLOOK MAILGROUP",1,"Q")
S:$G(PRCPMG)'="" PRCPMG2="S XMY("""_PRCPMG_""")=""""" X PRCPMG2
;
D ^XMD
Q
;
MAILFTP ;Builds mail messages to a defined mail group to notify users of
;the success or failure of issues pertaining to FTP Transfer and
;file permissions/protections associated with VMS Directories
;
;*98 Modified code to work with PRC CLRS OUTLOOK MAILGROUP parameter
N XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ,PRCPMG,PRCPMG2
S XMSUB="CLO Environment Check & Data Transfer for OS / FTP , "_$$HTE^XLFDT($H)
S XMDUZ="Clinical Logistics Report Server"
S XMTEXT="PRCPMSG("
S XMY("G.PRCPLO CLRS NOTIFICATIONS")=""
S PRCPMG=$$GET^XPAR("SYS","PRC CLRS OUTLOOK MAILGROUP",1,"Q")
S:$G(PRCPMG)'="" PRCPMG2="S XMY("""_PRCPMG_""")=""""" X PRCPMG2
;
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHLO4A 12302 printed Apr 09, 2024@21:01:49 Page 2
PRCHLO4A ;WOIFO/RLL/DAP-EXTRACT ROUTINE CLO REPORT SERVER ;12/30/10 14:58
+1 ;;5.1;IFCAP;**83,104,98,130,154,172**;Oct 20, 2000;Build 2
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ; Continuation of PRCHLO4
+4 ;
+5 ; PRCHLO4A routines are used to Write out the Header and data
+6 ;
+7 ;Patch PRC*5.1*172 are modifications to CLRS transmission processing
+8 ;to support those sites that have migrated to Full LINUX OS
+9 ;
+10 QUIT
GETDIR ; Get directory from PRCPLO EXTRACT DIRECTORY system parameter for CLRS
+1 NEW FILEDIR,STID
+2 SET STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
+3 SET FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
+4 ;
+5 QUIT
+6 ;
CRTWIN ; Create CLRSxxxWFTP.TXT file to transfer file(s)
+1 ;*98 Modified to work with PRC CLRS ADDRESS parameter
+2 NEW FILEDIR,POP,STID,OUTFLL1,ADDR
+3 ; PRC*5.1*130 begin
+4 NEW PRCHUSN,PRCHPSW
+5 ; PRC*5.1*130 end
+6 SET STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
+7 ; POP is returned by OPEN^%ZISH
SET POP=""
+8 SET FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
+9 ; RLL/PRC*5.1*104 change logic to create separate FTP
+10 ; transfer files (1 for each file for Windows/Cache)
+11 SET ADDR=$$GET^XPAR("SYS","PRC CLRS ADDRESS",1,"Q")
+12 IF ADDR=""
SET PRCPMSG(1)="There is no address identified in the CLRS Adress Parameter."
SET PRCPMSG(2)="Please correct and retry."
DO MAILFTP
SET CLRSERR=1
QUIT
+13 ; PRC*5.1*130 begin
+14 SET PRCHUSN=$$GET^XPAR("SYS","PRCPLO USER NAME",1,"Q")
+15 IF PRCHUSN=""
SET PRCPMSG(1)="There is no user name identified in the CLRS USER NAME Parameter."
SET PRCPMSG(2)="Please correct and retry."
DO MAILFTP
SET CLRSERR=1
QUIT
+16 SET PRCHUSN=$$DECRYP^XUSRB1(PRCHUSN)
+17 SET PRCHPSW=$$GET^XPAR("SYS","PRCPLO PASSWORD",1,"Q")
+18 IF PRCHPSW=""
SET PRCPMSG(1)="There is no password identified in the CLRS PASSWORD Parameter."
SET PRCPMSG(2)="Please correct and retry."
DO MAILFTP
SET CLRSERR=1
QUIT
+19 SET PRCHPSW=$$DECRYP^XUSRB1(PRCHPSW)
+20 ; PRC*5.1*130 end
+21 ;
+22 IF CLRSERR'=3
Begin DoDot:1
+23 ; File number for File type
NEW PONN
+24 SET PONN=1
+25 FOR PONN=1:1:27
Begin DoDot:2
+26 ; File type F=Po Activity , G=GIP
NEW FTY
+27 ;
+28 SET FTY="F"
+29 SET OUTFLL1="CLRS"_STID_FTY_PONN_"WFTP.TXT"
+30 DO OPEN^%ZISH("FILE1",FILEDIR,OUTFLL1,"W")
+31 IF POP
Begin DoDot:3
+32 SET CLRSERR=3
+33 QUIT
End DoDot:3
+34 DO USE^%ZISUTL("FILE1")
+35 DO BLDF1
+36 DO CLOSE^%ZISH("FILE1")
+37 QUIT
End DoDot:2
+38 QUIT
End DoDot:1
+39 ;
+40 IF CLRSERR'=3
Begin DoDot:1
+41 ; RLL/PRC*5.1*104 change logic to create separate FTP
+42 ; tranfer files (1 for each file for Windows/Cache)
+43 ; File number for file type
NEW PONN
+44 SET PONN=1
+45 FOR PONN=1:1:2
Begin DoDot:2
+46 ; File type F=Po Activity , G=GIP
NEW FTY
+47 SET FTY="G"
+48 SET OUTFLL1="CLRS"_STID_FTY_PONN_"WFTP.TXT"
+49 DO OPEN^%ZISH("FILE1",FILEDIR,OUTFLL1,"W")
+50 IF POP
Begin DoDot:3
+51 SET CLRSERR=3
+52 QUIT
End DoDot:3
+53 DO USE^%ZISUTL("FILE1")
+54 DO BLDF1
+55 DO CLOSE^%ZISH("FILE1")
+56 QUIT
End DoDot:2
+57 QUIT
End DoDot:1
+58 QUIT
BLDF1 ; RLL/PRC*5.1*104 added logic to create separate FTP
+1 ; transfers (1 for each file)
+2 ;
+3 ;Connect to the Report Server
WRITE "open "_ADDR,!
+4 ; PRC*5.1*130 begin
+5 ; Enter user name for Report Server Login
+6 WRITE PRCHUSN,!
+7 ; Enter P/W for Report Server Login
+8 WRITE PRCHPSW,!
+9 ; PRC*5.1*130 end
+10 WRITE "PUT "_FILEDIR_"IFCP"_STID_FTY_PONN_".TXT",!
+11 ; Exit FTP
WRITE "bye",!
+12 ;
+13 QUIT
CKRPTSV ; Check for availability of report server
+1 ; Several steps need to be performed
+2 ; 1. Set up script to perform PING
+3 ; 2. Capture log file during PING
+4 ; 3. Read logfile into working global
+5 ; 4. Determine Success/Failure of PING to server
+6 ; 5. If successful, continue processing (CLRSERR=0)
+7 ; 6. If problem occurs, S CLRSERR=3 and generate message
+8 ;
+9 ; CKOS set in PRCHLO5
IF CKOS["VMS"
DO VMSPING
+10 ; CKOS set in PRCHLO5
IF CKOS["NT"
DO WINPING
+11 ; added for UNIX LINUX PING ;PRC*5.1*172 added check for Full Linux
IF CKOS["UNIX"
DO UNXPING
+12 QUIT
VMSPING ; need to PING report server to make sure it is available
+1 ;
+2 ; 1. Create .COM file to execute
+3 ;*98 Modified to work with PRC CLRS ADDRESS parameter
+4 NEW FILEDIR,STID,OUTFLL2,ADDR
+5 SET STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
+6 SET FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
+7 SET ADDR=$$GET^XPAR("SYS","PRC CLRS ADDRESS",1,"Q")
+8 IF ADDR=""
SET PRCPMSG(1)="There is no address identified in the CLRS Address Parameter."
SET PRCPMSG(2)="Please correct and retry."
DO MAILFTP
SET CLRSERR=1
QUIT
+9 ;
+10 SET OUTFLL2="CLRS"_STID_"PING.COM"
+11 DO OPEN^%ZISH("FILE1",FILEDIR,OUTFLL2,"W")
+12 DO USE^%ZISUTL("FILE1")
+13 WRITE "$ SET VERIFY=(PROCEDURE,IMAGE)",!
+14 WRITE "$ SET DEFAULT "_FILEDIR,!
+15 WRITE "$ TCPIP",!
+16 WRITE "PING "_ADDR,!
+17 WRITE "EXIT",!
+18 WRITE "$ EXIT 3",!
+19 DO CLOSE^%ZISH("FILE1")
+20 ;
+21 ; 2. Execute .COM file, create logfile
+22 SET XPV1="S PV=$ZF(-1,""@"_FILEDIR_"CLRS"_STID_"PING.COM/OUTPUT="_FILEDIR_"CLRS"_STID_"PING.LOG"")"
+23 ; Run the .com file
XECUTE XPV1
+24 ;
+25 ; 3. Read Logfile into working global
+26 NEW FNAME,XLOG
+27 SET FNAME="CLRS"_STID_"PING.LOG"
+28 SET XLOG=$$FTG^%ZISH(FILEDIR,FNAME,$NAME(^TMP("PRCLRSLOG",$JOB,1)),3)
+29 ; Check global for %SYSTEM or 0 packets received
+30 NEW PNG,PNG1,PNG2,PNG3
+31 SET PNG=0
SET PNG1=0
SET PNG2=0
+32 FOR
SET PNG=$ORDER(^TMP("PRCLRSLOG",$JOB,PNG))
if PNG=""
QUIT
Begin DoDot:1
+33 SET PNG1=$GET(^TMP("PRCLRSLOG",$JOB,PNG))
+34 IF PNG1["0 packets received"
SET CLRSERR=3
+35 IF PNG1["%SYSTEM"
SET CLRSERR=3
+36 QUIT
End DoDot:1
+37 QUIT
UNXPING ;PRC*5.1*172 added logic for Full Linux
+1 ; UNIX/LINUX PING
+2 ;
+3 ; PING report server to make sure it is available
+4 ;*98 Modified to work with PRC CLRS ADDRESS parameter
+5 NEW PV,XPV1,FILEDIR,STID,XLOG,ADDR
+6 SET FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
+7 SET ADDR=$$GET^XPAR("SYS","PRC CLRS ADDRESS",1,"Q")
+8 IF ADDR=""
SET PRCPMSG(1)="There is no address identified in the CLRS Adress Parameter."
SET PRCPMSG(2)="Please correct and retry."
DO MAILFTP
SET CLRSERR=1
QUIT
+9 ;
+10 SET STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
+11 SET XPV1="S PV=$ZF(-1,""ping -c 3 "_ADDR_">"_FILEDIR_"CLRS"_STID_"PING.LOG"")"
+12 XECUTE XPV1
+13 SET FNAME="CLRS"_STID_"PING.LOG"
+14 SET XLOG=$$FTG^%ZISH(FILEDIR,FNAME,$NAME(^TMP("PRCLRSLOG",$JOB,1)),3)
+15 NEW PNG,PNG1,PNG2,PNG3
+16 SET PNG=0
SET PNG1=0
SET PNG2=0
+17 FOR
SET PNG=$ORDER(^TMP("PRCLRSLOG",$JOB,PNG))
if PNG=""
QUIT
Begin DoDot:1
+18 SET PNG1=$GET(^TMP("PRCLRSLOG",$JOB,PNG))
+19 IF PNG1["0 received"
SET CLRSERR=3
+20 QUIT
End DoDot:1
+21 QUIT
+22 ;
WINPING ; PING report server to make sure it is available
+1 ;*98 Modified to work with PRC CLRS ADDRESS parameter
+2 NEW PV,XPV1,FILEDIR,STID,XLOG,ADDR
+3 SET FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
+4 SET ADDR=$$GET^XPAR("SYS","PRC CLRS ADDRESS",1,"Q")
+5 IF ADDR=""
SET PRCPMSG(1)="There is no address identified in the CLRS Adress Parameter."
SET PRCPMSG(2)="Please correct and retry."
DO MAILFTP
SET CLRSERR=1
QUIT
+6 ;
+7 SET STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
+8 SET XPV1="S PV=$ZF(-1,""PING "_ADDR_">"_FILEDIR_"CLRS"_STID_"PING.LOG"")"
+9 XECUTE XPV1
+10 SET FNAME="CLRS"_STID_"PING.LOG"
+11 SET XLOG=$$FTG^%ZISH(FILEDIR,FNAME,$NAME(^TMP("PRCLRSLOG",$JOB,1)),3)
+12 NEW PNG,PNG1,PNG2,PNG3
+13 SET PNG=0
SET PNG1=0
SET PNG2=0
+14 FOR
SET PNG=$ORDER(^TMP("PRCLRSLOG",$JOB,PNG))
if PNG=""
QUIT
Begin DoDot:1
+15 SET PNG1=$GET(^TMP("PRCLRSLOG",$JOB,PNG))
+16 IF PNG1["Received = 0"
SET CLRSERR=3
+17 QUIT
End DoDot:1
+18 QUIT
+19 ;
LOG2FILE ; Set logfile to global, add to mail message
+1 ;
+2 ;
+3 NEW FILEDIR,STID,FNAME,XLOG
+4 SET FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
+5 SET STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
+6 IF CKOS["VMS"
SET FNAME="CLRS"_STID_"FTP1.LOG"
+7 IF CKOS["NT"
SET FNAME="CLRS"_STID_"F1FTP1.LOG"
+8 ;PRC*5.1*172 added check for Full Linux
IF CKOS["UNIX"
SET FNAME="UNIXFTP.LOG"
+9 SET XLOG=$$FTG^%ZISH(FILEDIR,FNAME,$NAME(^TMP("PRCHLOG",$JOB,1)),3)
+10 ; Log file is in the global ^TMP("PRCHLOG", lets put it in
+11 ; the message beginning at PRCPMSG(11)
+12 ;
+13 NEW LG1,LG2,LG3,LG4,LGCNT
+14 SET LG1=0
SET LG2=0
SET LG3=0
SET LG4=0
SET LGCNT=11
+15 FOR
SET LG1=$ORDER(^TMP("PRCHLOG",$JOB,LG1))
if LG1=""
QUIT
Begin DoDot:1
+16 SET LG3=$GET(^TMP("PRCHLOG",$JOB,LG1))
+17 SET PRCPMSG(LGCNT)=LG3
+18 SET LGCNT=LGCNT+1
+19 QUIT
End DoDot:1
+20 DO MAILFTP
+21 QUIT
FTPCOM ; Issue the FTP command after CLRSxxxWFTP.TXT file is built
+1 ; remain in CACHE during FTP Process using
+2 ; $ZF(-1) call
+3 ;
+4 ; rll/ 8/30/2006 Change logic to initiate transfer one file
+5 ; at a time to the report server for Windows/Cache stations
+6 ; This was done after a hang was observed between transfers.
+7 ;
+8 NEW LPP1,LPP2
+9 SET LPP1=0
SET LPP2="F"
+10 ; run the FTP command for the 27 PO files
FOR LPP1=1:1:27
Begin DoDot:1
+11 DO RUNFTPT
+12 QUIT
End DoDot:1
+13 SET LPP1=0
SET LPP2="G"
+14 ; run the FTP command for the 2 GIP files
FOR LPP1=1:1:2
Begin DoDot:1
+15 DO RUNFTPT
+16 QUIT
End DoDot:1
+17 QUIT
+18 ;
RUNFTPT ; Run the FTP transfer for Windows
+1 NEW PV,XPV1,FILEDIR,STID
+2 ;
+3 SET FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
+4 SET STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
+5 ; SACC Exception received for usage of $ZF(-1) in PRC*5.1*83
+6 ; See IFCAP Technical Manual
+7 SET XPV1="S PV=$ZF(-1,""ftp -s:"_FILEDIR_"CLRS"_STID_LPP2_LPP1_"WFTP.TXT>"_FILEDIR_"CLRS"_STID_LPP2_LPP1_"FTP1.LOG"")"
+8 ; FTP the files, Comment out for testing
XECUTE XPV1
+9 ;
+10 ; error flag logic
+11 ; Note, this error is logged on system error during xfer
IF PV=-1
Begin DoDot:1
+12 SET CLRSERR=1
+13 QUIT
End DoDot:1
+14 QUIT
DELWIN ; Delete windows files
+1 ;
+2 ;
+3 IF CKOS["NT"
Begin DoDot:1
+4 NEW LPP1,LPP2
+5 SET LPP1=0
SET LPP2="F"
+6 ; run the FTP command for the 27 PO files
FOR LPP1=1:1:27
Begin DoDot:2
+7 DO DELFTPF
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 SET LPP1=0
SET LPP2="G"
+11 FOR LPP1=1:1:2
Begin DoDot:1
+12 ; Delete the GIP files
DO DELFTPF
+13 QUIT
End DoDot:1
+14 QUIT
DELUNX ;PRC*5.1*172 added logic for Full Linux
+1 ; Delete the FTP files, logs , and .TXT files
+2 ;
+3 SET OUTFLL2="CLRSCLNUP.SH"
+4 NEW FILEDIR,STID,XPV
+5 SET FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
+6 SET STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
+7 ; delete previous extract
+8 DO OPEN^%ZISH("FILE1",FILEDIR,OUTFLL2,"W")
+9 DO USE^%ZISUTL("FILE1")
+10 ; add syntax here to create shell script
+11 ;
+12 ;
+13 ;
+14 ; add Linux code below
+15 WRITE "#!/bin/bash",!
+16 WRITE !
+17 WRITE "cd ",FILEDIR,!
+18 ; W !
+19 WRITE "rm -f CLRS*.TXT",!
+20 WRITE "rm -f IFCP*.TXT",!
+21 WRITE "rm -f CLRS*UNX*",!
+22 WRITE "rm -f CLRSCLNUP*",!
+23 WRITE "exit 0",!
+24 DO CLOSE^%ZISH("FILE1")
+25 ; get ready to delete files
+26 ;
+27 ; NOTE: This is a test entry point if problems occur with directory permissions
+28 ; if the directory is set up properly, the begin/end code in not needed
+29 ; this code was left in for troubleshooting via M/Cache
+30 ; begin troubleshooting code
+31 ; peform CHMOD on SHELL SCRIPT to make it executable
+32 ; S XPV1="S PV=$ZF(-1,""CHMOD 755 "_FILEDIR_"CLRS"_"CLNUP.SH"")"
+33 ; S XPV1="S PV=$ZF(-1,"""_FILEDIR_"CLRS"_"CLNUP.SH"")"
+34 ; X XPV1
+35 ; end troubleshooting code
+36 DO DELUNX1
+37 QUIT
+38 ;
+39 ;
+40 ;
DELUNX1 ;PRC*5.1*172 added logic for Full Linux
+1 ; Delete UNIX Files
+2 ;
+3 ; S XPV1="S PV=$ZF(-1,"""_FILEDIR_"CLRS"_STID_"UNX.SH"")"
+4 SET XPV1="S PV=$ZF(-1,"""_FILEDIR_"CLRS"_"CLNUP.SH"")"
+5 XECUTE XPV1
+6 QUIT
DELFTPF ; Delete the FTP files, logs , and .TXT files
+1 ;
+2 NEW FILEDIR,STID,XPV
+3 SET FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
+4 SET STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
+5 ; delete previous extract
+6 SET XPV="S PV=$ZF(-1,""DEL "_FILEDIR_"IFCP"_STID_LPP2_LPP1_".TXT"")"
+7 ; comment out for testing
XECUTE XPV
+8 ; delete previous logfile
+9 ;
+10 SET XPV="S PV=$ZF(-1,""DEL "_FILEDIR_"CLRS"_STID_LPP2_LPP1_"FTP1.LOG"")"
+11 ; comment out for testing
XECUTE XPV
+12 ; delete previous ftp file for transfer
+13 ;
+14 SET XPV="S PV=$ZF(-1,""DEL "_FILEDIR_"CLRS"_STID_LPP2_LPP1_"WFTP.TXT"")"
+15 XECUTE XPV
+16 QUIT
+17 ;
MAIL ;Builds mail messages to a defined mail group to notify users of the
+1 ;success or failure of the TaskMan scheduling for the CLO Procurement
+2 ;Reports
+3 ;
+4 ;*98 Modified code to work with PRC CLRS OUTLOOK MAILGROUP parameter
+5 NEW XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ,PRCPMG,PRCPMG2
+6 SET XMSUB="CLO Procurement Report Status for "_$$HTE^XLFDT($HOROLOG)
+7 SET XMDUZ="Clinical Logistics Report Server"
+8 SET XMTEXT="PRCPMSG("
+9 SET XMY("G.PRCPLO CLRS NOTIFICATIONS")=""
+10 SET PRCPMG=$$GET^XPAR("SYS","PRC CLRS OUTLOOK MAILGROUP",1,"Q")
+11 if $GET(PRCPMG)'=""
SET PRCPMG2="S XMY("""_PRCPMG_""")="""""
XECUTE PRCPMG2
+12 ;
+13 DO ^XMD
+14 QUIT
+15 ;
MAILFTP ;Builds mail messages to a defined mail group to notify users of
+1 ;the success or failure of issues pertaining to FTP Transfer and
+2 ;file permissions/protections associated with VMS Directories
+3 ;
+4 ;*98 Modified code to work with PRC CLRS OUTLOOK MAILGROUP parameter
+5 NEW XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ,PRCPMG,PRCPMG2
+6 SET XMSUB="CLO Environment Check & Data Transfer for OS / FTP , "_$$HTE^XLFDT($HOROLOG)
+7 SET XMDUZ="Clinical Logistics Report Server"
+8 SET XMTEXT="PRCPMSG("
+9 SET XMY("G.PRCPLO CLRS NOTIFICATIONS")=""
+10 SET PRCPMG=$$GET^XPAR("SYS","PRC CLRS OUTLOOK MAILGROUP",1,"Q")
+11 if $GET(PRCPMG)'=""
SET PRCPMG2="S XMY("""_PRCPMG_""")="""""
XECUTE PRCPMG2
+12 ;
+13 DO ^XMD
+14 QUIT
