PRCHLO4A.m

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 ---PRCHLO4A   12302     printed  Feb 18, 2025@23:34:56                                                                                                                                                                                                   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