BAREISS ; IHS/SD/LSL - EISS data, file, send ;08/20/2008
;;1.8;IHS ACCOUNTS RECEIVABLE;**7**;OCT 26, 2005
; MODIFIED XTMP FILE NAME TO TMP TO MEET SAC REQUIREMENTS;MRS:BAR*1.8*7 IM29892
; IHS/SD/LSL - 02/20/03 - V1.7 Patch 2
; Routine created to gather ASM and PSR data, create files, and
; send them to the to ARMS Server where WEB team can access them.
; The call is executed only if user chooses summary report by
; Allowance Category for all Allowance Categories. BARY("STCR")=5
; and '$D(BARY("ALL")) and BARY("RTYP")=1
;
; IHS/SD/LSL - 11/04/03 - V1.7 Patch 4
; Ensure that the time portion of run date is 6 characters.
;
; IHS/SD/SLS - 11/25/03 - V1.7 Patch 4
; Modify ASM to include Visit Locations
Q
; ********************************************************************
; Make sure 4 entries created in ZISH SEND PARAMETERS FILE
; AR Version 1.8 populate initially.
;
; 1. For PSR report - not queued
; Entry name = BAR EISS PSR F
; Target System ID = 127.0.0.1
; Username = bardata
; Password = 1bardat/
; Arguments = -i (immediate mode - otherwise ftp delay)
; Foreground/Background = F
; Send Command = sendto
;
; 2. For PSR report - queued
; Entry name = BAR EISS PSR B
; Target System ID = 127.0.0.1
; Username = bardata
; Password = 1bardat/
; Arguments = -i (immediate mode - otherwise ftp delay)
; Foreground/Background = B
; Send Command = sendto
;
; 3. For ASM report - not queued
; Entry name = BAR EISS ASM F
; Target System ID = 127.0.0.1
; Username = bardata
; Password = 1bardat/
; Arguments = -i (immediate mode - otherwise ftp delay)
; Foreground/Background = F
; Send Command = sendto
;
; 4. For ASM report - queued
; Entry name = BAR EISS ASM B
; Target System ID = 127.0.0.1
; Username = bardata
; Password = 1bardat/
; Arguments = -i (immediate mode - otherwise ftp delay)
; Foreground/Background = B
; Send Command = sendto
;
; *********************************************************************
; EISS File naming convention:
;
; ___A__|__B__|___C___|___D___|______E______F|__G__|_H_
; BARPSR202101200307012003073120030728155600_000010.TXT
;
; Position Description
;
; A 1-6 NAMESPACE_RPT (BARPSR)
; B 7-12 ASUFAC (if null send "XXXXXX")
; C 13-20 BEGIN DATE OF DATA (YYYYMMDD)
; D 21-28 END DATE OF DATA (YYYYMMDD)
; E 29-42 RUN DATE (YYYYMMDDHHMMSS)
; F 43 SPACER (_)
; G 44-49 RECORD COUNT, RIGHT JUSTIFY, O FILL
; H 50-53 FILE EXTENTSION (.TXT)
; ********************************************************************
;
PSR ; EP
; Called from SUMMARY^BARRPSRB after Summary report is done printing.
; ------------------------------------------------------------------
; Filename ex: BARPSR202101200307012003073120030728155600_000010.TXT
;
; File layout
;
; Piece # Description
;
; 1 Unique RPMS DB ID (if null, send "-1")
; 2 ASUFAC (if null, send "?")
; 3 Visit Location (if unkown, send "No visit location")
; 4 Allowance Category
; 5 Billed Amount (no formatting)
; 6 Payment Amount (no formatting)
; 7 Adjustment Amount(no formatting)
; 8 Refund Amount (no formatting)
;
; ^TMP($J,"BAR-PSR-EISS",line count)=1^2^3^4^5^6^7^8
;-------------------------------------------------------------------
; Obtain top level variables
;
; BARY("DT",1) set in BARRPSRA (FM Date) ; Begin date of data
; BARY("DT",2) set in BARRPSRA (FM Date) ; End date of data
N BARPNUM,BARRDT,BARRD,BARUNDT,BARCNT,BARVLOC,BARCAT,BARHLD,BARVDUZ
N BARDBID,BARVNUM,BARFN,BARTMP
N XBFN,XBGL,XBFLT,XBMED,XBNAR,XBQTO,XBUF
S BARTMP=0
F S BARTMP=$O(^BAREISS1(BARTMP)) Q:'+BARTMP K ^BAREISS1(BARTMP)
K BARTMP
D INIT ; set common vars
;
; -------------------------------
; Build ^BAREISS1 global of data
S BARVLOC=""
F S BARVLOC=$O(^TMP($J,"BAR-PSRT",BARVLOC)) Q:BARVLOC="" D
. S BARVDUZ=$P($G(^TMP($J,"BAR-PSRT",BARVLOC)),U,5)
. S BARCAT=""
. F S BARCAT=$O(^TMP($J,"BAR-PSRT",BARVLOC,BARCAT)) Q:BARCAT="" D
. . S BARCNT=BARCNT+1
. . S (BARDBID,BARVNUM)=""
. . S BARHLD=$G(^TMP($J,"BAR-PSRT",BARVLOC,BARCAT))
. . I +BARVDUZ D
. . . S BARDBID=$P($G(^AUTTLOC(BARVDUZ,1)),U,3)
. . . S BARVNUM=$P($G(^AUTTLOC(BARVDUZ,0)),U,10)
. . S $P(^BAREISS1($J,"BAR-PSR-EISS",BARCNT),U)=$S(BARDBID="":"-1",1:BARDBID)
. . S $P(^BAREISS1($J,"BAR-PSR-EISS",BARCNT),U,2)=$S(BARVNUM="":"?",1:BARVNUM)
. . S $P(^BAREISS1($J,"BAR-PSR-EISS",BARCNT),U,3)=BARVLOC
. . S $P(^BAREISS1($J,"BAR-PSR-EISS",BARCNT),U,4)=BARCAT
. . S $P(^BAREISS1($J,"BAR-PSR-EISS",BARCNT),U,5)=$P(BARHLD,U)
. . S $P(^BAREISS1($J,"BAR-PSR-EISS",BARCNT),U,6)=$P(BARHLD,U,2)
. . S $P(^BAREISS1($J,"BAR-PSR-EISS",BARCNT),U,7)=$P(BARHLD,U,3)
. . S $P(^BAREISS1($J,"BAR-PSR-EISS",BARCNT),U,8)=$P(BARHLD,U,4)
S BARCNT="000000"_BARCNT
S BARCNT=$E(BARCNT,$L(BARCNT)-5,$L(BARCNT)) ; zero fill to 6 digit
S XBFN="BARPSR"
D FILE
Q
;*********************************************************************
;
ASM ; EP
;
; Called from SUMMARY^BARRASM after Summary report is done printing.
; ------------------------------------------------------------------
; Filename ex: BARASM202101000000002003073120030731115200_000005.TXT
;
; File layout
;
; Piece # Description
;
; 1 Unique RPMS DB ID (if null, send "-1") - of visit location
; 2 ASUFAC (if null, send "?") - of visit location
; 3 Visit Location (if unkown, send "No visit location")
; 4 Allowance Category
; 5 Current Balance (no formatting)
; 6 Aged 31-60 Balance (no formatting)
; 7 Aged 61-90 Balance (no formatting)
; 8 Aged 91-120 Balance (no formatting)
; 9 Aged >120 Balance (no formatting)
; 10 Total balance for category (no formatting)
;
; ^TMP($J,"BAR-ASM-EISS",line count)=1^2^3^4^5^6^7^8^9^10^11
;-------------------------------------------------------------------
; Obtain top level variables
;
N BARPNUM,BARRDT,BARRD,BARUNDT,BARCNT,BARVLOC,BARCAT,BARHLD,BARVDUZ
N BARDBID,BARVNUM,BARFN,BARFLG
N XBFN,XBGL,XBFLT,XBMED,XBNAR,XBQTO,XBUF
S BARTMP=0
F S BARTMP=$O(^BAREISS2(BARTMP)) Q:'+BARTMP K ^BAREISS2(BARTMP)
K BARTMP
D INIT ; Set common vars
S BARY("DT",2)=DT ; End date of data
;
; -------------------------------
; Build ^BAREISS2 global of data
S BARVLOC=""
F S BARVLOC=$O(^TMP($J,"BAR-ASMT",BARVLOC)) Q:BARVLOC="" D
. S BARVDUZ=$P($G(^TMP($J,"BAR-ASMT",BARVLOC)),U,7)
. S BARCAT=""
. F S BARCAT=$O(^TMP($J,"BAR-ASMT",BARVLOC,BARCAT)) Q:BARCAT="" D
. . S BARCNT=BARCNT+1
. . S (BARDBID,BARVNUM)=""
. . I +BARVDUZ D
. . . S BARDBID=$P($G(^AUTTLOC(BARVDUZ,1)),U,3)
. . . S BARVNUM=$P($G(^AUTTLOC(BARVDUZ,0)),U,10)
. . S BARHLD=$G(^TMP($J,"BAR-ASMT",BARVLOC,BARCAT))
. . S $P(^BAREISS2($J,"BAR-ASM-EISS",BARCNT),U)=$S(BARDBID="":"-1",1:BARDBID)
. . S $P(^BAREISS2($J,"BAR-ASM-EISS",BARCNT),U,2)=$S(BARVNUM="":"?",1:BARVNUM)
. . S $P(^BAREISS2($J,"BAR-ASM-EISS",BARCNT),U,3)=BARVLOC
. . S $P(^BAREISS2($J,"BAR-ASM-EISS",BARCNT),U,4)=BARCAT
. . S $P(^BAREISS2($J,"BAR-ASM-EISS",BARCNT),U,5)=$P(BARHLD,U)
. . S $P(^BAREISS2($J,"BAR-ASM-EISS",BARCNT),U,6)=$P(BARHLD,U,2)
. . S $P(^BAREISS2($J,"BAR-ASM-EISS",BARCNT),U,7)=$P(BARHLD,U,3)
. . S $P(^BAREISS2($J,"BAR-ASM-EISS",BARCNT),U,8)=$P(BARHLD,U,4)
. . S $P(^BAREISS2($J,"BAR-ASM-EISS",BARCNT),U,9)=$P(BARHLD,U,5)
. . S $P(^BAREISS2($J,"BAR-ASM-EISS",BARCNT),U,10)=$P(BARHLD,U,6)
S BARCNT="000000"_BARCNT
S BARCNT=$E(BARCNT,$L(BARCNT)-5,$L(BARCNT)) ; zero fill to 6 digit
S XBFN="BARASM"
D FILE
Q
; ********************************************************************
;
INIT ;
; Top level variables.
S BARPNUM=$P($G(^AUTTLOC(DUZ(2),0)),U,10) ; Parent ASUFAC
S:BARPNUM="" BARPNUM="XXXXXX" ; If null, send XXXXXX
I $L(BARPNUM)<6 D
. S BARPNUM="000000"_BARPNUM
. S BARPNUM=$E(BARPNUM,$L(BARPNUM)-5,$L(BARPNUM)) ; zero fill to 6
D NOW^%DTC
S BARRDT=%
S BARRD=$$Y2KD2^BARDUTL(BARRDT)
S BARUNDT=BARRD_$P(BARRDT,".",2) ; Run date/time
I $L(BARUNDT)<14 D
. S BARTMP=$L(BARUNDT)
. F I=BARTMP+1:1:14 S BARUNDT=BARUNDT_"0"
S BARCNT=0 ; Initialize rec cnt
I $D(IO("S")),$$VERSION^%ZOSV(1)["UNIX" D ^%ZISC ; close slave
Q
; ********************************************************************
;
FILE ;
; Create Filename
S XBFN=XBFN_BARPNUM
S XBFN=XBFN_$S($D(BARY("DT",1)):$$Y2KD2^BARDUTL(BARY("DT",1)),1:"00000000")
S XBFN=XBFN_$$Y2KD2^BARDUTL(BARY("DT",2))
S XBFN=XBFN_BARUNDT
S XBFN=XBFN_"_"
S XBFN=XBFN_BARCNT
S XBFN=XBFN_".TXT" ; Filename to create
S BARFN=XBFN ; AR 1.8
;
; -------------------------------
; Create file and send to EISS
S BAREISS=$G(^BAR(90052.06,DUZ(2),DUZ(2),2))
S XBQSHO=""
S XBGL="BAREISS2(" ; ASM default
; NEW AUTO FTP **********
S XBS1="BAR EISS ASM F"
I $D(ZTQUEUED) S XBS1="BAR EISS ASM B"
;I $E(XBFN,4,6)="PSR" S XBGL="BAREISS1("
I $E(XBFN,4,6)="PSR" D
. S XBGL="BAREISS1("
. S XBS1="BAR EISS PSR F"
. I $D(ZTQUEUED) S XBS1="BAR EISS PSR B"
S XBQ="N" ; so won't do old send code in ZIBSGVEM/P
; END AUTO FTP ***************
S XBF=$J ; Beginning 1st level numeric subscript
S XBE=$J ; Ending 1st level numeric subscript
S XBFLT=1 ; indicates flat file
S XBMED="F" ; Flag indicates file as media
S XBCON=1 ; Q if non-cononic
S XBUF=$P(BAREISS,U,4) ; Local directory for file creation
; NEW AUTO FTP ****************
;S BARUNAM=$P(BAREISS,U,2) ; Username of system receiving file
;S BARUPASS=$P(BAREISS,U,3) ; Password of system receiving file
;S XBQTO=$P(BAREISS,U) ; System id to receive file
; Include username and password in system id
; Add i to XBQTO to send immediately rather than queue. Needed so can
; delete sent files. (A/R 1.8)
;S XBQTO="-il """_BARUNAM_":"_BARUPASS_""" "_XBQTO
;I XBUF=""!(BARUNAM="")!(BARUPASS="")!(XBQTO="") Q
I XBUF="" Q
I '$D(XBS1) Q
; END AUTO FTP *****************************
I IO=IO(0) W !!
D ^XBGSAVE
; Coding change A/R 1.8 - next 5 lines
Q:+XBFLG ; Send not successful
; delete file from local, send successful
H 10 ; try to make sure file at recieving system before deleting
S BARDIR=$P(BAREISS,U,4)
S BARDEL=$$DEL^%ZISH(BARDIR,BARFN)
Q
BAREISS ; IHS/SD/LSL - EISS data, file, send ;08/20/2008
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**7**;OCT 26, 2005
+2 ; MODIFIED XTMP FILE NAME TO TMP TO MEET SAC REQUIREMENTS;MRS:BAR*1.8*7 IM29892
+3 ; IHS/SD/LSL - 02/20/03 - V1.7 Patch 2
+4 ; Routine created to gather ASM and PSR data, create files, and
+5 ; send them to the to ARMS Server where WEB team can access them.
+6 ; The call is executed only if user chooses summary report by
+7 ; Allowance Category for all Allowance Categories. BARY("STCR")=5
+8 ; and '$D(BARY("ALL")) and BARY("RTYP")=1
+9 ;
+10 ; IHS/SD/LSL - 11/04/03 - V1.7 Patch 4
+11 ; Ensure that the time portion of run date is 6 characters.
+12 ;
+13 ; IHS/SD/SLS - 11/25/03 - V1.7 Patch 4
+14 ; Modify ASM to include Visit Locations
+15 QUIT
+16 ; ********************************************************************
+17 ; Make sure 4 entries created in ZISH SEND PARAMETERS FILE
+18 ; AR Version 1.8 populate initially.
+19 ;
+20 ; 1. For PSR report - not queued
+21 ; Entry name = BAR EISS PSR F
+22 ; Target System ID = 127.0.0.1
+23 ; Username = bardata
+24 ; Password = 1bardat/
+25 ; Arguments = -i (immediate mode - otherwise ftp delay)
+26 ; Foreground/Background = F
+27 ; Send Command = sendto
+28 ;
+29 ; 2. For PSR report - queued
+30 ; Entry name = BAR EISS PSR B
+31 ; Target System ID = 127.0.0.1
+32 ; Username = bardata
+33 ; Password = 1bardat/
+34 ; Arguments = -i (immediate mode - otherwise ftp delay)
+35 ; Foreground/Background = B
+36 ; Send Command = sendto
+37 ;
+38 ; 3. For ASM report - not queued
+39 ; Entry name = BAR EISS ASM F
+40 ; Target System ID = 127.0.0.1
+41 ; Username = bardata
+42 ; Password = 1bardat/
+43 ; Arguments = -i (immediate mode - otherwise ftp delay)
+44 ; Foreground/Background = F
+45 ; Send Command = sendto
+46 ;
+47 ; 4. For ASM report - queued
+48 ; Entry name = BAR EISS ASM B
+49 ; Target System ID = 127.0.0.1
+50 ; Username = bardata
+51 ; Password = 1bardat/
+52 ; Arguments = -i (immediate mode - otherwise ftp delay)
+53 ; Foreground/Background = B
+54 ; Send Command = sendto
+55 ;
+56 ; *********************************************************************
+57 ; EISS File naming convention:
+58 ;
+59 ; ___A__|__B__|___C___|___D___|______E______F|__G__|_H_
+60 ; BARPSR202101200307012003073120030728155600_000010.TXT
+61 ;
+62 ; Position Description
+63 ;
+64 ; A 1-6 NAMESPACE_RPT (BARPSR)
+65 ; B 7-12 ASUFAC (if null send "XXXXXX")
+66 ; C 13-20 BEGIN DATE OF DATA (YYYYMMDD)
+67 ; D 21-28 END DATE OF DATA (YYYYMMDD)
+68 ; E 29-42 RUN DATE (YYYYMMDDHHMMSS)
+69 ; F 43 SPACER (_)
+70 ; G 44-49 RECORD COUNT, RIGHT JUSTIFY, O FILL
+71 ; H 50-53 FILE EXTENTSION (.TXT)
+72 ; ********************************************************************
+73 ;
PSR ; EP
+1 ; Called from SUMMARY^BARRPSRB after Summary report is done printing.
+2 ; ------------------------------------------------------------------
+3 ; Filename ex: BARPSR202101200307012003073120030728155600_000010.TXT
+4 ;
+5 ; File layout
+6 ;
+7 ; Piece # Description
+8 ;
+9 ; 1 Unique RPMS DB ID (if null, send "-1")
+10 ; 2 ASUFAC (if null, send "?")
+11 ; 3 Visit Location (if unkown, send "No visit location")
+12 ; 4 Allowance Category
+13 ; 5 Billed Amount (no formatting)
+14 ; 6 Payment Amount (no formatting)
+15 ; 7 Adjustment Amount(no formatting)
+16 ; 8 Refund Amount (no formatting)
+17 ;
+18 ; ^TMP($J,"BAR-PSR-EISS",line count)=1^2^3^4^5^6^7^8
+19 ;-------------------------------------------------------------------
+20 ; Obtain top level variables
+21 ;
+22 ; BARY("DT",1) set in BARRPSRA (FM Date) ; Begin date of data
+23 ; BARY("DT",2) set in BARRPSRA (FM Date) ; End date of data
+24 NEW BARPNUM,BARRDT,BARRD,BARUNDT,BARCNT,BARVLOC,BARCAT,BARHLD,BARVDUZ
+25 NEW BARDBID,BARVNUM,BARFN,BARTMP
+26 NEW XBFN,XBGL,XBFLT,XBMED,XBNAR,XBQTO,XBUF
+27 SET BARTMP=0
+28 FOR
SET BARTMP=$ORDER(^BAREISS1(BARTMP))
IF '+BARTMP
QUIT
KILL ^BAREISS1(BARTMP)
+29 KILL BARTMP
+30 ; set common vars
DO INIT
+31 ;
+32 ; -------------------------------
+33 ; Build ^BAREISS1 global of data
+34 SET BARVLOC=""
+35 FOR
SET BARVLOC=$ORDER(^TMP($JOB,"BAR-PSRT",BARVLOC))
IF BARVLOC=""
QUIT
Begin DoDot:1
+36 SET BARVDUZ=$PIECE($GET(^TMP($JOB,"BAR-PSRT",BARVLOC)),U,5)
+37 SET BARCAT=""
+38 FOR
SET BARCAT=$ORDER(^TMP($JOB,"BAR-PSRT",BARVLOC,BARCAT))
IF BARCAT=""
QUIT
Begin DoDot:2
+39 SET BARCNT=BARCNT+1
+40 SET (BARDBID,BARVNUM)=""
+41 SET BARHLD=$GET(^TMP($JOB,"BAR-PSRT",BARVLOC,BARCAT))
+42 IF +BARVDUZ
Begin DoDot:3
+43 SET BARDBID=$PIECE($GET(^AUTTLOC(BARVDUZ,1)),U,3)
+44 SET BARVNUM=$PIECE($GET(^AUTTLOC(BARVDUZ,0)),U,10)
End DoDot:3
+45 SET $PIECE(^BAREISS1($JOB,"BAR-PSR-EISS",BARCNT),U)=$SELECT(BARDBID="":"-1",1:BARDBID)
+46 SET $PIECE(^BAREISS1($JOB,"BAR-PSR-EISS",BARCNT),U,2)=$SELECT(BARVNUM="":"?",1:BARVNUM)
+47 SET $PIECE(^BAREISS1($JOB,"BAR-PSR-EISS",BARCNT),U,3)=BARVLOC
+48 SET $PIECE(^BAREISS1($JOB,"BAR-PSR-EISS",BARCNT),U,4)=BARCAT
+49 SET $PIECE(^BAREISS1($JOB,"BAR-PSR-EISS",BARCNT),U,5)=$PIECE(BARHLD,U)
+50 SET $PIECE(^BAREISS1($JOB,"BAR-PSR-EISS",BARCNT),U,6)=$PIECE(BARHLD,U,2)
+51 SET $PIECE(^BAREISS1($JOB,"BAR-PSR-EISS",BARCNT),U,7)=$PIECE(BARHLD,U,3)
+52 SET $PIECE(^BAREISS1($JOB,"BAR-PSR-EISS",BARCNT),U,8)=$PIECE(BARHLD,U,4)
End DoDot:2
End DoDot:1
+53 SET BARCNT="000000"_BARCNT
+54 ; zero fill to 6 digit
SET BARCNT=$EXTRACT(BARCNT,$LENGTH(BARCNT)-5,$LENGTH(BARCNT))
+55 SET XBFN="BARPSR"
+56 DO FILE
+57 QUIT
+58 ;*********************************************************************
+59 ;
ASM ; EP
+1 ;
+2 ; Called from SUMMARY^BARRASM after Summary report is done printing.
+3 ; ------------------------------------------------------------------
+4 ; Filename ex: BARASM202101000000002003073120030731115200_000005.TXT
+5 ;
+6 ; File layout
+7 ;
+8 ; Piece # Description
+9 ;
+10 ; 1 Unique RPMS DB ID (if null, send "-1") - of visit location
+11 ; 2 ASUFAC (if null, send "?") - of visit location
+12 ; 3 Visit Location (if unkown, send "No visit location")
+13 ; 4 Allowance Category
+14 ; 5 Current Balance (no formatting)
+15 ; 6 Aged 31-60 Balance (no formatting)
+16 ; 7 Aged 61-90 Balance (no formatting)
+17 ; 8 Aged 91-120 Balance (no formatting)
+18 ; 9 Aged >120 Balance (no formatting)
+19 ; 10 Total balance for category (no formatting)
+20 ;
+21 ; ^TMP($J,"BAR-ASM-EISS",line count)=1^2^3^4^5^6^7^8^9^10^11
+22 ;-------------------------------------------------------------------
+23 ; Obtain top level variables
+24 ;
+25 NEW BARPNUM,BARRDT,BARRD,BARUNDT,BARCNT,BARVLOC,BARCAT,BARHLD,BARVDUZ
+26 NEW BARDBID,BARVNUM,BARFN,BARFLG
+27 NEW XBFN,XBGL,XBFLT,XBMED,XBNAR,XBQTO,XBUF
+28 SET BARTMP=0
+29 FOR
SET BARTMP=$ORDER(^BAREISS2(BARTMP))
IF '+BARTMP
QUIT
KILL ^BAREISS2(BARTMP)
+30 KILL BARTMP
+31 ; Set common vars
DO INIT
+32 ; End date of data
SET BARY("DT",2)=DT
+33 ;
+34 ; -------------------------------
+35 ; Build ^BAREISS2 global of data
+36 SET BARVLOC=""
+37 FOR
SET BARVLOC=$ORDER(^TMP($JOB,"BAR-ASMT",BARVLOC))
IF BARVLOC=""
QUIT
Begin DoDot:1
+38 SET BARVDUZ=$PIECE($GET(^TMP($JOB,"BAR-ASMT",BARVLOC)),U,7)
+39 SET BARCAT=""
+40 FOR
SET BARCAT=$ORDER(^TMP($JOB,"BAR-ASMT",BARVLOC,BARCAT))
IF BARCAT=""
QUIT
Begin DoDot:2
+41 SET BARCNT=BARCNT+1
+42 SET (BARDBID,BARVNUM)=""
+43 IF +BARVDUZ
Begin DoDot:3
+44 SET BARDBID=$PIECE($GET(^AUTTLOC(BARVDUZ,1)),U,3)
+45 SET BARVNUM=$PIECE($GET(^AUTTLOC(BARVDUZ,0)),U,10)
End DoDot:3
+46 SET BARHLD=$GET(^TMP($JOB,"BAR-ASMT",BARVLOC,BARCAT))
+47 SET $PIECE(^BAREISS2($JOB,"BAR-ASM-EISS",BARCNT),U)=$SELECT(BARDBID="":"-1",1:BARDBID)
+48 SET $PIECE(^BAREISS2($JOB,"BAR-ASM-EISS",BARCNT),U,2)=$SELECT(BARVNUM="":"?",1:BARVNUM)
+49 SET $PIECE(^BAREISS2($JOB,"BAR-ASM-EISS",BARCNT),U,3)=BARVLOC
+50 SET $PIECE(^BAREISS2($JOB,"BAR-ASM-EISS",BARCNT),U,4)=BARCAT
+51 SET $PIECE(^BAREISS2($JOB,"BAR-ASM-EISS",BARCNT),U,5)=$PIECE(BARHLD,U)
+52 SET $PIECE(^BAREISS2($JOB,"BAR-ASM-EISS",BARCNT),U,6)=$PIECE(BARHLD,U,2)
+53 SET $PIECE(^BAREISS2($JOB,"BAR-ASM-EISS",BARCNT),U,7)=$PIECE(BARHLD,U,3)
+54 SET $PIECE(^BAREISS2($JOB,"BAR-ASM-EISS",BARCNT),U,8)=$PIECE(BARHLD,U,4)
+55 SET $PIECE(^BAREISS2($JOB,"BAR-ASM-EISS",BARCNT),U,9)=$PIECE(BARHLD,U,5)
+56 SET $PIECE(^BAREISS2($JOB,"BAR-ASM-EISS",BARCNT),U,10)=$PIECE(BARHLD,U,6)
End DoDot:2
End DoDot:1
+57 SET BARCNT="000000"_BARCNT
+58 ; zero fill to 6 digit
SET BARCNT=$EXTRACT(BARCNT,$LENGTH(BARCNT)-5,$LENGTH(BARCNT))
+59 SET XBFN="BARASM"
+60 DO FILE
+61 QUIT
+62 ; ********************************************************************
+63 ;
INIT ;
+1 ; Top level variables.
+2 ; Parent ASUFAC
SET BARPNUM=$PIECE($GET(^AUTTLOC(DUZ(2),0)),U,10)
+3 ; If null, send XXXXXX
IF BARPNUM=""
SET BARPNUM="XXXXXX"
+4 IF $LENGTH(BARPNUM)<6
Begin DoDot:1
+5 SET BARPNUM="000000"_BARPNUM
+6 ; zero fill to 6
SET BARPNUM=$EXTRACT(BARPNUM,$LENGTH(BARPNUM)-5,$LENGTH(BARPNUM))
End DoDot:1
+7 DO NOW^%DTC
+8 SET BARRDT=%
+9 SET BARRD=$$Y2KD2^BARDUTL(BARRDT)
+10 ; Run date/time
SET BARUNDT=BARRD_$PIECE(BARRDT,".",2)
+11 IF $LENGTH(BARUNDT)<14
Begin DoDot:1
+12 SET BARTMP=$LENGTH(BARUNDT)
+13 FOR I=BARTMP+1:1:14
SET BARUNDT=BARUNDT_"0"
End DoDot:1
+14 ; Initialize rec cnt
SET BARCNT=0
+15 ; close slave
IF $DATA(IO("S"))
IF $$VERSION^%ZOSV(1)["UNIX"
DO ^%ZISC
+16 QUIT
+17 ; ********************************************************************
+18 ;
FILE ;
+1 ; Create Filename
+2 SET XBFN=XBFN_BARPNUM
+3 SET XBFN=XBFN_$SELECT($DATA(BARY("DT",1)):$$Y2KD2^BARDUTL(BARY("DT",1)),1:"00000000")
+4 SET XBFN=XBFN_$$Y2KD2^BARDUTL(BARY("DT",2))
+5 SET XBFN=XBFN_BARUNDT
+6 SET XBFN=XBFN_"_"
+7 SET XBFN=XBFN_BARCNT
+8 ; Filename to create
SET XBFN=XBFN_".TXT"
+9 ; AR 1.8
SET BARFN=XBFN
+10 ;
+11 ; -------------------------------
+12 ; Create file and send to EISS
+13 SET BAREISS=$GET(^BAR(90052.06,DUZ(2),DUZ(2),2))
+14 SET XBQSHO=""
+15 ; ASM default
SET XBGL="BAREISS2("
+16 ; NEW AUTO FTP **********
+17 SET XBS1="BAR EISS ASM F"
+18 IF $DATA(ZTQUEUED)
SET XBS1="BAR EISS ASM B"
+19 ;I $E(XBFN,4,6)="PSR" S XBGL="BAREISS1("
+20 IF $EXTRACT(XBFN,4,6)="PSR"
Begin DoDot:1
+21 SET XBGL="BAREISS1("
+22 SET XBS1="BAR EISS PSR F"
+23 IF $DATA(ZTQUEUED)
SET XBS1="BAR EISS PSR B"
End DoDot:1
+24 ; so won't do old send code in ZIBSGVEM/P
SET XBQ="N"
+25 ; END AUTO FTP ***************
+26 ; Beginning 1st level numeric subscript
SET XBF=$JOB
+27 ; Ending 1st level numeric subscript
SET XBE=$JOB
+28 ; indicates flat file
SET XBFLT=1
+29 ; Flag indicates file as media
SET XBMED="F"
+30 ; Q if non-cononic
SET XBCON=1
+31 ; Local directory for file creation
SET XBUF=$PIECE(BAREISS,U,4)
+32 ; NEW AUTO FTP ****************
+33 ;S BARUNAM=$P(BAREISS,U,2) ; Username of system receiving file
+34 ;S BARUPASS=$P(BAREISS,U,3) ; Password of system receiving file
+35 ;S XBQTO=$P(BAREISS,U) ; System id to receive file
+36 ; Include username and password in system id
+37 ; Add i to XBQTO to send immediately rather than queue. Needed so can
+38 ; delete sent files. (A/R 1.8)
+39 ;S XBQTO="-il """_BARUNAM_":"_BARUPASS_""" "_XBQTO
+40 ;I XBUF=""!(BARUNAM="")!(BARUPASS="")!(XBQTO="") Q
+41 IF XBUF=""
QUIT
+42 IF '$DATA(XBS1)
QUIT
+43 ; END AUTO FTP *****************************
+44 IF IO=IO(0)
WRITE !!
+45 DO ^XBGSAVE
+46 ; Coding change A/R 1.8 - next 5 lines
+47 ; Send not successful
IF +XBFLG
QUIT
+48 ; delete file from local, send successful
+49 ; try to make sure file at recieving system before deleting
HANG 10
+50 SET BARDIR=$PIECE(BAREISS,U,4)
+51 SET BARDEL=$$DEL^%ZISH(BARDIR,BARFN)
+52 QUIT
