source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUUPLD.m@ 1261

Last change on this file since 1261 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.0 KB
Line 
1TIUUPLD ; SLC/JER - ASCII Upload ;9/11/98@16:39:47
2 ;;1.0;TEXT INTEGRATION UTILITIES;**21**;Jun 20, 1997
3MAIN ; Control branching
4 N EOM,TIUDA,TIUERR,TIUHDR,TIULN,TIUSRC,X
5 I '$D(TIUPRM0)!'$D(TIUPRM1) D SETPARM^TIULE
6 S TIUSRC=$P($G(TIUPRM0),U,9),EOM=$P($G(TIUPRM0),U,11)
7 I EOM']"",($P(TIUPRM0,U,17)'="k") W !,$C(7),$C(7),$C(7),"No End of Message Signal Defined - Contact IRM.",! Q
8 S:TIUSRC']"" TIUSRC="R"
9 S TIUHDR=$P(TIUPRM0,U,10)
10 I TIUHDR']"" W $C(7),$C(7),$C(7),"No Record Header Signal Defined - Contact IRM.",! Q
11 S TIUDA=$$MAKEBUF
12 I +TIUDA'>0 W $C(7),$C(7),$C(7),"Unable to create a Buffer File Record - Contact IRM.",! Q
13 I TIUSRC="R" D REMOTE(TIUDA)
14 I TIUSRC="H" D HFS(TIUDA)
15 I +$G(TIUERR) W $C(7),$C(7),$C(7),!,"File Transfer Error: ",$G(TIUERR),!!,"Please re-transmit the file...",!
16 ; Set $ZB to MAIN+14^TIUUPLD:2
17 I +$O(^TIU(8925.2,TIUDA,"TEXT",0))>0,'+$G(TIUERR) D FILE(TIUDA)
18 I +$O(^TIU(8925.2,TIUDA,"TEXT",0))'>0!+$G(TIUERR) D BUFPURGE^TIUPUTC(TIUDA)
19 Q
20REMOTE(DA) ; Read ASCII stream from remote computer
21 N TIUI,TIUPAC,X
22 I '$D(TIUPRM0)!'$D(TIUPRM1) D SETPARM^TIULE
23 S TIUPAC=$P(TIUPRM0,U,15)
24 I TIUPAC']"",($P(TIUPRM0,U,17)'="k") W $C(7),$C(7),$C(7),"No Pace Character Defined - Contact IRM.",! Q
25 I $P(TIUPRM0,U,17)="k" D KERMIT(DA) Q
26 D REMHDR("ASCII")
27 S TIUERR=""
28 W !,$C(TIUPAC)
29 F R X:DTIME S:'$T X="^TIMEOUT" D Q:TIUERR'=""
30 . I (X="^")!(X="^^")!(X="^TIMEOUT") DO Q
31 . . S TIUERR="1,End of Message Signal not seen."
32 . I X=EOM S TIUERR=0 W ! Q
33 . I X?1."?" D HELP(X),REMHDR("ASCII") Q
34 . ; Ignore leading white space
35 . I (+$O(^TIU(8925.2,DA,"TEXT",0))'>0),(X="") Q
36 . S TIUI=+$G(TIUI)+1,^TIU(8925.2,DA,"TEXT",TIUI,0)=$$STRIP(X)
37 . W !,$C(TIUPAC) ; Send ACK to remote
38 S ^TIU(8925.2,DA,"TEXT",0)="^^"_$G(TIUI)_"^"_$G(TIUI)_"^"_DT_"^^^^"
39 Q
40REMHDR(PRTCL) ; Write Header for Remote upload
41 W @IOF D JUSTIFY^TIUU($$TITLE^TIUU(PRTCL_" UPLOAD"),"C")
42 W:PRTCL="ASCII" !!,"Initiate upload procedure:",!
43 Q
44KERMIT(DA) ; Use Kermit Protocol Driver
45 N XTKDIC,XTKERR,XTKMODE,DWLC
46 D REMHDR("KERMIT")
47 S XTKDIC="^TIU(8925.2,"_+DA_",""TEXT"",",XTKMODE=2
48 D RECEIVE^XTKERMIT I +$G(XTKERR) S TIUERR=$G(XTKERR) W !
49 Q
50HFS(DA) ; Read HFS file
51 N TIUI,X
52 I '$D(TIUPRM0)!'$D(TIUPRM1) D SETPARM^TIULE
53 W @IOF D JUSTIFY^TIUU($$TITLE^TIUU("ASCII UPLOAD"),"C")
54 W !!,"Select Host File:",! D ^%ZIS I POP W !,$C(7),"Device unavailable." Q
55 F U IO R X:DTIME Q:'$T!(X=EOM)!(X="^")!(X="^^") D
56 . U IO(0) W X,!
57 . S TIUI=+$G(TIUI)+1,^TIU(8925.2,DA,"TEXT",TIUI,0)=$$STRIP(X)
58 S ^TIU(8925.2,DA,"TEXT",0)="^^"_$G(TIUI)_"^"_$G(TIUI)_"^"_DT_"^^^^"
59 D ^%ZISC
60 Q
61STRIP(X) ; Strip control characters
62 N I,Y
63 ; First replace TABS w/5 spaces
64 F I=1:1:$L(X) S:$A(X,I)=9 X=$E(X,1,(I-1))_" "_$E(X,(I+1),$L(X))
65 ; Next, remove control characters
66 S Y="" F I=1:1:$L(X) S:$A(X,I)>31 Y=Y_$E(X,I)
67 Q Y
68MAKEBUF() ; Subroutine to create buffer records
69 N DIC,DA,DR,DIE,START,X,Y
70 S START=$$NOW^TIULC
71 S (DIC,DLAYGO)=8925.2,DIC(0)="LX",X=""""_$J_"""" D ^DIC
72 I +Y'>0 S DA=Y G MAKEBUX
73 S DA=+Y,DIE=DIC,DR=".02////"_+$G(DUZ)_";.03////"_START D ^DIE
74MAKEBUX Q DA
75FILE(DA) ; Completes upload transaction, invokes filer/router
76 N DIE,DR
77 I '$D(^TIU(8925.2,+DA,0)) G FILEX
78 S DIE="^TIU(8925.2,",DR=".04////"_$$NOW^TIULC D ^DIE
79 ; Task background filer/router to process buffer record
80 S ZTIO="",ZTDTH=$H,ZTSAVE("DA")=""
81 S ZTRTN=$S($P(TIUPRM0,U,16)="D":"MAIN^TIUPUTD",1:"MAIN^TIUPUTC")
82 S ZTDESC="TIU Document Filer"
83 ; If filer is NOT designated to run in the foreground, queue it
84 I '+$P(TIUPRM0,U,18) D G FILEX
85 . D ^%ZTLOAD
86 . W !,$S($D(ZTSK):"Filer/Router Queued!",1:"Filer/Router Cancelled!")
87 ; Otherwise, run the filer in the foreground
88 W !!,"File Transfer Complete--Now Filing Records..."
89 D @ZTRTN
90FILEX Q
91HELP(X) ; Process HELP for Remote upload
92 I X="?" W !?3,"Begin file transfer using ASCII protocol upload procedure.",!
93 I X?2."?" D
94 . W !?3,"Consult your terminal emulator's User Manual to determine",!
95 . W !?3,"how to set-up and initiate an ASCII protocol file transfer.",!
96 W !?3,"Enter '^' or '^^' to exit.",!
97 S TIUX=$$READ^TIUU("FOA","Press RETURN to continue...")
98 Q
Note: See TracBrowser for help on using the repository browser.