XUTLS.m

XUTLS ;SLC/JLA - TLS API's ; AUG 1, 2025@7:30

 ;;8.0;KERNEL;**787**;Jul 10, 1995;Build 73

 ;Per VA Directive 6402, this routine should not be modified.

 ;

 ;

 ; External API's

 ;

 ; FileMan

GET1(AFILE,AIENS,AFIELD,AFLAGS,ATROOT,AMROOT) Q $$GET1^DIQ($G(AFILE),$G(AIENS),$G(AFIELD),$G(AFLAGS),$G(ATROOT),$G(AMROOT))

DT() Q $$DT^XLFDT()

NOW() Q $$NOW^XLFDT()

FMADD(AFMDATE,ADAYS) Q $$FMADD^XLFDT($G(AFMDATE),$G(ADAYS))

 ;

 ; KERNEL/TLS API's

UPSTR(ASTRING) Q $$UP^XLFSTR($G(ASTRING))

ISTLSSERVERCONF(ATLSCONFIGNAME) Q $$ISTLSSERVERCONF^XUSUDO($G(ATLSCONFIGNAME))

APPERROR(AMESSAGE) D APPERROR^%ZTER($G(AMESSAGE)) Q

 ;

 ;

 ; Get Kernel System Parameter "DEFAULT TLS SERVER CONFIG." (FILE=8989.3, FIELD=667)

 ;

 ; Returns

 ;   0^GKSPTLSCN^XUTLS^Error message

 ;   1^Default TLS Server Name

 ;

 ; KRNDEV>ZW ^DD(8989.3,667)

 ; ^DD(8989.3,667,0)="DEFAULT TLS SERVER CONFIG.^FJ30^^667;1^K:$L(X)>30!($L(X)<3) X"

 ; ^DD(8989.3,667,3)="Enter the number that corresponds to the TLS server configuration name."

 ; ^DD(8989.3,667,21,0)="^^2^2^3250627^"

 ; ^DD(8989.3,667,21,1,0)="This is the name of the default TLS server configuration used by Kernel "

 ; ^DD(8989.3,667,21,2,0)="for TLS communication. It should not be blank. "

 ; ^DD(8989.3,667,"DT")=3250627

 ;

 ; W $$GKSPTLSCN^XUTLS()    ;ZW ^XTV(8989.3,1,667)

 ;

GKSPTLSCN() ;

 N DTLSN,FILE,KSPIEN,TLSFIELD,EMA,RTNVAL

 S FILE=8989.3,KSPIEN="1,",TLSFIELD=667,EMA="ERRMSGA"

 S DTLSN=$$GET1(FILE,KSPIEN,TLSFIELD,,,EMA)

 I +$P($G(@EMA@("DIERR")),"^") D

 . S RTNVAL="0^GKSPTLSCN^XUTLS^"_@EMA@("DIERR",1,"TEXT",1)

 E  S RTNVAL="1^"_DTLSN

 Q RTNVAL

 ;

 ;

 ; Initialize the already open TCP principal device to use TLS communication

 ; following the RPC Broker expected return format

 ;

 ; Returns

 ;   0^INIT^XUTLS^Error: <message>

 ;   1^INIT^XUTLS^Use Command executed

 ;   Sets XWBTLS to 0 by default and to 1 when $$INIT^XUTLS("USE",$P) is successful

 ;

INITRPC(ARESULT) ;

 S XWBTLS=0

 S ARESULT=$$INIT^XUTLS("USE",$P)

 I ARESULT S XWBTLS=1

 Q

 ;

 ;

 ; Initialize the already open TCP principal device to USE TLS communication.

 ;

 ; Returns

 ;   0^INIT^XUTLS^Error: <message>

 ;   1^INIT^XUTLS^Use Command executed

 ;

INITUP ;

 N returnValue

 S returnValue=$$INIT("USE",$P)

 Q returnValue

 ;

 ;

 ; Initialize the principal device to OPEN TLS communication.

 ;

 ; Returns

 ;   0^INIT^XUTLS^Error: <message>

 ;   1^INIT^XUTLS^Open Command executed

 ;

