- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUUPLD 4176 printed Feb 19, 2025@00:12:52 Page 2
- 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