Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BTIUUPL

BTIUUPL.m

Go to the documentation of this file.
  1. BTIUUPL ; IHS/ITSC/LJF - ASCII Upload ;
  1. ;;1.0;TEXT INTEGRATION UTILITIES;**1002**;NOV 04, 2004
  1. ; IHS copy of TIUUPLD for silent ASCII upload
  1. ; -- see tagged lines for changes
  1. ;IHS/OIT/LJF 3/18/2005 PATCH 1002 if line too long, break it up using FM call
  1. ;
  1. MAIN ;EP; Control branching
  1. Q:$$GET1^DIQ(9003130.2,1,.02)]"" ;do NOT start upload if one already running
  1. D SET(.02,$$NOW^XLFDT) ;set start time for upload
  1. D ^XBKVAR ;added so call from unix works
  1. NEW TIUZMSG ;used for silent messaging
  1. N EOM,TIUDA,TIUERR,TIUHDR,TIULN,TIUSRC,X
  1. I '$D(TIUPRM0)!'$D(TIUPRM1) D SETPARM^TIULE
  1. S TIUSRC=$P($G(TIUPRM0),U,9),EOM=$P($G(TIUPRM0),U,11)
  1. ;I EOM']"",($P(TIUPRM0,U,17)'="k") W !,$C(7),$C(7),$C(7),"No End of Message Signal Defined - Contact IRM.",! Q ;original VA
  1. I EOM']"",($P(TIUPRM0,U,17)'="k") D SET(.05,"No End of Message Signal Defined - Contact IRM.") Q ;store error message
  1. S:TIUSRC']"" TIUSRC="R"
  1. S TIUHDR=$P(TIUPRM0,U,10)
  1. ;I TIUHDR']"" W $C(7),$C(7),$C(7),"No Record Header Signal Defined - Contact IRM.",! Q ;original VA
  1. I TIUHDR']"" D SET(.05,"No Record Header Signal Defined - Contact IRM.") Q ;store error message
  1. S TIUDA=$$MAKEBUF
  1. ;I +TIUDA'>0 W $C(7),$C(7),$C(7),"Unable to create a Buffer File Record - Contact IRM.",! Q ;original VA
  1. I +TIUDA'>0 D SET(.05,"Unable to create a Buffer File Record - Contact IRM.") Q ;store error message
  1. I TIUSRC="R" D REMOTE(TIUDA)
  1. I TIUSRC="H" D HFS(TIUDA)
  1. ;I +$G(TIUERR) W $C(7),$C(7),$C(7),!,"Kermit Error: ",$G(TIUERR)," Please re-transmit the file...",! ;original VA
  1. I +$G(TIUERR) D SET(.05,"Kermit Error: "_$G(TIUERR)_" Please re-transmit the file...") Q ;store error message
  1. ; Set $ZB to MAIN+14^TIUUPLD:2
  1. I +$O(^TIU(8925.2,TIUDA,"TEXT",0))>0,'+$G(TIUERR) D FILE(TIUDA)
  1. I +$O(^TIU(8925.2,TIUDA,"TEXT",0))'>0!+$G(TIUERR) D BUFPURGE^TIUPUTC(TIUDA)
  1. D SET(.02,"@") ;upload done - okay to spawn new job
  1. Q
  1. REMOTE(DA) ; Read ASCII stream from remote computer
  1. N TIUI,TIUPAC,X
  1. I '$D(TIUPRM0)!'$D(TIUPRM1) D SETPARM^TIULE
  1. S TIUPAC=$P(TIUPRM0,U,15)
  1. ;I TIUPAC']"",($P(TIUPRM0,U,17)'="k") W $C(7),$C(7),$C(7),"No Pace Character Defined - Contact IRM.",! Q ;original VA
  1. I TIUPAC']"",($P(TIUPRM0,U,17)'="k") D SET(.05,"No Pace Character Defined - Contact IRM.") Q ;store error message
  1. I $P(TIUPRM0,U,17)="k" D KERMIT(DA) Q
  1. D REMHDR("ASCII")
  1. F R X:DTIME Q:'$T!(X=EOM)!(X="^")!(X="^^") D
  1. . I X?1."?" D HELP(X),REMHDR("ASCII") Q
  1. . ; Ignore leading white space
  1. . I (+$O(^TIU(8925.2,DA,"TEXT",0))'>0),(X="") Q
  1. . S TIUI=+$G(TIUI)+1,^TIU(8925.2,DA,"TEXT",TIUI,0)=$$STRIP(X)
  1. . W !,$C(TIUPAC) ; Send ACK to remote
  1. S ^TIU(8925.2,DA,"TEXT",0)="^^"_$G(TIUI)_"^"_$G(TIUI)_"^"_DT_"^^^^"
  1. Q
  1. REMHDR(PRTCL) ; Write Header for Remote upload
  1. W @IOF D JUSTIFY^TIUU($$TITLE^TIUU(PRTCL_" UPLOAD"),"C")
  1. W:PRTCL="ASCII" !!,"Initiate upload procedure:",!
  1. Q
  1. KERMIT(DA) ; Use Kermit Protocol Driver
  1. N XTKDIC,XTKERR,XTKMODE,DWLC
  1. D REMHDR("KERMIT")
  1. S XTKDIC="^TIU(8925.2,"_+DA_",""TEXT"",",XTKMODE=2
  1. D RECEIVE^XTKERMIT I +$G(XTKERR) S TIUERR=$G(XTKERR) W !
  1. Q
  1. HFS(DA) ; Read HFS file
  1. N TIUI,X
  1. I '$D(TIUPRM0)!'$D(TIUPRM1) D SETPARM^TIULE
  1. ;W @IOF D JUSTIFY^TIUU($$TITLE^TIUU("ASCII UPLOAD"),"C") ;original VA
  1. ;W !!,"Select Host File:",! D ^%ZIS I POP W !,$C(7),"Device unavailable." Q ;original VA
  1. ;
  1. NEW TIUSITE S TIUSITE=$O(^TIU(8925.99,"B",DUZ(2),0)) ;added - find site
  1. I 'TIUSITE D SET(.05,"Site not setup in Parameter File") Q ;added - store error and quit
  1. S IOP="HFS",%ZIS("HFSNAME")=$$GET1^DIQ(8925.99,TIUSITE,9999999.01) ;added - find directory
  1. S %ZIS("HFSNAME")=%ZIS("HFSNAME")_$$GET1^DIQ(8925.99,TIUSITE,9999999.03) ;added - find filename
  1. S %ZIS("HFSMODE")="R" D ^%ZIS ;added - is it there?
  1. I POP D SET(.03,$$NOW^XLFDT) Q ;added - if no file, update status global & quit
  1. H 5 ;added wait in case ftp in process at call time
  1. S IOP="HFS",%ZIS("HFSNAME")=$$GET1^DIQ(8925.99,TIUSITE,9999999.01) ;added - find directory
  1. S %ZIS("HFSNAME")=%ZIS("HFSNAME")_$$GET1^DIQ(8925.99,TIUSITE,9999999.03) ;added - find filename
  1. S %ZIS("HFSMODE")="RW" D ^%ZIS ;added - open of uploading now
  1. I POP D SET(.05,"Device Unavailable") Q ;added - store error and quit
  1. ;
  1. ;F U IO R X:DTIME Q:'$T!(X=EOM)!(X="^")!(X="^^") D ;original VA
  1. NEW QUIT S QUIT=0 F U IO R X:1 Q:QUIT=1 D ;changed DTIME per Dimitri
  1. . I X=EOM S QUIT=1 Q
  1. . ;
  1. . ;IHS/OIT/LJF 3/18/2005 PATCH 1002 if line too long, break it up
  1. . ;I $L(X)>255 S X=$$REPEAT^XLFSTR("?",75) ;if line too long, reset to 75? - may be garbage
  1. . I $L(X)>255 D Q
  1. . . NEW I K ^UTILITY($J,"W")
  1. . . S DIWL=1,DIWR=75,DIWF="I" D ^DIWP
  1. . . F I=1:1 Q:'$D(^UTILITY($J,"W",1,I)) S TIUI=+$G(TIUI)+1,^TIU(8925.2,DA,"TEXT",TIUI,0)=$$STRIP(^UTILITY($J,"W",1,I,0))
  1. . . K ^UTILITY($J,"W")
  1. . . ;IHS/OIT/LJF 3/18/2005 PATCH 1002 end of new code
  1. . ;
  1. . S TIUI=+$G(TIUI)+1,^TIU(8925.2,DA,"TEXT",TIUI,0)=$$STRIP(X)
  1. ;
  1. S ^TIU(8925.2,DA,"TEXT",0)="^^"_$G(TIUI)_"^"_$G(TIUI)_"^"_DT_"^^^^"
  1. D ^%ZISC
  1. ;
  1. D SET(.04,$$NOW^XLFDT) ;added - update status global for date last file processed
  1. D ^BTIUARC ;added - move to archive directory
  1. ;
  1. Q
  1. STRIP(X) ; Strip control characters
  1. N I,Y
  1. ; First replace TABS w/5 spaces
  1. F I=1:1:$L(X) S:$A(X,I)=9 X=$E(X,1,(I-1))_" "_$E(X,(I+1),$L(X))
  1. ; Next, remove control characters
  1. S Y="" F I=1:1:$L(X) S:$A(X,I)>31 Y=Y_$E(X,I)
  1. Q Y
  1. MAKEBUF() ; Subroutine to create buffer records
  1. N DIC,DA,DR,DIE,START,X,Y
  1. S START=$$NOW^TIULC
  1. S (DIC,DLAYGO)=8925.2,DIC(0)="LX",X=""""_$J_"""" D ^DIC
  1. I +Y'>0 S DA=Y G MAKEBUX
  1. S DA=+Y,DIE=DIC,DR=".02////"_+$G(DUZ)_";.03////"_START D ^DIE
  1. MAKEBUX Q DA
  1. FILE(DA) ; Completes upload transaction, invokes filer/router
  1. N DIE,DR
  1. I '$D(^TIU(8925.2,+DA,0)) G FILEX
  1. S DIE="^TIU(8925.2,",DR=".04////"_$$NOW^TIULC D ^DIE
  1. ; Task background filer/router to process buffer record
  1. S ZTIO="",ZTDTH=$H,ZTSAVE("DA")=""
  1. S ZTRTN=$S($P(TIUPRM0,U,16)="D":"MAIN^TIUPUTD",1:"MAIN^TIUPUTC")
  1. S ZTDESC="TIU Document Filer"
  1. ; If filer is NOT designated to run in the foreground, queue it
  1. I '+$P(TIUPRM0,U,18) D G FILEX
  1. . D ^%ZTLOAD
  1. . ;W !,$S($D(ZTSK):"Filer/Router Queued!",1:"Filer/Router Cancelled!") ;original VA - need silence
  1. ; Otherwise, run the filer in the foreground
  1. D @ZTRTN
  1. FILEX Q
  1. HELP(X) ; Process HELP for Remote upload
  1. I X="?" W !?3,"Begin file transfer using ASCII protocol upload procedure.",!
  1. I X?2."?" D
  1. . W !?3,"Consult your terminal emulator's User Manual to determine",!
  1. . W !?3,"how to set-up and initiate an ASCII protocol file transfer.",!
  1. W !?3,"Enter '^' or '^^' to exit.",!
  1. S TIUX=$$READ^TIUU("FOA","Press RETURN to continue...")
  1. Q
  1. ;
  1. SET(FIELD,ANS) ; upload BTIU UPLOAD STATUS file
  1. NEW DIE,DA,DR
  1. S DIE=9003130.2,DA=1,DR=FIELD_"///"_ANS
  1. D ^DIE
  1. Q
  1. ;
  1. DISPLAY ;EP; -- display status of upload
  1. NEW X,Y
  1. D ^XBCLS D MSG^BTIUU("**STATUS OF TIU UPLOAD**",2,1,0)
  1. ;
  1. S Y=$$GET1^DIQ(9003130.2,1,.04,"I")
  1. S X=$S(Y="":"NO FILES UPLOADED",1:$$DOW^XLFDT(Y)_" "_$$FMTE^XLFDT(Y))
  1. D MSG^BTIUU("LAST FILE UPLOADED INTO RPMS: "_X,1,1,0)
  1. ;
  1. S Y=$$GET1^DIQ(9003130.2,1,.03,"I")
  1. S X=$S(Y="":"NO LAST SCAN FOUND",1:$$DOW^XLFDT(Y)_" "_$$FMTE^XLFDT(Y))
  1. D MSG^BTIUU("LAST SCAN FOR NEW TIU FILE: "_X,1,1,0)
  1. ;
  1. S Y=$$GET1^DIQ(9003130.2,1,.02) I Y]"" D
  1. . D MSG^BTIUU("UPLOAD STILL RUNNING; CHECK END OF FILE MARKERS",1,0,0)
  1. . D MSG^BTIUU("UPLOAD STARTED ON "_Y,1,0,0)
  1. . S X=$$GET1^DIQ(900903130.2,1,.05)
  1. . I X]"" D MSG^BTIUU("ERROR RECORDED: "_X,1,1,0)
  1. D RETURN^BTIUU
  1. Q
  1. ;
  1. RESET ;EP; resets Upload Running and Error Messages back to null so uplaod can run
  1. ; after porblem has been fixed; run this to restart upload
  1. Q:'$$READ^TIUU("Y","OKAY to Reset UPLOAD STATUS","NO")
  1. NEW DIE,DA,DR
  1. S DIE=9003130.2,DA=1,DR=".02///@;.05///@"
  1. D ^DIE
  1. Q