XTKERM4 ;SF/RWF - Kermit utility parts ;11/8/93 11:46 ; [ 11/22/95 1:20 PM ]
;;7.3;TOOLKIT;;Apr 25, 1995
;IHS/OHPRD/FJE 11/22/95 modified for use with HL7
;IHS/OHPRD/FJE tests for XTKHL7 variable to determine if IO needed
INIT ;Init kermit paramiters
S (XTKS("PN"),XTKR("PN"))=0
S XTKRDAT="~+ @-#N1" D RPAR S XTKSDAT="~+ @-#N1" D SPAR
S XTKS("TO")=15,XTKS("QA")="#",(XTKS("SOH"),XTKR("SOH"))=1
S (XTKR("MAXTRY"),XTKS("MAXTRY"))=10,XTKERR=0
S (XTKR("TRY"),XTKR("CCNT"),XTKR("PN"))=0,XTKR("PT")="B",XTKR("SA")=""
S (XTKS("TRY"),XTKS("CCNT"),XTKS("PN"))=0,XTKS("PT")="S",XTKS("SA")=""
S:'$D(XTKDIC) XTKERR=1 S:'$D(XTKMODE) XTKMODE=2 S:'$D(DWLC) DWLC=0
S U="^",XTKR("TRMRD")=^%ZOSF("TRMRD")
Q
RPAR ;Setup receive paramiters from the S packet, Some go into send parameters
Q:XTKRDAT']""
S X=$A(XTKRDAT)-35 S:X>1 XTKS("SIZ")=X
S XTKR("TO")=$A(XTKRDAT,2)-32,XTKS("EOL")=$A(XTKRDAT,5)-32,XTKR("QA")=$E(XTKRDAT,6)
S:XTKS("EOL")<1 XTKS("EOL")=13 S:XTKR("QA")=" "!(XTKR("QA")="") XTKR("QA")="#"
S:XTKR("TO")<1 XTKR("TO")=5
Q
SPAR ;Setup send paramiters from the Y packet.
Q:XTKSDAT']""
S X=$A(XTKSDAT)-35 S:X>1 XTKS("SIZ")=X
S XTKR("TO")=$A(XTKSDAT,2)-32,XTKS("NPAD")=$A(XTKSDAT,3)-32,XTKS("PADC")=$E(XTKSDAT,4)#64,XTKS("EOL")=$A(XTKSDAT,5)-32,XTKR("QA")=$E(XTKSDAT,6)
S:XTKS("EOL")<1 XTKS("EOL")=13 S:XTKR("QA")=" "!(XTKR("QA")="") XTKR("QA")="#" S:XTKS("NPAD")<0 XTKS("NPAD")=0
S:XTKR("TO")<1 XTKR("TO")=5
Q
SFILE ;Get file to send.
K DIC S XTKERR=1,DIC="^DIZ(8980,",DIC(0)="AEMQ",DIC("A")="KERMIT FILE TO SEND:" D ^DIC Q:Y'>0
S XTKERR=0,XTKDA=+Y,XTKDIC="^DIZ(8980,"_XTKDA_",2,",XTKFILE=$P(Y,U,2),DIE=DIC,DA=+Y,DR="1///NOW;3" D ^DIE
S XTKMODE=$P(^DIZ(8980,XTKDA,0),U,4) K DIC,DIE,DR,DA
Q
RFILE ;Receive file IHS/OHPRD/FJE corrected spelling
I '$D(XTKHL7) W !!,"If you enter 'XXX' for the file name it will be replaced by the name sent." ;IHS/OHPRD/FJE If $D added to bypass IO if for HL7
I '$D(XTKHL7) K DIC S XTKERR=1,DLAYGO=8980,DIC="^DIZ(8980,",DIC(0)="AEMQLZ",DIC("A")="RECIEVE TO KERMIT FILE:",DIC("DR")="2//YES;3//TEXT" D ^DIC Q:Y'>0 ;IHS/OHPRD/FJE If added to test for XTKHL7
I $D(XTKHL7) K DIC S XTKERR=1,DIADD=1,DLAYGO=8980,DIC="^DIZ(8980,",DIC(0)="MLZ",DIC("DR")="2///YES;3///TEXT",X="XXX" D ^DIC K DIADD Q:Y'>0 ;IHS/OHPRD/FJE added If for HL7 to bypass fm IO
S XTKDA=+Y,XTKFILE=$P(Y,U,2) I '$P(Y,U,3) S DA=+Y,DIE=DIC,DR="1///NOW;2;3" D ^DIE S Y(0)=^DIZ(8980,XTKDA,0)
S XTKERR=0,XTKDIC="^DIZ(8980,"_XTKDA_",2,",XTKR("RFN")=$P(Y(0),U,3),XTKMODE=$P(Y(0),U,4)
S @(XTKDIC_"0)")="" K DIC,DIE,DA,DR
Q
READY S X=0 X ^%ZOSF("RM"),^%ZOSF("TYPE-AHEAD"),^%ZOSF("EOFF"),^%ZOSF("TRMON") Q
RESTORE S X=$S($D(IOM):IOM,1:80) X ^%ZOSF("RM"),^%ZOSF("EON"),^%ZOSF("TRMOFF") Q:$D(XTKDEBUG)
CLEAN ;Kill off variables
K A,C,F1,L,X1,X2,XTKR,XTKS,XTKRDAT,XTKSDAT,XTKRPK,XTKSPK,XTKDA,XTKFILE,XTKDIC,Y,Z,XTKET
Q
BSPAR ;Build S or Y init string
S XTKSDAT="~"_$C(XTKS("TO")+32)_" @-#N1"
Q
XTKERM4 ;SF/RWF - Kermit utility parts ;11/8/93 11:46 ; [ 11/22/95 1:20 PM ]
+1 ;;7.3;TOOLKIT;;Apr 25, 1995
+2 ;IHS/OHPRD/FJE 11/22/95 modified for use with HL7
+3 ;IHS/OHPRD/FJE tests for XTKHL7 variable to determine if IO needed
INIT ;Init kermit paramiters
+1 SET (XTKS("PN"),XTKR("PN"))=0
+2 SET XTKRDAT="~+ @-#N1"
DO RPAR
SET XTKSDAT="~+ @-#N1"
DO SPAR
+3 SET XTKS("TO")=15
SET XTKS("QA")="#"
SET (XTKS("SOH"),XTKR("SOH"))=1
+4 SET (XTKR("MAXTRY"),XTKS("MAXTRY"))=10
SET XTKERR=0
+5 SET (XTKR("TRY"),XTKR("CCNT"),XTKR("PN"))=0
SET XTKR("PT")="B"
SET XTKR("SA")=""
+6 SET (XTKS("TRY"),XTKS("CCNT"),XTKS("PN"))=0
SET XTKS("PT")="S"
SET XTKS("SA")=""
+7 IF '$DATA(XTKDIC)
SET XTKERR=1
IF '$DATA(XTKMODE)
SET XTKMODE=2
IF '$DATA(DWLC)
SET DWLC=0
+8 SET U="^"
SET XTKR("TRMRD")=^%ZOSF("TRMRD")
+9 QUIT
RPAR ;Setup receive paramiters from the S packet, Some go into send parameters
+1 IF XTKRDAT']""
QUIT
+2 SET X=$ASCII(XTKRDAT)-35
IF X>1
SET XTKS("SIZ")=X
+3 SET XTKR("TO")=$ASCII(XTKRDAT,2)-32
SET XTKS("EOL")=$ASCII(XTKRDAT,5)-32
SET XTKR("QA")=$EXTRACT(XTKRDAT,6)
+4 IF XTKS("EOL")<1
SET XTKS("EOL")=13
IF XTKR("QA")=" "!(XTKR("QA")="")
SET XTKR("QA")="#"
+5 IF XTKR("TO")<1
SET XTKR("TO")=5
+6 QUIT
SPAR ;Setup send paramiters from the Y packet.
+1 IF XTKSDAT']""
QUIT
+2 SET X=$ASCII(XTKSDAT)-35
IF X>1
SET XTKS("SIZ")=X
+3 SET XTKR("TO")=$ASCII(XTKSDAT,2)-32
SET XTKS("NPAD")=$ASCII(XTKSDAT,3)-32
SET XTKS("PADC")=$EXTRACT(XTKSDAT,4)#64
SET XTKS("EOL")=$ASCII(XTKSDAT,5)-32
SET XTKR("QA")=$EXTRACT(XTKSDAT,6)
+4 IF XTKS("EOL")<1
SET XTKS("EOL")=13
IF XTKR("QA")=" "!(XTKR("QA")="")
SET XTKR("QA")="#"
IF XTKS("NPAD")<0
SET XTKS("NPAD")=0
+5 IF XTKR("TO")<1
SET XTKR("TO")=5
+6 QUIT
SFILE ;Get file to send.
+1 KILL DIC
SET XTKERR=1
SET DIC="^DIZ(8980,"
SET DIC(0)="AEMQ"
SET DIC("A")="KERMIT FILE TO SEND:"
DO ^DIC
IF Y'>0
QUIT
+2 SET XTKERR=0
SET XTKDA=+Y
SET XTKDIC="^DIZ(8980,"_XTKDA_",2,"
SET XTKFILE=$PIECE(Y,U,2)
SET DIE=DIC
SET DA=+Y
SET DR="1///NOW;3"
DO ^DIE
+3 SET XTKMODE=$PIECE(^DIZ(8980,XTKDA,0),U,4)
KILL DIC,DIE,DR,DA
+4 QUIT
RFILE ;Receive file IHS/OHPRD/FJE corrected spelling
+1 ;IHS/OHPRD/FJE If $D added to bypass IO if for HL7
IF '$DATA(XTKHL7)
WRITE !!,"If you enter 'XXX' for the file name it will be replaced by the name sent."
+2 ;IHS/OHPRD/FJE If added to test for XTKHL7
IF '$DATA(XTKHL7)
KILL DIC
SET XTKERR=1
SET DLAYGO=8980
SET DIC="^DIZ(8980,"
SET DIC(0)="AEMQLZ"
SET DIC("A")="RECIEVE TO KERMIT FILE:"
SET DIC("DR")="2//YES;3//TEXT"
DO ^DIC
IF Y'>0
QUIT
+3 ;IHS/OHPRD/FJE added If for HL7 to bypass fm IO
IF $DATA(XTKHL7)
KILL DIC
SET XTKERR=1
SET DIADD=1
SET DLAYGO=8980
SET DIC="^DIZ(8980,"
SET DIC(0)="MLZ"
SET DIC("DR")="2///YES;3///TEXT"
SET X="XXX"
DO ^DIC
KILL DIADD
IF Y'>0
QUIT
+4 SET XTKDA=+Y
SET XTKFILE=$PIECE(Y,U,2)
IF '$PIECE(Y,U,3)
SET DA=+Y
SET DIE=DIC
SET DR="1///NOW;2;3"
DO ^DIE
SET Y(0)=^DIZ(8980,XTKDA,0)
+5 SET XTKERR=0
SET XTKDIC="^DIZ(8980,"_XTKDA_",2,"
SET XTKR("RFN")=$PIECE(Y(0),U,3)
SET XTKMODE=$PIECE(Y(0),U,4)
+6 SET @(XTKDIC_"0)")=""
KILL DIC,DIE,DA,DR
+7 QUIT
READY SET X=0
XECUTE ^%ZOSF("RM")
XECUTE ^%ZOSF("TYPE-AHEAD")
XECUTE ^%ZOSF("EOFF")
XECUTE ^%ZOSF("TRMON")
QUIT
RESTORE SET X=$SELECT($DATA(IOM):IOM,1:80)
XECUTE ^%ZOSF("RM")
XECUTE ^%ZOSF("EON")
XECUTE ^%ZOSF("TRMOFF")
IF $DATA(XTKDEBUG)
QUIT
CLEAN ;Kill off variables
+1 KILL A,C,F1,L,X1,X2,XTKR,XTKS,XTKRDAT,XTKSDAT,XTKRPK,XTKSPK,XTKDA,XTKFILE,XTKDIC,Y,Z,XTKET
+2 QUIT
BSPAR ;Build S or Y init string
+1 SET XTKSDAT="~"_$CHAR(XTKS("TO")+32)_" @-#N1"
+2 QUIT