INITOP ;

 N returnValue

 S returnValue=$$INIT("OPEN",$P)

 Q returnValue

 ;

 ;

 ; A server-side USE command for TLS communication.

 ;

 ;   USE an existing open device for TLS communication.

 ;

 ;   USE:   USE device:(::/TLS=TLSConfigName):"mnespace"

 ;

 ;   Packet mode is the default if no mode is specified. If stream mode is disabled, the mode defaults to packet mode.

 ;   In packet mode READ commands complete as soon as there is some data to return. 

 ; 

 ; Parameters

 ;   ADEVICENAME    - A string of the form |TCP| followed by some number of numeric digits.

 ;                    The numeric portion of the device name is called the device identifier.

 ;                    This device identifier must be a unique TCP port number.

 ;   ATLSCONFIGNAME - A TLS Configuration Name.

 ;

 ; Returns

 ;   0^INIT^XUTLS^Error: <message>

 ;   1^INIT^XUTLS^Use Command executed

 ;

 ; S ADEVICE="|TCP|1234"

 ; S ATLSCN="server_encrypt"

 ; W $$USE^XUTLS(ADEVICE,ATLSCN)

 ;

USE(ADEVICENAME,ATLSCONFIGNAME) ;

 N returnValue

 S returnValue=$$INIT("USE",ADEVICENAME,ATLSCONFIGNAME)

 Q returnValue

 ;

 ;

 ; A server-side TCP OPEN command for TLS communication.

 ;

 ;   OPEN establishes ownership of the specified device. The process retains ownership of the device until 

 ;        the process either terminates or releases the device with a subsequent CLOSE command. While a 

 ;        device is owned by a process, no other process can acquire or use the device.

 ;

 ;   OPEN device:(::/TLS=TLSConfigName):timeout:"mnespace"

 ;

 ;   Packet mode is the default if no mode is specified. If stream mode is disabled, the mode defaults to packet mode.

 ;   In packet mode READ commands complete as soon as there is some data to return. 

 ; 

 ; Parameters

 ;   ADEVICENAME    - A string of the form |TCP| followed by some number of numeric digits.

 ;                    The numeric portion of the device name is called the device identifier.

 ;                    This device identifier must be a unique TCP port number.

 ;   ATLSCONFIGNAME - A TLS Configuration Name.

 ;   ATIMEOUT       - A TCP OPEN command Timeout.

 ;

 ; Returns

 ;   0^INIT^XUTLS^Error: <message>

 ;   1^INIT^XUTLS^Open Command executed

 ;

 ; S ADEVICE="|TCP|1234"

 ; S ATLSCN="server_encrypt"

 ; S ATIMEOUT=5

 ; W $$OPEN^XUTLS(ADEVICE,ATLSCN,ATIMEOUT)

 ;

OPEN(ADEVICENAME,ATLSCONFIGNAME,ATIMEOUT) ;

 N returnValue

 S returnValue=$$INIT("OPEN",ADEVICENAME,ATLSCONFIGNAME,ATIMEOUT)

 Q returnValue

 ;

 ;

 ; Initialize a server-side OPEN or USE command for TLS communication.

 ;

 ;   OPEN:  OPEN device:(::/TLS=TLSConfigName):timeout:"mnespace"

 ;    USE:   USE device:(::/TLS=TLSConfigName):"mnespace"

 ;

 ; Parameters

 ;   ACOMMAND       - A OPEN or USE command

 ;   ADEVICENAME    - A string of the form |TCP| followed by some number of numeric digits.

 ;                    The numeric portion of the device name is called the device identifier.

 ;                    This device identifier must be a unique TCP port number.

 ;   ATLSCONFIGNAME - A TLS Configuration Name.

 ;   ATIMEOUT       - A TCP OPEN command Timeout.

 ;   ASCREEN        - A Screen for logging (ex: XUDEBUG>2).

 ;     If the ASCREEN parameter is NOT passed in, it defaults the local screen variable to 1. 

 ;   ALOGGER        - A Logger to call to log messages when ASCREEN evaluates to true (ex: "LOG^XUTLS").

 ;     If the ALOGGER parameter is NOT passed in, the local logger variable is set to the local logging funtion LOG

 ;     Any logger passed in assumed to be ready for logging and must have the logging message as the first parameter.

 ;

 ; Returns

 ;   0^INIT^XUTLS^Error: <message>

 ;   1^INIT^XUTLS^<TLSCommand>

 ;

 ; S ACOMMAND="OPEN", S ACOMMAND="USE"

 ; S ADEVICE="|TCP|1234",ATLSCN="server_encrypt",ATIMEOUT=5

 ; S ADEVICE="|TCP|1234",ATLSCN="tls_encrypt_server",ATIMEOUT=5

 ; S ASCREEN="XWBDEBUG>1",XWBDEBUG=2,ALOGGER="LOG^XWBTCPM"

 ; W $$INIT^XUTLS(ACOMMAND,ADEVICE,ATLSCN,ATIMEOUT,ASCREEN,ALOGGER)

 ;

