PRCHLO4 ;WOIFO/RLL/DAP-EXTRACT ROUTINE CLO REPORT SERVER ;12/30/10 15:01
;;5.1;IFCAP;**83,98,130,154,172**;Oct 20, 2000;Build 2
;Per VHA Directive 2004-038, this routine should not be modified.
; Continuation of PRCHLO3
;
; PRCHLO3 routines are used to Write out the Header and data
; associated with each of the 29 tables created for the Clinical
; logistics Report Server. The files are built from the extracts
; located in the ^TMP($J) global.
;
;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 System parameter for CLRS
S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
;
Q
CLRSFIL ; Create output files for CLRS
N FILEDIR
S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
; GET station id
N STID
; S STID=$G(^DD("SITE",1)) Old call
S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
TSTFIL ; Test entry point
;
D POMASTF ; Po Master Data
D POOBF ; Po Obligation Data
D POMETHF ; PO Method of Purchase Data
D PODISCF ; PO Discount Data
D POITMF ; Po Item Data
D POITIVF ; PO Item Inventory Point Data
D POITDRF ; PO Item Desc Data
D PODSCF ; PO Description
D POPRTF ; PO Partial Data
D PO2237F ; PO 2237 data
D POBOCF ; PO BOC Data
D POCOMF ; PO Comments data
D POREMF ; PO Remarks data
D POPPTF ; PO Prompt Payment Terms data
D POAMTF ; PO Amount data
D POAMDF ; PO Amendment Data
D POAMDCF ; PO Amendment Changes Data
D POAMDDF ; PO Amendment Description Data
D POAMBKF ; PO Amount Breakout Code Data
D FIL410 ; FILE 410
D FIL424 ; FILE 424
D FIL4241 ; FILE 424.1
D INVHDR^PRCHLO7 ;File 421.5 header
D INVPAY^PRCHLO7 ;Subfile 421.531
D INVFMS^PRCHLO7 ;Subfile 421.541
D INVCERT^PRCHLO7 ;Subfile 421.51
GIPBL1 ; GIP REPORTS
D BLDGP1^PRCPLO3
D BLDGP2^PRCPLO3
Q
POMASTF ; Save PO Master table data to a file to FTP to report Server
; build file name
N OUTFIL1
S OUTFIL1="IFCP"_STID_"F1.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL1,"W") ; Open the file
D USE^%ZISUTL("FILE1") ; Use the file as the output device
D POMASTH^PRCHLO3 ; Write the Header to the file
D POMASTW^PRCHLO3 ; Write the data to the file
D CLOSE^%ZISH("FILE1") ; Close the file
Q
POOBF ; Create flat file for PO OBLIGATION DATA
N OUTFIL2
S OUTFIL2="IFCP"_STID_"F2.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL2,"W") ; Open the file
D USE^%ZISUTL("FILE1") ; Use the file as the output device
D POOBHD^PRCHLO3
D POOBW^PRCHLO3
D CLOSE^%ZISH("FILE1") ; Close the file
Q
POMETHF ; Create flat for for Purchase Order Method
N OUTFIL3
S OUTFIL3="IFCP"_STID_"F3.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL3,"W") ; Open the file
D USE^%ZISUTL("FILE1") ; Use the file as the output device
D POPMEH^PRCHLO3
D POPMEW^PRCHLO3
D CLOSE^%ZISH("FILE1") ; Close the file
Q
PODISCF ; Create flat file for Purchase Order Discount
N OUTFIL4
S OUTFIL4="IFCP"_STID_"F4.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL4,"W") ; Open the file
D USE^%ZISUTL("FILE1")
D PODISCH^PRCHLO1
D PODISCW^PRCHLO1
D CLOSE^%ZISH("FILE1")
Q
POITMF ; Create flat file for PO Item data
N OUTFIL5
S OUTFIL5="IFCP"_STID_"F5.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL5,"W") ; Open the file
D USE^%ZISUTL("FILE1")
D POITEMH^PRCHLO2
D POITEMW^PRCHLO2
D CLOSE^%ZISH("FILE1")
Q
POITIVF ; Create flat file for PO Item inv. point data
N OUTFIL6
S OUTFIL6="IFCP"_STID_"F6.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL6,"W") ; Open the file
D USE^%ZISUTL("FILE1")
D POITLNH^PRCHLO2
D POITLNW^PRCHLO2
D CLOSE^%ZISH("FILE1")
Q
POITDRF ; Create flat file for PO Item date received
N OUTFIL7
S OUTFIL7="IFCP"_STID_"F7.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL7,"W") ; Open the file
D USE^%ZISUTL("FILE1")
D POITDRCH^PRCHLO2
D POITDRCW^PRCHLO2
D CLOSE^%ZISH("FILE1")
Q
PODSCF ; Create flat file for PO item description
N OUTFIL8
S OUTFIL8="IFCP"_STID_"F8.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL8,"W") ; Open the file
D USE^%ZISUTL("FILE1")
D POITDSH^PRCHLO2
D POITDSW^PRCHLO2
D CLOSE^%ZISH("FILE1")
Q
POPRTF ; Create flat file for PO Partial data
N OUTFIL9
S OUTFIL9="IFCP"_STID_"F9.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL9,"W") ; Open the file
D USE^%ZISUTL("FILE1")
D POPART^PRCHLO3
D POPARTW^PRCHLO3
D CLOSE^%ZISH("FILE1")
Q
PO2237F ; Create flat file for 2237 data
N OUTFIL10
S OUTFIL10="IFCP"_STID_"F10.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL10,"W") ; Open the file
D USE^%ZISUTL("FILE1")
D PO2237H^PRCHLO3
D PO2237W^PRCHLO3
D CLOSE^%ZISH("FILE1")
Q
POBOCF ; Create flat file for PO BOC data
N OUTFIL11
S OUTFIL11="IFCP"_STID_"F11.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL11,"W")
D USE^%ZISUTL("FILE1")
D POBOCH^PRCHLO3
D POBOCW^PRCHLO3
D CLOSE^%ZISH("FILE1")
Q
POCOMF ; Create flat file for PO Comments
N OUTFIL12
S OUTFIL12="IFCP"_STID_"F12.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL12,"W")
D USE^%ZISUTL("FILE1")
D POCMTSH^PRCHLO3
D POCMTSW^PRCHLO3
D CLOSE^%ZISH("FILE1")
Q
POREMF ; Create flat file for PO Remarks
N OUTFIL13
S OUTFIL13="IFCP"_STID_"F13.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL13,"W")
D USE^%ZISUTL("FILE1")
D PORMKH^PRCHLO3
D PORMKW^PRCHLO3
D CLOSE^%ZISH("FILE1")
Q
POPPTF ; Create flat file for PO Prompt payment terms data
N OUTFIL14
S OUTFIL14="IFCP"_STID_"F14.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL14,"W")
D USE^%ZISUTL("FILE1")
D POPPTH^PRCHLO3
D POPPTW^PRCHLO3
D CLOSE^%ZISH("FILE1")
Q
POAMTF ; Create flat file for PO Amount data
N OUTFIL15
S OUTFIL15="IFCP"_STID_"F15.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL15,"W")
D USE^%ZISUTL("FILE1")
D POAMTH^PRCHLO3
D POAMTW^PRCHLO3
D CLOSE^%ZISH("FILE1")
Q
POAMDF ; Create flat file for PO Amendment data
N OUTFIL16
S OUTFIL16="IFCP"_STID_"F16.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL16,"W")
D USE^%ZISUTL("FILE1")
D POAMDH^PRCHLO3
D POAMDW^PRCHLO3
D CLOSE^%ZISH("FILE1")
Q
POAMDCF ; Create flat file for PO Amendment changes
N OUTFIL17
S OUTFIL17="IFCP"_STID_"F17.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL17,"W")
D USE^%ZISUTL("FILE1")
D POAMDCH^PRCHLO3
D POAMDCW^PRCHLO3
D CLOSE^%ZISH("FILE1")
Q
POAMDDF ; Create flat file for PO Amendment Desc data
N OUTFIL18
S OUTFIL18="IFCP"_STID_"F18.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL18,"W")
D USE^%ZISUTL("FILE1")
D PAMDDH^PRCHLO3
D PAMDDW^PRCHLO3
D CLOSE^%ZISH("FILE1")
Q
POAMBKF ; Create flat file for PO amount breakout code
N OUTFIL19
S OUTFIL19="IFCP"_STID_"F19.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL19,"W")
D USE^%ZISUTL("FILE1")
D PAMTBKH^PRCHLO3
D PAMTBKW^PRCHLO3
D CLOSE^%ZISH("FILE1")
Q
FIL410 ; Create flat file for file 410 (Control Point Activity)
N OUTFIL20
S OUTFIL20="IFCP"_STID_"F20.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL20,"W")
D USE^%ZISUTL("FILE1")
D CONTRPH^PRCHLO3
D CONTRPW^PRCHLO3
D CLOSE^%ZISH("FILE1")
N OUTFIL21
S OUTFIL21="IFCP"_STID_"F21.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL21,"W")
D USE^%ZISUTL("FILE1")
D SUBCPH^PRCHLO3
D SUBCPW^PRCHLO3
D CLOSE^%ZISH("FILE1")
Q
FIL424 ; Create flat file for file 424 (1358 Daily Record)
N OUTFIL22
S OUTFIL22="IFCP"_STID_"F22.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL22,"W")
D USE^%ZISUTL("FILE1")
D DR1358H^PRCHLO3
D DR1358W^PRCHLO3
D CLOSE^%ZISH("FILE1")
Q
FIL4241 ;Create flat file for file 424.1 (1358 Authorization Detail)
N OUTFIL23
S OUTFIL23="IFCP"_STID_"F23.TXT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL23,"W")
D USE^%ZISUTL("FILE1")
D AD1358H^PRCHLO3
D AD1358W^PRCHLO3
D CLOSE^%ZISH("FILE1")
Q
TSTF ; Test directory for file creation
N FILEDIR,TFILE,OUTFILT,POP,STID
; POP is returned by OPEN^%ZISH if file cannot be created.
S POP=""
S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
S OUTFILT="CLRSREADME"_STID_".TXT"
S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
D OPEN^%ZISH("TFILE",FILEDIR,OUTFILT,"W")
I POP D
. S CLRSERR=2
. Q
I CLRSERR'=2 D
. D USE^%ZISUTL("TFILE")
. W !,"$ ! This directory is used to store PO activity"
. W !,"$ ! extracts and GIP Extracts which are transmitted"
. W !,"$ ! to the Clinical Logistics Report Server on a monthly"
. W !,"$ ! basis. There are 29 extract files IFCPXXXF1 through"
. W !,"$ ! IFCPXXXF27, IFCPXXXG1 and IFCPXXXG2. In addition, there"
. W !,"$ ! are 2 working files used for the FTP Transfer:"
. W !,"$ ! CLRSxxx.DAT and CLRS1xxx.COM. CLRSREADMExxx.TXT is also present"
. W !,"$ EXIT"
. D CLOSE^%ZISH("TFILE")
. Q
Q
;
CRTCOM ; Create .DAT file to transfer file(s)
N FILEDIR,POP,STID,OUTFLL1
; PRC*5.1*130 begin
N PRCHUSN,PRCHPSW
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^PRCHLO4A S CLRSERR=3 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^PRCHLO4A S CLRSERR=3 Q
S PRCHPSW=$$DECRYP^XUSRB1(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="$1$DGA2:[ANONYMOUS.CLRS]" ;set dir for outpt files.
S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
S OUTFLL1="CLRS"_STID_"FTP.DAT"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFLL1,"W")
I POP D
. S CLRSERR=3
. Q
I CLRSERR'=3 D
. D USE^%ZISUTL("FILE1")
. ; Enter user name and password for Report Server Login ; PRC*5.1*130
. W PRCHUSN,!,PRCHPSW,!
. W "SET DEFAULT /LOCAL "_FILEDIR,!
. W "PUT IFCP"_STID_"*.*;*",! ; new code to issue PUT command
. W "EXIT",! ; Exit FTP
. D CLOSE^%ZISH("FILE1")
. Q
Q
CRTCOM1 ; Run CLRSFTP1.COM as com file for exception handling
;
;*98 Modified code 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^PRCHLO4A S CLRSERR=1 Q
S OUTFLL2="CLRS"_STID_"FTP1.COM"
D OPEN^%ZISH("FILE1",FILEDIR,OUTFLL2,"W")
D USE^%ZISUTL("FILE1")
W "$ SET VERIFY=(PROCEDURE,IMAGE)",!
W "$ SET DEFAULT "_FILEDIR,!
W "$ FTP "_ADDR_" /INPUT="_FILEDIR_"CLRS"_STID_"FTP.DAT",!
;
W "$ EXIT 3",!
D CLOSE^%ZISH("FILE1")
Q
FTPCOM ; Issue the FTP command after CLRS1.TXT file is built
; remain in CACHE during FTP Process using
; $ZF(-1) call
; ; SACC Exception received for usage of $ZF(-1) in PRC*5.1*83
; See IFCAP technical manual
;
; commented out for testing
; add hook to mailman messaging for ftp, check variable PV
N PV,XPV1,FILEDIR,STID
;
;
S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
S XPV1="S PV=$ZF(-1,""@"_FILEDIR_"CLRS"_STID_"FTP1.COM/OUTPUT="_FILEDIR_"CLRS"_STID_"FTP1.LOG"")"
X XPV1 ; Run the .COM file to transfer files
;
; Error flag logic
I PV=-1 D ; This error is generated if failure during xfer occurs
. S CLRSERR=1
. Q
Q
CRTUNX1 ;PRC*5.1*172 added logic for Full Linux
; Run CLRS_STID_UNX.sh as shell script file for exception handling
;
;*98 Modified code to work with PRC CLRS ADDRESS parameter
;
N FILEDIR,STID,OUTFLL2,ADDR,CMD,FILES,HOST,PASSWD,USER
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^PRCHLO4A S CLRSERR=1 Q
S OUTFLL2="CLRS"_STID_"UNX.SH"
; add linux variables here
;
S HOST=ADDR
;
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^PRCHLO4A 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^PRCHLO4A S CLRSERR=1 Q
S PRCHPSW=$$DECRYP^XUSRB1(PRCHPSW)
S USER=PRCHUSN
S PASSWD=PRCHPSW
S FILES="IFCP*TXT"
; end adding LINUX variables
; PRC*5.1*130 end
;
D OPEN^%ZISH("FILE1",FILEDIR,OUTFLL2,"W")
D USE^%ZISUTL("FILE1")
;
; add Linux code below
W "#!/bin/bash",!
W !
W "HOST='"_HOST_"'",!
W "USER='"_USER_"'",!
W "PASSWD='"_PASSWD_"'",!
W "FILES='"_FILES_"'",!
W !
W "cd ",FILEDIR,!
W !
W "ftp -n $HOST <<END_SCRIPT",!
W "quote USER $USER",!
W "quote PASS $PASSWD",!
W "prompt",!
W "mput $FILES",!
W "quit",!
W "END_SCRIPT",!
W "exit 0",!
; W "$ EXIT 3",!
D CLOSE^%ZISH("FILE1")
; delete the test file before LINUX FTP transmission
S CMD="rm -f "
S XPV1="S PV=$ZF(-1,"""_CMD_FILEDIR_"IFCP"_STID_"TST.TXT"")"
X XPV1
Q
UNXFTP ;PRC*5.1*172 added logic for Full Linux
; Issue the FTP command after CLRS1.TXT file is built
; remain in CACHE during FTP Process using
; $ZF(-1) call
; ; SACC Exception received for usage of $ZF(-1) in PRC*5.1*83
; See IFCAP technical manual
;
; commented out for testing
; add hook to mailman messaging for ftp, check variable PV
N PV,XPV1,FILEDIR,STID
;
;
S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
S XPV1="S PV=$ZF(-1,"""_FILEDIR_"CLRS"_STID_"UNX.SH >"_FILEDIR_"UNIXFTP.LOG"")"
X XPV1 ; Run the .SH file to transfer files
;
; Error flag logic
I XPV1=-1 D ; This error is generated if failure during xfer occurs
. S CLRSERR=1
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHLO4 14177 printed Sep 23, 2025@19:44:36 Page 2
PRCHLO4 ;WOIFO/RLL/DAP-EXTRACT ROUTINE CLO REPORT SERVER ;12/30/10 15:01
+1 ;;5.1;IFCAP;**83,98,130,154,172**;Oct 20, 2000;Build 2
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ; Continuation of PRCHLO3
+4 ;
+5 ; PRCHLO3 routines are used to Write out the Header and data
+6 ; associated with each of the 29 tables created for the Clinical
+7 ; logistics Report Server. The files are built from the extracts
+8 ; located in the ^TMP($J) global.
+9 ;
+10 ;Patch PRC*5.1*172 are modifications to CLRS transmission processing
+11 ;to support those sites that have migrated to Full LINUX OS
+12 ;
+13 QUIT
GETDIR ; Get directory from System parameter for CLRS
+1 SET FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
+2 ;
+3 QUIT
CLRSFIL ; Create output files for CLRS
+1 NEW FILEDIR
+2 SET FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
+3 ; GET station id
+4 NEW STID
+5 ; S STID=$G(^DD("SITE",1)) Old call
+6 SET STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
TSTFIL ; Test entry point
+1 ;
+2 ; Po Master Data
DO POMASTF
+3 ; Po Obligation Data
DO POOBF
+4 ; PO Method of Purchase Data
DO POMETHF
+5 ; PO Discount Data
DO PODISCF
+6 ; Po Item Data
DO POITMF
+7 ; PO Item Inventory Point Data
DO POITIVF
+8 ; PO Item Desc Data
DO POITDRF
+9 ; PO Description
DO PODSCF
+10 ; PO Partial Data
DO POPRTF
+11 ; PO 2237 data
DO PO2237F
+12 ; PO BOC Data
DO POBOCF
+13 ; PO Comments data
DO POCOMF
+14 ; PO Remarks data
DO POREMF
+15 ; PO Prompt Payment Terms data
DO POPPTF
+16 ; PO Amount data
DO POAMTF
+17 ; PO Amendment Data
DO POAMDF
+18 ; PO Amendment Changes Data
DO POAMDCF
+19 ; PO Amendment Description Data
DO POAMDDF
+20 ; PO Amount Breakout Code Data
DO POAMBKF
+21 ; FILE 410
DO FIL410
+22 ; FILE 424
DO FIL424
+23 ; FILE 424.1
DO FIL4241
+24 ;File 421.5 header
DO INVHDR^PRCHLO7
+25 ;Subfile 421.531
DO INVPAY^PRCHLO7
+26 ;Subfile 421.541
DO INVFMS^PRCHLO7
+27 ;Subfile 421.51
DO INVCERT^PRCHLO7
GIPBL1 ; GIP REPORTS
+1 DO BLDGP1^PRCPLO3
+2 DO BLDGP2^PRCPLO3
+3 QUIT
POMASTF ; Save PO Master table data to a file to FTP to report Server
+1 ; build file name
+2 NEW OUTFIL1
+3 SET OUTFIL1="IFCP"_STID_"F1.TXT"
+4 ; Open the file
DO OPEN^%ZISH("FILE1",FILEDIR,OUTFIL1,"W")
+5 ; Use the file as the output device
DO USE^%ZISUTL("FILE1")
+6 ; Write the Header to the file
DO POMASTH^PRCHLO3
+7 ; Write the data to the file
DO POMASTW^PRCHLO3
+8 ; Close the file
DO CLOSE^%ZISH("FILE1")
+9 QUIT
POOBF ; Create flat file for PO OBLIGATION DATA
+1 NEW OUTFIL2
+2 SET OUTFIL2="IFCP"_STID_"F2.TXT"
+3 ; Open the file
DO OPEN^%ZISH("FILE1",FILEDIR,OUTFIL2,"W")
+4 ; Use the file as the output device
DO USE^%ZISUTL("FILE1")
+5 DO POOBHD^PRCHLO3
+6 DO POOBW^PRCHLO3
+7 ; Close the file
DO CLOSE^%ZISH("FILE1")
+8 QUIT
POMETHF ; Create flat for for Purchase Order Method
+1 NEW OUTFIL3
+2 SET OUTFIL3="IFCP"_STID_"F3.TXT"
+3 ; Open the file
DO OPEN^%ZISH("FILE1",FILEDIR,OUTFIL3,"W")
+4 ; Use the file as the output device
DO USE^%ZISUTL("FILE1")
+5 DO POPMEH^PRCHLO3
+6 DO POPMEW^PRCHLO3
+7 ; Close the file
DO CLOSE^%ZISH("FILE1")
+8 QUIT
PODISCF ; Create flat file for Purchase Order Discount
+1 NEW OUTFIL4
+2 SET OUTFIL4="IFCP"_STID_"F4.TXT"
+3 ; Open the file
DO OPEN^%ZISH("FILE1",FILEDIR,OUTFIL4,"W")
+4 DO USE^%ZISUTL("FILE1")
+5 DO PODISCH^PRCHLO1
+6 DO PODISCW^PRCHLO1
+7 DO CLOSE^%ZISH("FILE1")
+8 QUIT
POITMF ; Create flat file for PO Item data
+1 NEW OUTFIL5
+2 SET OUTFIL5="IFCP"_STID_"F5.TXT"
+3 ; Open the file
DO OPEN^%ZISH("FILE1",FILEDIR,OUTFIL5,"W")
+4 DO USE^%ZISUTL("FILE1")
+5 DO POITEMH^PRCHLO2
+6 DO POITEMW^PRCHLO2
+7 DO CLOSE^%ZISH("FILE1")
+8 QUIT
POITIVF ; Create flat file for PO Item inv. point data
+1 NEW OUTFIL6
+2 SET OUTFIL6="IFCP"_STID_"F6.TXT"
+3 ; Open the file
DO OPEN^%ZISH("FILE1",FILEDIR,OUTFIL6,"W")
+4 DO USE^%ZISUTL("FILE1")
+5 DO POITLNH^PRCHLO2
+6 DO POITLNW^PRCHLO2
+7 DO CLOSE^%ZISH("FILE1")
+8 QUIT
POITDRF ; Create flat file for PO Item date received
+1 NEW OUTFIL7
+2 SET OUTFIL7="IFCP"_STID_"F7.TXT"
+3 ; Open the file
DO OPEN^%ZISH("FILE1",FILEDIR,OUTFIL7,"W")
+4 DO USE^%ZISUTL("FILE1")
+5 DO POITDRCH^PRCHLO2
+6 DO POITDRCW^PRCHLO2
+7 DO CLOSE^%ZISH("FILE1")
+8 QUIT
PODSCF ; Create flat file for PO item description
+1 NEW OUTFIL8
+2 SET OUTFIL8="IFCP"_STID_"F8.TXT"
+3 ; Open the file
DO OPEN^%ZISH("FILE1",FILEDIR,OUTFIL8,"W")
+4 DO USE^%ZISUTL("FILE1")
+5 DO POITDSH^PRCHLO2
+6 DO POITDSW^PRCHLO2
+7 DO CLOSE^%ZISH("FILE1")
+8 QUIT
POPRTF ; Create flat file for PO Partial data
+1 NEW OUTFIL9
+2 SET OUTFIL9="IFCP"_STID_"F9.TXT"
+3 ; Open the file
DO OPEN^%ZISH("FILE1",FILEDIR,OUTFIL9,"W")
+4 DO USE^%ZISUTL("FILE1")
+5 DO POPART^PRCHLO3
+6 DO POPARTW^PRCHLO3
+7 DO CLOSE^%ZISH("FILE1")
+8 QUIT
PO2237F ; Create flat file for 2237 data
+1 NEW OUTFIL10
+2 SET OUTFIL10="IFCP"_STID_"F10.TXT"
+3 ; Open the file
DO OPEN^%ZISH("FILE1",FILEDIR,OUTFIL10,"W")
+4 DO USE^%ZISUTL("FILE1")
+5 DO PO2237H^PRCHLO3
+6 DO PO2237W^PRCHLO3
+7 DO CLOSE^%ZISH("FILE1")
+8 QUIT
POBOCF ; Create flat file for PO BOC data
+1 NEW OUTFIL11
+2 SET OUTFIL11="IFCP"_STID_"F11.TXT"
+3 DO OPEN^%ZISH("FILE1",FILEDIR,OUTFIL11,"W")
+4 DO USE^%ZISUTL("FILE1")
+5 DO POBOCH^PRCHLO3
+6 DO POBOCW^PRCHLO3
+7 DO CLOSE^%ZISH("FILE1")
+8 QUIT
POCOMF ; Create flat file for PO Comments
+1 NEW OUTFIL12
+2 SET OUTFIL12="IFCP"_STID_"F12.TXT"
+3 DO OPEN^%ZISH("FILE1",FILEDIR,OUTFIL12,"W")
+4 DO USE^%ZISUTL("FILE1")
+5 DO POCMTSH^PRCHLO3
+6 DO POCMTSW^PRCHLO3
+7 DO CLOSE^%ZISH("FILE1")
+8 QUIT
POREMF ; Create flat file for PO Remarks
+1 NEW OUTFIL13
+2 SET OUTFIL13="IFCP"_STID_"F13.TXT"
+3 DO OPEN^%ZISH("FILE1",FILEDIR,OUTFIL13,"W")
+4 DO USE^%ZISUTL("FILE1")
+5 DO PORMKH^PRCHLO3
+6 DO PORMKW^PRCHLO3
+7 DO CLOSE^%ZISH("FILE1")
+8 QUIT
POPPTF ; Create flat file for PO Prompt payment terms data
+1 NEW OUTFIL14
+2 SET OUTFIL14="IFCP"_STID_"F14.TXT"
+3 DO OPEN^%ZISH("FILE1",FILEDIR,OUTFIL14,"W")
+4 DO USE^%ZISUTL("FILE1")
+5 DO POPPTH^PRCHLO3
+6 DO POPPTW^PRCHLO3
+7 DO CLOSE^%ZISH("FILE1")
+8 QUIT
POAMTF ; Create flat file for PO Amount data
+1 NEW OUTFIL15
+2 SET OUTFIL15="IFCP"_STID_"F15.TXT"
+3 DO OPEN^%ZISH("FILE1",FILEDIR,OUTFIL15,"W")
+4 DO USE^%ZISUTL("FILE1")
+5 DO POAMTH^PRCHLO3
+6 DO POAMTW^PRCHLO3
+7 DO CLOSE^%ZISH("FILE1")
+8 QUIT
POAMDF ; Create flat file for PO Amendment data
+1 NEW OUTFIL16
+2 SET OUTFIL16="IFCP"_STID_"F16.TXT"
+3 DO OPEN^%ZISH("FILE1",FILEDIR,OUTFIL16,"W")
+4 DO USE^%ZISUTL("FILE1")
+5 DO POAMDH^PRCHLO3
+6 DO POAMDW^PRCHLO3
+7 DO CLOSE^%ZISH("FILE1")
+8 QUIT
POAMDCF ; Create flat file for PO Amendment changes
+1 NEW OUTFIL17
+2 SET OUTFIL17="IFCP"_STID_"F17.TXT"
+3 DO OPEN^%ZISH("FILE1",FILEDIR,OUTFIL17,"W")
+4 DO USE^%ZISUTL("FILE1")
+5 DO POAMDCH^PRCHLO3
+6 DO POAMDCW^PRCHLO3
+7 DO CLOSE^%ZISH("FILE1")
+8 QUIT
POAMDDF ; Create flat file for PO Amendment Desc data
+1 NEW OUTFIL18
+2 SET OUTFIL18="IFCP"_STID_"F18.TXT"
+3 DO OPEN^%ZISH("FILE1",FILEDIR,OUTFIL18,"W")
+4 DO USE^%ZISUTL("FILE1")
+5 DO PAMDDH^PRCHLO3
+6 DO PAMDDW^PRCHLO3
+7 DO CLOSE^%ZISH("FILE1")
+8 QUIT
POAMBKF ; Create flat file for PO amount breakout code
+1 NEW OUTFIL19
+2 SET OUTFIL19="IFCP"_STID_"F19.TXT"
+3 DO OPEN^%ZISH("FILE1",FILEDIR,OUTFIL19,"W")
+4 DO USE^%ZISUTL("FILE1")
+5 DO PAMTBKH^PRCHLO3
+6 DO PAMTBKW^PRCHLO3
+7 DO CLOSE^%ZISH("FILE1")
+8 QUIT
FIL410 ; Create flat file for file 410 (Control Point Activity)
+1 NEW OUTFIL20
+2 SET OUTFIL20="IFCP"_STID_"F20.TXT"
+3 DO OPEN^%ZISH("FILE1",FILEDIR,OUTFIL20,"W")
+4 DO USE^%ZISUTL("FILE1")
+5 DO CONTRPH^PRCHLO3
+6 DO CONTRPW^PRCHLO3
+7 DO CLOSE^%ZISH("FILE1")
+8 NEW OUTFIL21
+9 SET OUTFIL21="IFCP"_STID_"F21.TXT"
+10 DO OPEN^%ZISH("FILE1",FILEDIR,OUTFIL21,"W")
+11 DO USE^%ZISUTL("FILE1")
+12 DO SUBCPH^PRCHLO3
+13 DO SUBCPW^PRCHLO3
+14 DO CLOSE^%ZISH("FILE1")
+15 QUIT
FIL424 ; Create flat file for file 424 (1358 Daily Record)
+1 NEW OUTFIL22
+2 SET OUTFIL22="IFCP"_STID_"F22.TXT"
+3 DO OPEN^%ZISH("FILE1",FILEDIR,OUTFIL22,"W")
+4 DO USE^%ZISUTL("FILE1")
+5 DO DR1358H^PRCHLO3
+6 DO DR1358W^PRCHLO3
+7 DO CLOSE^%ZISH("FILE1")
+8 QUIT
FIL4241 ;Create flat file for file 424.1 (1358 Authorization Detail)
+1 NEW OUTFIL23
+2 SET OUTFIL23="IFCP"_STID_"F23.TXT"
+3 DO OPEN^%ZISH("FILE1",FILEDIR,OUTFIL23,"W")
+4 DO USE^%ZISUTL("FILE1")
+5 DO AD1358H^PRCHLO3
+6 DO AD1358W^PRCHLO3
+7 DO CLOSE^%ZISH("FILE1")
+8 QUIT
TSTF ; Test directory for file creation
+1 NEW FILEDIR,TFILE,OUTFILT,POP,STID
+2 ; POP is returned by OPEN^%ZISH if file cannot be created.
+3 SET POP=""
+4 SET STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
+5 SET OUTFILT="CLRSREADME"_STID_".TXT"
+6 SET FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
+7 DO OPEN^%ZISH("TFILE",FILEDIR,OUTFILT,"W")
+8 IF POP
Begin DoDot:1
+9 SET CLRSERR=2
+10 QUIT
End DoDot:1
+11 IF CLRSERR'=2
Begin DoDot:1
+12 DO USE^%ZISUTL("TFILE")
+13 WRITE !,"$ ! This directory is used to store PO activity"
+14 WRITE !,"$ ! extracts and GIP Extracts which are transmitted"
+15 WRITE !,"$ ! to the Clinical Logistics Report Server on a monthly"
+16 WRITE !,"$ ! basis. There are 29 extract files IFCPXXXF1 through"
+17 WRITE !,"$ ! IFCPXXXF27, IFCPXXXG1 and IFCPXXXG2. In addition, there"
+18 WRITE !,"$ ! are 2 working files used for the FTP Transfer:"
+19 WRITE !,"$ ! CLRSxxx.DAT and CLRS1xxx.COM. CLRSREADMExxx.TXT is also present"
+20 WRITE !,"$ EXIT"
+21 DO CLOSE^%ZISH("TFILE")
+22 QUIT
End DoDot:1
+23 QUIT
+24 ;
CRTCOM ; Create .DAT file to transfer file(s)
+1 NEW FILEDIR,POP,STID,OUTFLL1
+2 ; PRC*5.1*130 begin
+3 NEW PRCHUSN,PRCHPSW
+4 SET PRCHUSN=$$GET^XPAR("SYS","PRCPLO USER NAME",1,"Q")
+5 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^PRCHLO4A
SET CLRSERR=3
QUIT
+6 SET PRCHUSN=$$DECRYP^XUSRB1(PRCHUSN)
+7 SET PRCHPSW=$$GET^XPAR("SYS","PRCPLO PASSWORD",1,"Q")
+8 IF PRCHPSW=""
SET PRCPMSG(1)="There is no password identified in the CLRS PASSWORD Parameter."
SET PRCPMSG(2)="Please correct and retry."
DO MAILFTP^PRCHLO4A
SET CLRSERR=3
QUIT
+9 SET PRCHPSW=$$DECRYP^XUSRB1(PRCHPSW)
+10 ; PRC*5.1*130 end
+11 SET STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
+12 ; POP is returned by OPEN^%ZISH
SET POP=""
+13 ; S FILEDIR="$1$DGA2:[ANONYMOUS.CLRS]" ;set dir for outpt files.
+14 SET FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
+15 SET OUTFLL1="CLRS"_STID_"FTP.DAT"
+16 DO OPEN^%ZISH("FILE1",FILEDIR,OUTFLL1,"W")
+17 IF POP
Begin DoDot:1
+18 SET CLRSERR=3
+19 QUIT
End DoDot:1
+20 IF CLRSERR'=3
Begin DoDot:1
+21 DO USE^%ZISUTL("FILE1")
+22 ; Enter user name and password for Report Server Login ; PRC*5.1*130
+23 WRITE PRCHUSN,!,PRCHPSW,!
+24 WRITE "SET DEFAULT /LOCAL "_FILEDIR,!
+25 ; new code to issue PUT command
WRITE "PUT IFCP"_STID_"*.*;*",!
+26 ; Exit FTP
WRITE "EXIT",!
+27 DO CLOSE^%ZISH("FILE1")
+28 QUIT
End DoDot:1
+29 QUIT
CRTCOM1 ; Run CLRSFTP1.COM as com file for exception handling
+1 ;
+2 ;*98 Modified code to work with PRC CLRS ADDRESS parameter
+3 ;
+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^PRCHLO4A
SET CLRSERR=1
QUIT
+9 SET OUTFLL2="CLRS"_STID_"FTP1.COM"
+10 DO OPEN^%ZISH("FILE1",FILEDIR,OUTFLL2,"W")
+11 DO USE^%ZISUTL("FILE1")
+12 WRITE "$ SET VERIFY=(PROCEDURE,IMAGE)",!
+13 WRITE "$ SET DEFAULT "_FILEDIR,!
+14 WRITE "$ FTP "_ADDR_" /INPUT="_FILEDIR_"CLRS"_STID_"FTP.DAT",!
+15 ;
+16 WRITE "$ EXIT 3",!
+17 DO CLOSE^%ZISH("FILE1")
+18 QUIT
FTPCOM ; Issue the FTP command after CLRS1.TXT file is built
+1 ; remain in CACHE during FTP Process using
+2 ; $ZF(-1) call
+3 ; ; SACC Exception received for usage of $ZF(-1) in PRC*5.1*83
+4 ; See IFCAP technical manual
+5 ;
+6 ; commented out for testing
+7 ; add hook to mailman messaging for ftp, check variable PV
+8 NEW PV,XPV1,FILEDIR,STID
+9 ;
+10 ;
+11 SET FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
+12 SET STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
+13 SET XPV1="S PV=$ZF(-1,""@"_FILEDIR_"CLRS"_STID_"FTP1.COM/OUTPUT="_FILEDIR_"CLRS"_STID_"FTP1.LOG"")"
+14 ; Run the .COM file to transfer files
XECUTE XPV1
+15 ;
+16 ; Error flag logic
+17 ; This error is generated if failure during xfer occurs
IF PV=-1
Begin DoDot:1
+18 SET CLRSERR=1
+19 QUIT
End DoDot:1
+20 QUIT
CRTUNX1 ;PRC*5.1*172 added logic for Full Linux
+1 ; Run CLRS_STID_UNX.sh as shell script file for exception handling
+2 ;
+3 ;*98 Modified code to work with PRC CLRS ADDRESS parameter
+4 ;
+5 NEW FILEDIR,STID,OUTFLL2,ADDR,CMD,FILES,HOST,PASSWD,USER
+6 SET STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
+7 SET FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
+8 SET ADDR=$$GET^XPAR("SYS","PRC CLRS ADDRESS",1,"Q")
+9 IF ADDR=""
SET PRCPMSG(1)="There is no address identified in the CLRS Address Parameter."
SET PRCPMSG(2)="Please correct and retry."
DO MAILFTP^PRCHLO4A
SET CLRSERR=1
QUIT
+10 SET OUTFLL2="CLRS"_STID_"UNX.SH"
+11 ; add linux variables here
+12 ;
+13 SET HOST=ADDR
+14 ;
+15 SET PRCHUSN=$$GET^XPAR("SYS","PRCPLO USER NAME",1,"Q")
+16 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^PRCHLO4A
SET CLRSERR=1
QUIT
+17 SET PRCHUSN=$$DECRYP^XUSRB1(PRCHUSN)
+18 SET PRCHPSW=$$GET^XPAR("SYS","PRCPLO PASSWORD",1,"Q")
+19 IF PRCHPSW=""
SET PRCPMSG(1)="There is no password identified in the CLRS PASSWORD Parameter."
SET PRCPMSG(2)="Please correct and retry."
DO MAILFTP^PRCHLO4A
SET CLRSERR=1
QUIT
+20 SET PRCHPSW=$$DECRYP^XUSRB1(PRCHPSW)
+21 SET USER=PRCHUSN
+22 SET PASSWD=PRCHPSW
+23 SET FILES="IFCP*TXT"
+24 ; end adding LINUX variables
+25 ; PRC*5.1*130 end
+26 ;
+27 DO OPEN^%ZISH("FILE1",FILEDIR,OUTFLL2,"W")
+28 DO USE^%ZISUTL("FILE1")
+29 ;
+30 ; add Linux code below
+31 WRITE "#!/bin/bash",!
+32 WRITE !
+33 WRITE "HOST='"_HOST_"'",!
+34 WRITE "USER='"_USER_"'",!
+35 WRITE "PASSWD='"_PASSWD_"'",!
+36 WRITE "FILES='"_FILES_"'",!
+37 WRITE !
+38 WRITE "cd ",FILEDIR,!
+39 WRITE !
+40 WRITE "ftp -n $HOST <<END_SCRIPT",!
+41 WRITE "quote USER $USER",!
+42 WRITE "quote PASS $PASSWD",!
+43 WRITE "prompt",!
+44 WRITE "mput $FILES",!
+45 WRITE "quit",!
+46 WRITE "END_SCRIPT",!
+47 WRITE "exit 0",!
+48 ; W "$ EXIT 3",!
+49 DO CLOSE^%ZISH("FILE1")
+50 ; delete the test file before LINUX FTP transmission
+51 SET CMD="rm -f "
+52 SET XPV1="S PV=$ZF(-1,"""_CMD_FILEDIR_"IFCP"_STID_"TST.TXT"")"
+53 XECUTE XPV1
+54 QUIT
UNXFTP ;PRC*5.1*172 added logic for Full Linux
+1 ; Issue the FTP command after CLRS1.TXT file is built
+2 ; remain in CACHE during FTP Process using
+3 ; $ZF(-1) call
+4 ; ; SACC Exception received for usage of $ZF(-1) in PRC*5.1*83
+5 ; See IFCAP technical manual
+6 ;
+7 ; commented out for testing
+8 ; add hook to mailman messaging for ftp, check variable PV
+9 NEW PV,XPV1,FILEDIR,STID
+10 ;
+11 ;
+12 SET FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
+13 SET STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
+14 SET XPV1="S PV=$ZF(-1,"""_FILEDIR_"CLRS"_STID_"UNX.SH >"_FILEDIR_"UNIXFTP.LOG"")"
+15 ; Run the .SH file to transfer files
XECUTE XPV1
+16 ;
+17 ; Error flag logic
+18 ; This error is generated if failure during xfer occurs
IF XPV1=-1
Begin DoDot:1
+19 SET CLRSERR=1
+20 QUIT
End DoDot:1
+21 QUIT
