TIUUPLD ; SLC/JER - ASCII Upload ;9/11/98@16:39:47
;;1.0;TEXT INTEGRATION UTILITIES;**21**;Jun 20, 1997
MAIN ; Control branching
N EOM,TIUDA,TIUERR,TIUHDR,TIULN,TIUSRC,X
I '$D(TIUPRM0)!'$D(TIUPRM1) D SETPARM^TIULE
S TIUSRC=$P($G(TIUPRM0),U,9),EOM=$P($G(TIUPRM0),U,11)
I EOM']"",($P(TIUPRM0,U,17)'="k") W !,$C(7),$C(7),$C(7),"No End of Message Signal Defined - Contact IRM.",! Q
S:TIUSRC']"" TIUSRC="R"
S TIUHDR=$P(TIUPRM0,U,10)
I TIUHDR']"" W $C(7),$C(7),$C(7),"No Record Header Signal Defined - Contact IRM.",! Q
S TIUDA=$$MAKEBUF
I +TIUDA'>0 W $C(7),$C(7),$C(7),"Unable to create a Buffer File Record - Contact IRM.",! Q
I TIUSRC="R" D REMOTE(TIUDA)
I TIUSRC="H" D HFS(TIUDA)
I +$G(TIUERR) W $C(7),$C(7),$C(7),!,"File Transfer Error: ",$G(TIUERR),!!,"Please re-transmit the file...",!
; Set $ZB to MAIN+14^TIUUPLD:2
I +$O(^TIU(8925.2,TIUDA,"TEXT",0))>0,'+$G(TIUERR) D FILE(TIUDA)
I +$O(^TIU(8925.2,TIUDA,"TEXT",0))'>0!+$G(TIUERR) D BUFPURGE^TIUPUTC(TIUDA)
Q
REMOTE(DA) ; Read ASCII stream from remote computer
N TIUI,TIUPAC,X
I '$D(TIUPRM0)!'$D(TIUPRM1) D SETPARM^TIULE
S TIUPAC=$P(TIUPRM0,U,15)
I TIUPAC']"",($P(TIUPRM0,U,17)'="k") W $C(7),$C(7),$C(7),"No Pace Character Defined - Contact IRM.",! Q
I $P(TIUPRM0,U,17)="k" D KERMIT(DA) Q
D REMHDR("ASCII")
S TIUERR=""
W !,$C(TIUPAC)
F R X:DTIME S:'$T X="^TIMEOUT" D Q:TIUERR'=""
. I (X="^")!(X="^^")!(X="^TIMEOUT") DO Q
. . S TIUERR="1,End of Message Signal not seen."
. I X=EOM S TIUERR=0 W ! Q
. I X?1."?" D HELP(X),REMHDR("ASCII") Q
. ; Ignore leading white space
. I (+$O(^TIU(8925.2,DA,"TEXT",0))'>0),(X="") Q
. S TIUI=+$G(TIUI)+1,^TIU(8925.2,DA,"TEXT",TIUI,0)=$$STRIP(X)
. W !,$C(TIUPAC) ; Send ACK to remote
S ^TIU(8925.2,DA,"TEXT",0)="^^"_$G(TIUI)_"^"_$G(TIUI)_"^"_DT_"^^^^"
Q
REMHDR(PRTCL) ; Write Header for Remote upload
W @IOF D JUSTIFY^TIUU($$TITLE^TIUU(PRTCL_" UPLOAD"),"C")
W:PRTCL="ASCII" !!,"Initiate upload procedure:",!
Q
KERMIT(DA) ; Use Kermit Protocol Driver
N XTKDIC,XTKERR,XTKMODE,DWLC
D REMHDR("KERMIT")
S XTKDIC="^TIU(8925.2,"_+DA_",""TEXT"",",XTKMODE=2
D RECEIVE^XTKERMIT I +$G(XTKERR) S TIUERR=$G(XTKERR) W !
Q
HFS(DA) ; Read HFS file
N TIUI,X
I '$D(TIUPRM0)!'$D(TIUPRM1) D SETPARM^TIULE
W @IOF D JUSTIFY^TIUU($$TITLE^TIUU("ASCII UPLOAD"),"C")
W !!,"Select Host File:",! D ^%ZIS I POP W !,$C(7),"Device unavailable." Q
F U IO R X:DTIME Q:'$T!(X=EOM)!(X="^")!(X="^^") D
. U IO(0) W X,!
. S TIUI=+$G(TIUI)+1,^TIU(8925.2,DA,"TEXT",TIUI,0)=$$STRIP(X)
S ^TIU(8925.2,DA,"TEXT",0)="^^"_$G(TIUI)_"^"_$G(TIUI)_"^"_DT_"^^^^"
D ^%ZISC
Q
STRIP(X) ; Strip control characters
N I,Y
; First replace TABS w/5 spaces
F I=1:1:$L(X) S:$A(X,I)=9 X=$E(X,1,(I-1))_" "_$E(X,(I+1),$L(X))
; Next, remove control characters
S Y="" F I=1:1:$L(X) S:$A(X,I)>31 Y=Y_$E(X,I)
Q Y
MAKEBUF() ; Subroutine to create buffer records
N DIC,DA,DR,DIE,START,X,Y
S START=$$NOW^TIULC
S (DIC,DLAYGO)=8925.2,DIC(0)="LX",X=""""_$J_"""" D ^DIC
I +Y'>0 S DA=Y G MAKEBUX
S DA=+Y,DIE=DIC,DR=".02////"_+$G(DUZ)_";.03////"_START D ^DIE
MAKEBUX Q DA
FILE(DA) ; Completes upload transaction, invokes filer/router
N DIE,DR
I '$D(^TIU(8925.2,+DA,0)) G FILEX
S DIE="^TIU(8925.2,",DR=".04////"_$$NOW^TIULC D ^DIE
; Task background filer/router to process buffer record
S ZTIO="",ZTDTH=$H,ZTSAVE("DA")=""
S ZTRTN=$S($P(TIUPRM0,U,16)="D":"MAIN^TIUPUTD",1:"MAIN^TIUPUTC")
S ZTDESC="TIU Document Filer"
; If filer is NOT designated to run in the foreground, queue it
I '+$P(TIUPRM0,U,18) D G FILEX
. D ^%ZTLOAD
. W !,$S($D(ZTSK):"Filer/Router Queued!",1:"Filer/Router Cancelled!")
; Otherwise, run the filer in the foreground
W !!,"File Transfer Complete--Now Filing Records..."
D @ZTRTN
FILEX Q
HELP(X) ; Process HELP for Remote upload
I X="?" W !?3,"Begin file transfer using ASCII protocol upload procedure.",!
I X?2."?" D
. W !?3,"Consult your terminal emulator's User Manual to determine",!
. W !?3,"how to set-up and initiate an ASCII protocol file transfer.",!
W !?3,"Enter '^' or '^^' to exit.",!
S TIUX=$$READ^TIUU("FOA","Press RETURN to continue...")
Q
TIUUPLD ; SLC/JER - ASCII Upload ;9/11/98@16:39:47
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**21**;Jun 20, 1997
MAIN ; Control branching
+1 NEW EOM,TIUDA,TIUERR,TIUHDR,TIULN,TIUSRC,X
+2 IF '$DATA(TIUPRM0)!'$DATA(TIUPRM1)
DO SETPARM^TIULE
+3 SET TIUSRC=$PIECE($GET(TIUPRM0),U,9)
SET EOM=$PIECE($GET(TIUPRM0),U,11)
+4 IF EOM']""
IF ($PIECE(TIUPRM0,U,17)'="k")
WRITE !,$CHAR(7),$CHAR(7),$CHAR(7),"No End of Message Signal Defined - Contact IRM.",!
QUIT
+5 IF TIUSRC']""
SET TIUSRC="R"
+6 SET TIUHDR=$PIECE(TIUPRM0,U,10)
+7 IF TIUHDR']""
WRITE $CHAR(7),$CHAR(7),$CHAR(7),"No Record Header Signal Defined - Contact IRM.",!
QUIT
+8 SET TIUDA=$$MAKEBUF
+9 IF +TIUDA'>0
WRITE $CHAR(7),$CHAR(7),$CHAR(7),"Unable to create a Buffer File Record - Contact IRM.",!
QUIT
+10 IF TIUSRC="R"
DO REMOTE(TIUDA)
+11 IF TIUSRC="H"
DO HFS(TIUDA)
+12 IF +$GET(TIUERR)
WRITE $CHAR(7),$CHAR(7),$CHAR(7),!,"File Transfer Error: ",$GET(TIUERR),!!,"Please re-transmit the file...",!
+13 ; Set $ZB to MAIN+14^TIUUPLD:2
+14 IF +$ORDER(^TIU(8925.2,TIUDA,"TEXT",0))>0
IF '+$GET(TIUERR)
DO FILE(TIUDA)
+15 IF +$ORDER(^TIU(8925.2,TIUDA,"TEXT",0))'>0!+$GET(TIUERR)
DO BUFPURGE^TIUPUTC(TIUDA)
+16 QUIT
REMOTE(DA) ; Read ASCII stream from remote computer
+1 NEW TIUI,TIUPAC,X
+2 IF '$DATA(TIUPRM0)!'$DATA(TIUPRM1)
DO SETPARM^TIULE
+3 SET TIUPAC=$PIECE(TIUPRM0,U,15)
+4 IF TIUPAC']""
IF ($PIECE(TIUPRM0,U,17)'="k")
WRITE $CHAR(7),$CHAR(7),$CHAR(7),"No Pace Character Defined - Contact IRM.",!
QUIT
+5 IF $PIECE(TIUPRM0,U,17)="k"
DO KERMIT(DA)
QUIT
+6 DO REMHDR("ASCII")
+7 SET TIUERR=""
+8 WRITE !,$CHAR(TIUPAC)
+9 FOR
READ X:DTIME
IF '$TEST
SET X="^TIMEOUT"
Begin DoDot:1
+10 IF (X="^")!(X="^^")!(X="^TIMEOUT")
Begin DoDot:2
+11 SET TIUERR="1,End of Message Signal not seen."
End DoDot:2
QUIT
+12 IF X=EOM
SET TIUERR=0
WRITE !
QUIT
+13 IF X?1."?"
DO HELP(X)
DO REMHDR("ASCII")
QUIT
+14 ; Ignore leading white space
+15 IF (+$ORDER(^TIU(8925.2,DA,"TEXT",0))'>0)
IF (X="")
QUIT
+16 SET TIUI=+$GET(TIUI)+1
SET ^TIU(8925.2,DA,"TEXT",TIUI,0)=$$STRIP(X)
+17 ; Send ACK to remote
WRITE !,$CHAR(TIUPAC)
End DoDot:1
IF TIUERR'=""
QUIT
+18 SET ^TIU(8925.2,DA,"TEXT",0)="^^"_$GET(TIUI)_"^"_$GET(TIUI)_"^"_DT_"^^^^"
+19 QUIT
REMHDR(PRTCL) ; Write Header for Remote upload
+1 WRITE @IOF
DO JUSTIFY^TIUU($$TITLE^TIUU(PRTCL_" UPLOAD"),"C")
+2 IF PRTCL="ASCII"
WRITE !!,"Initiate upload procedure:",!
+3 QUIT
KERMIT(DA) ; Use Kermit Protocol Driver
+1 NEW XTKDIC,XTKERR,XTKMODE,DWLC
+2 DO REMHDR("KERMIT")
+3 SET XTKDIC="^TIU(8925.2,"_+DA_",""TEXT"","
SET XTKMODE=2
+4 DO RECEIVE^XTKERMIT
IF +$GET(XTKERR)
SET TIUERR=$GET(XTKERR)
WRITE !
+5 QUIT
HFS(DA) ; Read HFS file
+1 NEW TIUI,X
+2 IF '$DATA(TIUPRM0)!'$DATA(TIUPRM1)
DO SETPARM^TIULE
+3 WRITE @IOF
DO JUSTIFY^TIUU($$TITLE^TIUU("ASCII UPLOAD"),"C")
+4 WRITE !!,"Select Host File:",!
DO ^%ZIS
IF POP
WRITE !,$CHAR(7),"Device unavailable."
QUIT
+5 FOR
USE IO
READ X:DTIME
IF '$TEST!(X=EOM)!(X="^")!(X="^^")
QUIT
Begin DoDot:1
+6 USE IO(0)
WRITE X,!
+7 SET TIUI=+$GET(TIUI)+1
SET ^TIU(8925.2,DA,"TEXT",TIUI,0)=$$STRIP(X)
End DoDot:1
+8 SET ^TIU(8925.2,DA,"TEXT",0)="^^"_$GET(TIUI)_"^"_$GET(TIUI)_"^"_DT_"^^^^"
+9 DO ^%ZISC
+10 QUIT
STRIP(X) ; Strip control characters
+1 NEW I,Y
+2 ; First replace TABS w/5 spaces
+3 FOR I=1:1:$LENGTH(X)
IF $ASCII(X,I)=9
SET X=$EXTRACT(X,1,(I-1))_" "_$EXTRACT(X,(I+1),$LENGTH(X))
+4 ; Next, remove control characters
+5 SET Y=""
FOR I=1:1:$LENGTH(X)
IF $ASCII(X,I)>31
SET Y=Y_$EXTRACT(X,I)
+6 QUIT Y
MAKEBUF() ; Subroutine to create buffer records
+1 NEW DIC,DA,DR,DIE,START,X,Y
+2 SET START=$$NOW^TIULC
+3 SET (DIC,DLAYGO)=8925.2
SET DIC(0)="LX"
SET X=""""_$JOB_""""
DO ^DIC
+4 IF +Y'>0
SET DA=Y
GOTO MAKEBUX
+5 SET DA=+Y
SET DIE=DIC
SET DR=".02////"_+$GET(DUZ)_";.03////"_START
DO ^DIE
MAKEBUX QUIT DA
FILE(DA) ; Completes upload transaction, invokes filer/router
+1 NEW DIE,DR
+2 IF '$DATA(^TIU(8925.2,+DA,0))
GOTO FILEX
+3 SET DIE="^TIU(8925.2,"
SET DR=".04////"_$$NOW^TIULC
DO ^DIE
+4 ; Task background filer/router to process buffer record
+5 SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTSAVE("DA")=""
+6 SET ZTRTN=$SELECT($PIECE(TIUPRM0,U,16)="D":"MAIN^TIUPUTD",1:"MAIN^TIUPUTC")
+7 SET ZTDESC="TIU Document Filer"
+8 ; If filer is NOT designated to run in the foreground, queue it
+9 IF '+$PIECE(TIUPRM0,U,18)
Begin DoDot:1
+10 DO ^%ZTLOAD
+11 WRITE !,$SELECT($DATA(ZTSK):"Filer/Router Queued!",1:"Filer/Router Cancelled!")
End DoDot:1
GOTO FILEX
+12 ; Otherwise, run the filer in the foreground
+13 WRITE !!,"File Transfer Complete--Now Filing Records..."
+14 DO @ZTRTN
FILEX QUIT
HELP(X) ; Process HELP for Remote upload
+1 IF X="?"
WRITE !?3,"Begin file transfer using ASCII protocol upload procedure.",!
+2 IF X?2."?"
Begin DoDot:1
+3 WRITE !?3,"Consult your terminal emulator's User Manual to determine",!
+4 WRITE !?3,"how to set-up and initiate an ASCII protocol file transfer.",!
End DoDot:1
+5 WRITE !?3,"Enter '^' or '^^' to exit.",!
+6 SET TIUX=$$READ^TIUU("FOA","Press RETURN to continue...")
+7 QUIT