INIT(ACOMMAND,ADEVICENAME,ATLSCONFIGNAME,ATIMEOUT,ASCREEN,ALOGGER) ;

 N command,deviceName,TLSConfigName,timeout,TLSCommand,defaultTimeout,screen,logger,validTLSConfig,returnValue,message

 S returnValue=1,validTLSConfig=1,defaultTimeout=10

 I '$D(VERBOSE) NEW VERBOSE S VERBOSE=0

 I VERBOSE W !,"INIT^XUTLS(""",$G(ACOMMAND),""",""",$G(ADEVICENAME),""",""",$G(ATLSCONFIGNAME),""",",$G(ATIMEOUT),",""",$G(ASCREEN),""",""",$G(ALOGGER),""") Called",!!

 ;

 ; Define logger

 S screen=1,logger="LOG(message)"

 S:$L($G(ASCREEN)) screen=$G(ASCREEN)

 I $L($G(ALOGGER)) S logger=$G(ALOGGER)_"(message)"

 E  D LOGSTART("XUTLS")

 ;

 ; Validate the COMMAND passed in

 S command=$G(ACOMMAND)

 I '$L(command) D  G TLSCOMDN

 . S message="INIT^XUTLS^Error: Undefined TLS command parameter, 'OPEN' or 'USE' only."

 . I @screen D @logger

 . S returnValue="0^"_message

 S command=$$UPSTR($E(command,1))

 I '((command="O")!(command="U")) D  G TLSCOMDN

 . S message="INIT^XUTLS^Error: Invalid TLS command parameter, 'OPEN' or 'USE' only."

 . I @screen D @logger

 . S returnValue="0^"_message

 I @screen S message="INIT^XUTLS^Command parameter: "_command D @logger

 ;

 ; Validate the DEVICENAME passed in

 S deviceName=$G(ADEVICENAME)

 I '$L(deviceName) D  G TLSCOMDN

 . S message="INIT^XUTLS^Error: Undefined devicename parameter."

 . I @screen D @logger

 . S returnValue="0^"_message

 I '(deviceName?1"|TCP|".(1.10N1"|")1.10N) D  G TLSCOMDN

 . S message="INIT^XUTLS^Error: Invalid devicename parameter, devicename must be of the form: '|TCP|PORT'."

 . I @screen D @logger

 . S returnValue="0^"_message

 I @screen S message="INIT^XUTLS^Device: "_deviceName D @logger

 ;

 ; If the TLSCONFIGNAME is not passed in, read the default TLS configuration name.

 S TLSConfigName=$G(ATLSCONFIGNAME)

 I '$L(TLSConfigName) D

 . S returnValue=$$GKSPTLSCN()

 . I (+returnValue) S TLSConfigName=$P(returnValue,"^",2)

 I '$L(TLSConfigName) G TLSCOMDN

 I @screen S message="INIT^XUTLS^ConfigName: "_TLSConfigName D @logger

 ;

 ; Validate the TLSConfigName

 S validTLSConfig=$$ISTLSSERVERCONF(TLSConfigName)

 I 'validTLSConfig D  G TLSCOMDN

 . S message="INIT^XUTLS^Error: Invalid TLS configuration name: '"_TLSConfigName_"'."

 . I @screen D @logger

 . S returnValue="0^"_message

 S TLSCommand=command_" """_deviceName_""":(::/TLS="""_TLSConfigName_""")"

 ;

 ; Add the timeout for an OPEN command

 I command="O" D

 . S timeout=+$G(ATIMEOUT)

 . I 'timeout D  ; If the timeout is not passed in, use defaultTimeout

 .. S timeout=defaultTimeout

 .. I VERBOSE W !,"Defaulting timeout: ",timeout,!

 . S TLSCommand=TLSCommand_":"_timeout

 I @screen S message="INIT^XUTLS^Full Command: "_TLSCommand D @logger

 ;

 ; Open/Use the device

 X TLSCommand

 ;O deviceName:(::/TLS=TLSConfigName):timeout ; THIS WORKS

 I '$T S returnValue="0^INIT^XUTLS^Error: "_TLSCommand_" Failed, $ZA^$ZB: "_$ZA_"^"_$ZB G TLSCOMDN

 S returnValue="1^INIT^XUTLS^"_TLSCommand

 ;

TLSCOMDN ;

 I VERBOSE W !,"INIT^XUTLS(""",$G(ACOMMAND),""",""",$G(ADEVICENAME),""",""",$G(ATLSCONFIGNAME),""",",$G(ATIMEOUT),",""",$G(ASCREEN),""",""",$G(ALOGGER),""") Exiting. Returning: ",returnValue,!!

 I 'returnValue D APPERROR($P(returnValue,"^",4))

 I @screen S message="INIT^XUTLS^Status: "_$E(returnValue,1) D @logger

 Q returnValue

 ;

 ;

 ; Setup the log, Clear the log location.

 ;

 ;   Note: purgeDate is hard coded to 7 days past the current Date.

 ;

 ; Parameters

 ;   AROUTINE - The name of the routine starting to log.

 ;   ADAYSUP  - The number of days until log is purged.

 ;

 ; D LOGSTART^XUTLS("XUTLS",5)

 ;

LOGSTART(AROUTINE,ADAYSUP) ;Clear the debug log

 N routine,currentDateTime,currentDate,daysUntilPurge,purgeDate

 S routine="UNKNOWN"

 I $L($G(AROUTINE)) S routine=$G(AROUTINE)

 S currentDateTime=$$NOW,currentDate=$P(currentDateTime,".",1)

 ;

 ; Initialize the logger for this session and date

 K ^XTMP("TLS "_$J_" "_currentDate)

 ;

 ; Set the create date and purge date for the logger

 S daysUntilPurge=7

 S:+($G(ADAYSUP))>0 daysUntilPurge=+($G(ADAYSUP))

 S purgeDate=$$FMADD(currentDate,daysUntilPurge)

 S ^XTMP("TLS "_$J_" "_currentDate,0)=purgeDate_"^"_currentDate_"^"_"TLS INIT logging"

 ;

 ; Initialize the message counter

 S ^XTMP("TLS "_$J_" "_currentDate,.1)=0

 D LOG("LOGSTART^XUTLS^Log start: "_routine)

 Q

 ;

 ;

 ; Log AMESSAGE to ^XTMP("TLS "_$J_" "_currentDate)

 ;

 ; Parameters

 ;   AMESSAGE - A TLS message to log.

 ;

 ; D LOG^XUTLS("A Test TLS Log Message")

 ;

 ; S A="TLS " F  S A=$O(^XTMP(A)) Q:A'["TLS"  ZW ^XTMP(A)

 ; S A="TLS "_$J F  S A=$O(^XTMP(A)) Q:A'[("TLS "_$J)  ZW ^XTMP(A)

 ; 

LOG(AMESSAGE) ;

 N count,currentDateTime,currentDate,currentTime

 Q:'$L($G(AMESSAGE))

 S currentDateTime=$$NOW,currentDate=$P(currentDateTime,".",1),currentTime=$P(currentDateTime,".",2)

 S count=1+$G(^XTMP("TLS "_$J_" "_currentDate,.1)),^(.1)=count,^(count)=$E(currentTime_"^"_AMESSAGE,1,255)

 Q

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---XUTLS   11472     printed  Jul 11, 2026@02:09:59                                                                                                                                                                                                      Page 2

XUTLS     ;SLC/JLA - TLS API's ; AUG 1, 2025@7:30

 +1       ;;8.0;KERNEL;**787**;Jul 10, 1995;Build 73

 +2       ;Per VA Directive 6402, this routine should not be modified.

 +3       ;

 +4       ;

 +5       ; External API's

 +6       ;

 +7       ; FileMan

GET1(AFILE,AIENS,AFIELD,AFLAGS,ATROOT,AMROOT)  QUIT $$GET1^DIQ($GET(AFILE),$GET(AIENS),$GET(AFIELD),$GET(AFLAGS),$GET(ATROOT),$GET(AMROOT))

DT()       QUIT $$DT^XLFDT()

NOW()      QUIT $$NOW^XLFDT()

FMADD(AFMDATE,ADAYS)  QUIT $$FMADD^XLFDT($GET(AFMDATE),$GET(ADAYS))

 +1       ;

 +2       ; KERNEL/TLS API's

UPSTR(ASTRING)  QUIT $$UP^XLFSTR($GET(ASTRING))

ISTLSSERVERCONF(ATLSCONFIGNAME)  QUIT $$ISTLSSERVERCONF^XUSUDO($GET(ATLSCONFIGNAME))

APPERROR(AMESSAGE)  DO APPERROR^%ZTER($GET(AMESSAGE))

           QUIT 

 +1       ;

 +2       ;

 +3       ; Get Kernel System Parameter "DEFAULT TLS SERVER CONFIG." (FILE=8989.3, FIELD=667)

 +4       ;

 +5       ; Returns

 +6       ;   0^GKSPTLSCN^XUTLS^Error message

 +7       ;   1^Default TLS Server Name

 +8       ;

 +9       ; KRNDEV>ZW ^DD(8989.3,667)

 +10      ; ^DD(8989.3,667,0)="DEFAULT TLS SERVER CONFIG.^FJ30^^667;1^K:$L(X)>30!($L(X)<3) X"

 +11      ; ^DD(8989.3,667,3)="Enter the number that corresponds to the TLS server configuration name."

 +12      ; ^DD(8989.3,667,21,0)="^^2^2^3250627^"

 +13      ; ^DD(8989.3,667,21,1,0)="This is the name of the default TLS server configuration used by Kernel "

 +14      ; ^DD(8989.3,667,21,2,0)="for TLS communication. It should not be blank. "

 +15      ; ^DD(8989.3,667,"DT")=3250627

 +16      ;

 +17      ; W $$GKSPTLSCN^XUTLS()    ;ZW ^XTV(8989.3,1,667)

 +18      ;

GKSPTLSCN() ;

 +1        NEW DTLSN,FILE,KSPIEN,TLSFIELD,EMA,RTNVAL

 +2        SET FILE=8989.3

           SET KSPIEN="1,"

           SET TLSFIELD=667

           SET EMA="ERRMSGA"

 +3        SET DTLSN=$$GET1(FILE,KSPIEN,TLSFIELD,,,EMA)

 +4        IF +$PIECE($GET(@EMA@("DIERR")),"^")

               Begin DoDot:1

 +5                SET RTNVAL="0^GKSPTLSCN^XUTLS^"_@EMA@("DIERR",1,"TEXT",1)

               End DoDot:1

 +6       IF '$TEST

               SET RTNVAL="1^"_DTLSN

 +7        QUIT RTNVAL

 +8       ;

 +9       ;

 +10      ; Initialize the already open TCP principal device to use TLS communication

 +11      ; following the RPC Broker expected return format

 +12      ;

 +13      ; Returns

 +14      ;   0^INIT^XUTLS^Error: <message>

 +15      ;   1^INIT^XUTLS^Use Command executed

 +16      ;   Sets XWBTLS to 0 by default and to 1 when $$INIT^XUTLS("USE",$P) is successful

 +17      ;

INITRPC(ARESULT) ;

 +1        SET XWBTLS=0

 +2        SET ARESULT=$$INIT^XUTLS("USE",$PRINCIPAL)

 +3        IF ARESULT

               SET XWBTLS=1

 +4        QUIT 

 +5       ;

 +6       ;

 +7       ; Initialize the already open TCP principal device to USE TLS communication.

 +8       ;

 +9       ; Returns

 +10      ;   0^INIT^XUTLS^Error: <message>

 +11      ;   1^INIT^XUTLS^Use Command executed

 +12      ;

INITUP    ;

 +1        NEW returnValue

 +2        SET returnValue=$$INIT("USE",$PRINCIPAL)

 +3        QUIT returnValue

 +4       ;

 +5       ;

 +6       ; Initialize the principal device to OPEN TLS communication.

 +7       ;

 +8       ; Returns

 +9       ;   0^INIT^XUTLS^Error: <message>

 +10      ;   1^INIT^XUTLS^Open Command executed

 +11      ;

INITOP    ;

 +1        NEW returnValue

 +2        SET returnValue=$$INIT("OPEN",$PRINCIPAL)

 +3        QUIT returnValue

 +4       ;

 +5       ;

 +6       ; A server-side USE command for TLS communication.

 +7       ;

 +8       ;   USE an existing open device for TLS communication.

 +9       ;

 +10      ;   USE:   USE device:(::/TLS=TLSConfigName):"mnespace"

 +11      ;

 +12      ;   Packet mode is the default if no mode is specified. If stream mode is disabled, the mode defaults to packet mode.

 +13      ;   In packet mode READ commands complete as soon as there is some data to return. 

 +14      ; 

 +15      ; Parameters

 +16      ;   ADEVICENAME    - A string of the form |TCP| followed by some number of numeric digits.

 +17      ;                    The numeric portion of the device name is called the device identifier.

 +18      ;                    This device identifier must be a unique TCP port number.

 +19      ;   ATLSCONFIGNAME - A TLS Configuration Name.

 +20      ;

 +21      ; Returns

 +22      ;   0^INIT^XUTLS^Error: <message>

 +23      ;   1^INIT^XUTLS^Use Command executed

 +24      ;

 +25      ; S ADEVICE="|TCP|1234"

 +26      ; S ATLSCN="server_encrypt"

 +27      ; W $$USE^XUTLS(ADEVICE,ATLSCN)

 +28      ;

USE(ADEVICENAME,ATLSCONFIGNAME) ;

 +1        NEW returnValue

 +2        SET returnValue=$$INIT("USE",ADEVICENAME,ATLSCONFIGNAME)

 +3        QUIT returnValue

 +4       ;

 +5       ;

 +6       ; A server-side TCP OPEN command for TLS communication.

 +7       ;

 +8       ;   OPEN establishes ownership of the specified device. The process retains ownership of the device until 

 +9       ;        the process either terminates or releases the device with a subsequent CLOSE command. While a 

 +10      ;        device is owned by a process, no other process can acquire or use the device.

 +11      ;

 +12      ;   OPEN device:(::/TLS=TLSConfigName):timeout:"mnespace"

 +13      ;

 +14      ;   Packet mode is the default if no mode is specified. If stream mode is disabled, the mode defaults to packet mode.

 +15      ;   In packet mode READ commands complete as soon as there is some data to return. 

 +16      ; 

 +17      ; Parameters

 +18      ;   ADEVICENAME    - A string of the form |TCP| followed by some number of numeric digits.

 +19      ;                    The numeric portion of the device name is called the device identifier.

 +20      ;                    This device identifier must be a unique TCP port number.

 +21      ;   ATLSCONFIGNAME - A TLS Configuration Name.

 +22      ;   ATIMEOUT       - A TCP OPEN command Timeout.

 +23      ;

 +24      ; Returns

 +25      ;   0^INIT^XUTLS^Error: <message>

 +26      ;   1^INIT^XUTLS^Open Command executed

 +27      ;

 +28      ; S ADEVICE="|TCP|1234"

 +29      ; S ATLSCN="server_encrypt"

 +30      ; S ATIMEOUT=5

 +31      ; W $$OPEN^XUTLS(ADEVICE,ATLSCN,ATIMEOUT)

 +32      ;

OPEN(ADEVICENAME,ATLSCONFIGNAME,ATIMEOUT) ;

 +1        NEW returnValue

 +2        SET returnValue=$$INIT("OPEN",ADEVICENAME,ATLSCONFIGNAME,ATIMEOUT)

 +3        QUIT returnValue

 +4       ;

 +5       ;

 +6       ; Initialize a server-side OPEN or USE command for TLS communication.

 +7       ;

 +8       ;   OPEN:  OPEN device:(::/TLS=TLSConfigName):timeout:"mnespace"

 +9       ;    USE:   USE device:(::/TLS=TLSConfigName):"mnespace"

 +10      ;

 +11      ; Parameters

 +12      ;   ACOMMAND       - A OPEN or USE command

 +13      ;   ADEVICENAME    - A string of the form |TCP| followed by some number of numeric digits.

 +14      ;                    The numeric portion of the device name is called the device identifier.

 +15      ;                    This device identifier must be a unique TCP port number.

 +16      ;   ATLSCONFIGNAME - A TLS Configuration Name.

 +17      ;   ATIMEOUT       - A TCP OPEN command Timeout.

 +18      ;   ASCREEN        - A Screen for logging (ex: XUDEBUG>2).

 +19      ;     If the ASCREEN parameter is NOT passed in, it defaults the local screen variable to 1. 

 +20      ;   ALOGGER        - A Logger to call to log messages when ASCREEN evaluates to true (ex: "LOG^XUTLS").

 +21      ;     If the ALOGGER parameter is NOT passed in, the local logger variable is set to the local logging funtion LOG

 +22      ;     Any logger passed in assumed to be ready for logging and must have the logging message as the first parameter.

 +23      ;

 +24      ; Returns

 +25      ;   0^INIT^XUTLS^Error: <message>

 +26      ;   1^INIT^XUTLS^<TLSCommand>

 +27      ;

 +28      ; S ACOMMAND="OPEN", S ACOMMAND="USE"

 +29      ; S ADEVICE="|TCP|1234",ATLSCN="server_encrypt",ATIMEOUT=5

 +30      ; S ADEVICE="|TCP|1234",ATLSCN="tls_encrypt_server",ATIMEOUT=5

 +31      ; S ASCREEN="XWBDEBUG>1",XWBDEBUG=2,ALOGGER="LOG^XWBTCPM"

 +32      ; W $$INIT^XUTLS(ACOMMAND,ADEVICE,ATLSCN,ATIMEOUT,ASCREEN,ALOGGER)

 +33      ;

INIT(ACOMMAND,ADEVICENAME,ATLSCONFIGNAME,ATIMEOUT,ASCREEN,ALOGGER) ;

 +1        NEW command,deviceName,TLSConfigName,timeout,TLSCommand,defaultTimeout,screen,logger,validTLSConfig,returnValue,message

 +2        SET returnValue=1

           SET validTLSConfig=1

           SET defaultTimeout=10

 +3        IF '$DATA(VERBOSE)

               NEW VERBOSE

               SET VERBOSE=0

 +4        IF VERBOSE

               WRITE !,"INIT^XUTLS(""",$GET(ACOMMAND),""",""",$GET(ADEVICENAME),""",""",$GET(ATLSCONFIGNAME),""",",$GET(ATIMEOUT),",""",$GET(ASCREEN),""",""",$GET(ALOGGER),""") Called",!!

 +5       ;

 +6       ; Define logger

 +7        SET screen=1

           SET logger="LOG(message)"

 +8        if $LENGTH($GET(ASCREEN))

               SET screen=$GET(ASCREEN)

 +9        IF $LENGTH($GET(ALOGGER))

               SET logger=$GET(ALOGGER)_"(message)"

 +10      IF '$TEST

               DO LOGSTART("XUTLS")

 +11      ;

 +12      ; Validate the COMMAND passed in

 +13       SET command=$GET(ACOMMAND)

 +14       IF '$LENGTH(command)

               Begin DoDot:1

 +15               SET message="INIT^XUTLS^Error: Undefined TLS command parameter, 'OPEN' or 'USE' only."

 +16               IF @screen

                       DO @logger

 +17               SET returnValue="0^"_message

               End DoDot:1

               GOTO TLSCOMDN

 +18       SET command=$$UPSTR($EXTRACT(command,1))

 +19       IF '((command="O")!(command="U"))

               Begin DoDot:1

 +20               SET message="INIT^XUTLS^Error: Invalid TLS command parameter, 'OPEN' or 'USE' only."

 +21               IF @screen

                       DO @logger

 +22               SET returnValue="0^"_message

               End DoDot:1

               GOTO TLSCOMDN

 +23       IF @screen

               SET message="INIT^XUTLS^Command parameter: "_command

               DO @logger

 +24      ;

 +25      ; Validate the DEVICENAME passed in

 +26       SET deviceName=$GET(ADEVICENAME)

 +27       IF '$LENGTH(deviceName)

               Begin DoDot:1

 +28               SET message="INIT^XUTLS^Error: Undefined devicename parameter."

 +29               IF @screen

                       DO @logger

 +30               SET returnValue="0^"_message

               End DoDot:1

               GOTO TLSCOMDN

 +31       IF '(deviceName?1"|TCP|".(1.10N1"|")1.10N)

               Begin DoDot:1

 +32               SET message="INIT^XUTLS^Error: Invalid devicename parameter, devicename must be of the form: '|TCP|PORT'."

 +33               IF @screen

                       DO @logger

 +34               SET returnValue="0^"_message

               End DoDot:1

               GOTO TLSCOMDN

 +35       IF @screen

               SET message="INIT^XUTLS^Device: "_deviceName

               DO @logger

 +36      ;

 +37      ; If the TLSCONFIGNAME is not passed in, read the default TLS configuration name.

 +38       SET TLSConfigName=$GET(ATLSCONFIGNAME)

 +39       IF '$LENGTH(TLSConfigName)

               Begin DoDot:1

 +40               SET returnValue=$$GKSPTLSCN()

 +41               IF (+returnValue)

                       SET TLSConfigName=$PIECE(returnValue,"^",2)

               End DoDot:1

 +42       IF '$LENGTH(TLSConfigName)

               GOTO TLSCOMDN

 +43       IF @screen

               SET message="INIT^XUTLS^ConfigName: "_TLSConfigName

               DO @logger

 +44      ;

 +45      ; Validate the TLSConfigName

 +46       SET validTLSConfig=$$ISTLSSERVERCONF(TLSConfigName)

 +47       IF 'validTLSConfig

               Begin DoDot:1

 +48               SET message="INIT^XUTLS^Error: Invalid TLS configuration name: '"_TLSConfigName_"'."

 +49               IF @screen

                       DO @logger

 +50               SET returnValue="0^"_message

               End DoDot:1

               GOTO TLSCOMDN

 +51       SET TLSCommand=command_" """_deviceName_""":(::/TLS="""_TLSConfigName_""")"

 +52      ;

 +53      ; Add the timeout for an OPEN command

 +54       IF command="O"

               Begin DoDot:1

 +55               SET timeout=+$GET(ATIMEOUT)

 +56      ; If the timeout is not passed in, use defaultTimeout

                   IF 'timeout

                       Begin DoDot:2

 +57                       SET timeout=defaultTimeout

 +58                       IF VERBOSE

                               WRITE !,"Defaulting timeout: ",timeout,!

                       End DoDot:2

 +59               SET TLSCommand=TLSCommand_":"_timeout

               End DoDot:1

 +60       IF @screen

               SET message="INIT^XUTLS^Full Command: "_TLSCommand

               DO @logger

 +61      ;

 +62      ; Open/Use the device

 +63       XECUTE TLSCommand

 +64      ;O deviceName:(::/TLS=TLSConfigName):timeout ; THIS WORKS

 +65       IF '$TEST

               SET returnValue="0^INIT^XUTLS^Error: "_TLSCommand_" Failed, $ZA^$ZB: "_$ZA_"^"_$ZB

               GOTO TLSCOMDN

 +66       SET returnValue="1^INIT^XUTLS^"_TLSCommand

 +67      ;

TLSCOMDN  ;

 +1        IF VERBOSE

               WRITE !,"INIT^XUTLS(""",$GET(ACOMMAND),""",""",$GET(ADEVICENAME),""",""",$GET(ATLSCONFIGNAME),""",",$GET(ATIMEOUT),",""",$GET(ASCREEN),""",""",$GET(ALOGGER),""") Exiting. Returning: ",returnValue,!!

 +2        IF 'returnValue

               DO APPERROR($PIECE(returnValue,"^",4))

 +3        IF @screen

               SET message="INIT^XUTLS^Status: "_$EXTRACT(returnValue,1)

               DO @logger

 +4        QUIT returnValue

 +5       ;

 +6       ;

 +7       ; Setup the log, Clear the log location.

 +8       ;

 +9       ;   Note: purgeDate is hard coded to 7 days past the current Date.

 +10      ;

 +11      ; Parameters

 +12      ;   AROUTINE - The name of the routine starting to log.

 +13      ;   ADAYSUP  - The number of days until log is purged.

 +14      ;

 +15      ; D LOGSTART^XUTLS("XUTLS",5)

 +16      ;

LOGSTART(AROUTINE,ADAYSUP) ;Clear the debug log

 +1        NEW routine,currentDateTime,currentDate,daysUntilPurge,purgeDate

 +2        SET routine="UNKNOWN"

 +3        IF $LENGTH($GET(AROUTINE))

               SET routine=$GET(AROUTINE)

 +4        SET currentDateTime=$$NOW

           SET currentDate=$PIECE(currentDateTime,".",1)

 +5       ;

 +6       ; Initialize the logger for this session and date

 +7        KILL ^XTMP("TLS "_$JOB_" "_currentDate)

 +8       ;

 +9       ; Set the create date and purge date for the logger

 +10       SET daysUntilPurge=7

 +11       if +($GET(ADAYSUP))>0

               SET daysUntilPurge=+($GET(ADAYSUP))

 +12       SET purgeDate=$$FMADD(currentDate,daysUntilPurge)

 +13       SET ^XTMP("TLS "_$JOB_" "_currentDate,0)=purgeDate_"^"_currentDate_"^"_"TLS INIT logging"

 +14      ;

 +15      ; Initialize the message counter

 +16       SET ^XTMP("TLS "_$JOB_" "_currentDate,.1)=0

 +17       DO LOG("LOGSTART^XUTLS^Log start: "_routine)

 +18       QUIT 

 +19      ;

 +20      ;

 +21      ; Log AMESSAGE to ^XTMP("TLS "_$J_" "_currentDate)

 +22      ;

 +23      ; Parameters

 +24      ;   AMESSAGE - A TLS message to log.

 +25      ;

 +26      ; D LOG^XUTLS("A Test TLS Log Message")

 +27      ;

 +28      ; S A="TLS " F  S A=$O(^XTMP(A)) Q:A'["TLS"  ZW ^XTMP(A)

 +29      ; S A="TLS "_$J F  S A=$O(^XTMP(A)) Q:A'[("TLS "_$J)  ZW ^XTMP(A)

 +30      ; 

LOG(AMESSAGE) ;

 +1        NEW count,currentDateTime,currentDate,currentTime

 +2        if '$LENGTH($GET(AMESSAGE))

               QUIT 

 +3        SET currentDateTime=$$NOW

           SET currentDate=$PIECE(currentDateTime,".",1)

           SET currentTime=$PIECE(currentDateTime,".",2)

 +4        SET count=1+$GET(^XTMP("TLS "_$JOB_" "_currentDate,.1))

           SET ^(.1)=count

           SET ^(count)=$EXTRACT(currentTime_"^"_AMESSAGE,1,255)

 +5        QUIT 

 +6       ;