INHVCRA1 ;KAC,JKB ; 7 Mar 96 14:11; Application Server (ApS) Cont'd
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
;
Q ;no top entry
;
OPEN(INCHNL,INMEM,INADDR,INPORT,INIP) ; open a TCP socket
; Input : INCHNL (req) = will return channel of created socket or error
; msg if open fails, PBR
; INMEM ( ? ) = ?? - may be unnecessary, PBR
; INADDR (opt) = IP address of remote server to connect to as a
; client, or null to open as a server; if null,
; and PBR, will return address of client that
; connects
; INPORT (req) = IP port to open (client or server)
; INIP (req) = array of backround proc params, PBR
; also requires INBPN
; Output: void
N INI,INSTOP
F INI=1:1:INIP("OTRY") D OPEN^%INET(.INCHNL,.INMEM,.INADDR,INPORT,1) Q:INCHNL D WAIT^INHUVUT(INBPN,INIP("OHNG"),"",.INSTOP) Q:INSTOP
I 'INCHNL,INSTOP S INCHNL="process signalled to quit"
Q
;
RECEIVE(INV,INCHNL,INIP,INERR,INMEM) ; read socket
; Input : INV (req) = location to store message, PBR
; INCHNL (req) = socket
; INIP (req) = array of backround proc params, PBR
; INERR (opt) = error array, PBR
; INMEM ( ? ) = ?? - may be unnecessary, PBR
; also requires INBPN,U
; Output: 0=ok, 1=no response, 2=failure during receive, 3=fatal err
; init vars
N AP,APREC,INDONE,INORESP,INREC,INSMIN,INTTOT,INULRD,REC
S (APREC,AP,INDONE,INORESP,INTTOT,INULRD)="",INREC="REC"
S INSMIN=$S($P($G(^INRHSITE(1,0)),U,14):$P(^(0),U,14),1:2500)
; socket read loop
F D Q:INDONE!INORESP
.D RECV^%INET(.APREC,.INCHNL,INIP("RTO"),1)
.; handle receive errors
.I $D(APREC(0)) D Q
..; all but timeouts are fatal
..I APREC(0)'["TIMEOUT" S INDONE=1 Q
..; handle timeouts
..K APREC(0)
..S INULRD=INULRD+1 ; increment # of retries
..;I INULRD>INIP("RTRY") S INORESP=1 Q ; retries NOT currently active
..D WAIT^INHUVUT(INBPN,INIP("RHNG"),"",.INORESP) Q:INORESP
..S INTTOT=INTTOT+INIP("RTO")+INIP("RHNG")
..I INTTOT'<INIP("TMAX") S INORESP=1 Q
.; process end of msg
.I APREC[$C(28) D
..; if end of msg not clean, purge buffer (513 byte msg prob)
..I $P(APREC,$C(28),2)'=$C(13) N X S X="" D RECV^%INET(.X,.INCHNL,1,1)
..; remove end of msg sequence; set flag
..S APREC=$P(APREC,$C(28)),INDONE=1
.; remove start of msg sequence
.I APREC[$C(11) S APREC=$P(APREC,$C(11),2)
.; quit if nothing left
.Q:'$L(APREC)
.; switch to global storage if short on memory
.I $S<INSMIN,INREC'["^" K ^UTILITY("INREC",$J) M ^($J)=@INREC S INREC="^UTILITY(""INREC"","_$J_")"
.S AP=AP+1,@INREC@(AP)=APREC,INULRD=0
; if fatal error
I $D(APREC(0)) S INERR="fatal error: "_APREC(0) Q 3
; if no msg received
I 'AP S INERR="no message received from remote system" Q 1
; if remote system timed-out
I INORESP S INERR="remote system timed-out during transmission" Q 2
; msg receipt completed - parse it
D PARSE^INHUVUT1 K @INREC
Q 0
;
LOGLOCI ; LOG LOCATION input transform (4004,9.02)
I X=$E("GLOBAL",1,$L(X)) S X="GLOBAL" Q
I $L(X)>50 K X Q
I X[".DAT",$L($$OPENSEQ^%ZTFS1(X,"W")) C X Q
D TXTPTR^INHU1(3.5,.X,.Y) S:$D(X) X=$P(Y,U)
Q
;
LOGLOCO ; LOG LOCATION output transform (4004,9.02)
I Y?1.N,$D(^%ZIS(1,Y,0)) S Y=$P(^(0),U)
Q
;
LOG(MSG,TYP,ACK) ; log BACKGROUND PROCESS activity and errors
; Input : MSG (req) = status/error/debug message; status msg must be a
; string, error/debug msg can be a string (PBV) or
; an array of strings (PBR)
; TYP (opt) = msg type: S=status(def), E=error, or integer
; corresponding to level of a debug msg
; ACK (opt) = boolean flag; set true only when logging a
; positive ack (sets piece 3 of run node = $H)
; INBPN,U (req)
; INDEBUG,INDEBUGD,INHSRVR (opt)
; Output: void
; INDEBUG,INDEBUGD if not set coming in
; if debug on, will write to debug log (file, device or global)
; Local : ENUM = INTERFACE ERROR ptr
; T = timestamp
; SRVR = server number or 0 if not a multiple background proc
I '$D(INDEBUG) D DEBUG()
N SRVR S SRVR=+$G(INHSRVR),TYP=$G(TYP)
; if debugging, write to log
I INDEBUG,INDEBUG'<TYP D
.I $D(MSG)=1,$L(MSG) S MSG(1)=MSG
.N J,T S J="",T=$$NOW^%ZTFDT
.I INDEBUGD="GLOBAL" D Q
..N I S I=$O(^UTILITY("INDEBUG",INBPN,SRVR,$J,""),-1)
..F I=I+1:1 S J=$O(MSG(J)) Q:J="" S ^(I)=T_U_MSG(J) ;NAKED on ^UTILITY
.U INDEBUGD F S J=$O(MSG(J)) Q:J="" W !,INBPN_U_SRVR_U_T_U_MSG(J)
Q:TYP
; on error, log in error file and abbrev msg text to point to it
I TYP="E" N ENUM D LOAD^INHE("","","","R","","","",.MSG,INBPN,.ENUM) S MSG="Error "_$G(ENUM)
; update "run" node (format: Status$H^StatusText^LastPositiveAck$H)
I SRVR S $P(^INRHB("RUN","SRVR",INBPN,SRVR),U,1,2)=$H_U_MSG S:$G(ACK) $P(^(SRVR),U,3)=$H Q
S $P(^INRHB("RUN",INBPN),U,1,2)=$H_U_MSG S:$G(ACK) $P(^(INBPN),U,3)=$H
Q
;
DEBUG(L) ; set debug params for a BACKGROUND PROCESS
; Input : L (opt) = debug level; "" = look it up (def), 0 = turn it
; off, positive integer = set it
; also expects INBPN
; Output: void
; INDEBUG = Debug Level
; INDEBUGD = Log Location
; if debug level input is null, look it up
S INDEBUG=$S($L($G(L)):L,1:$P($G(^INTHPC(INBPN,9)),U))
; if debug off, close log loc if not a global, then kill var and quit
I 'INDEBUG D Q
.I $L($G(INDEBUGD)) D:INDEBUGD'="GLOBAL" ^%ZISC K INDEBUGD
; debug is on - get log loc
S INDEBUGD=$P(^INTHPC(INBPN,9),U,2)
; quit if no need to open (is a global or $P)
I "GLOBAL"[INDEBUGD S:INDEBUGD="" INDEBUGD=$P Q
; if a device ptr, resolve it
I INDEBUGD,$D(^%ZIS(1,INDEBUGD,0)) S INDEBUGD=$P(^(0),U)
; open the device - if can't, use $P
S IOP=INDEBUGD D ^%ZIS I POP S IOP="" D ^%ZIS
S INDEBUGD=IO
Q
INHVCRA1 ;KAC,JKB ; 7 Mar 96 14:11; Application Server (ApS) Cont'd
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 ;
+4 ;no top entry
QUIT
+5 ;
OPEN(INCHNL,INMEM,INADDR,INPORT,INIP) ; open a TCP socket
+1 ; Input : INCHNL (req) = will return channel of created socket or error
+2 ; msg if open fails, PBR
+3 ; INMEM ( ? ) = ?? - may be unnecessary, PBR
+4 ; INADDR (opt) = IP address of remote server to connect to as a
+5 ; client, or null to open as a server; if null,
+6 ; and PBR, will return address of client that
+7 ; connects
+8 ; INPORT (req) = IP port to open (client or server)
+9 ; INIP (req) = array of backround proc params, PBR
+10 ; also requires INBPN
+11 ; Output: void
+12 NEW INI,INSTOP
+13 FOR INI=1:1:INIP("OTRY")
DO OPEN^%INET(.INCHNL,.INMEM,.INADDR,INPORT,1)
IF INCHNL
QUIT
DO WAIT^INHUVUT(INBPN,INIP("OHNG"),"",.INSTOP)
IF INSTOP
QUIT
+14 IF 'INCHNL
IF INSTOP
SET INCHNL="process signalled to quit"
+15 QUIT
+16 ;
RECEIVE(INV,INCHNL,INIP,INERR,INMEM) ; read socket
+1 ; Input : INV (req) = location to store message, PBR
+2 ; INCHNL (req) = socket
+3 ; INIP (req) = array of backround proc params, PBR
+4 ; INERR (opt) = error array, PBR
+5 ; INMEM ( ? ) = ?? - may be unnecessary, PBR
+6 ; also requires INBPN,U
+7 ; Output: 0=ok, 1=no response, 2=failure during receive, 3=fatal err
+8 ; init vars
+9 NEW AP,APREC,INDONE,INORESP,INREC,INSMIN,INTTOT,INULRD,REC
+10 SET (APREC,AP,INDONE,INORESP,INTTOT,INULRD)=""
SET INREC="REC"
+11 SET INSMIN=$SELECT($PIECE($GET(^INRHSITE(1,0)),U,14):$PIECE(^(0),U,14),1:2500)
+12 ; socket read loop
+13 FOR
Begin DoDot:1
+14 DO RECV^%INET(.APREC,.INCHNL,INIP("RTO"),1)
+15 ; handle receive errors
+16 IF $DATA(APREC(0))
Begin DoDot:2
+17 ; all but timeouts are fatal
+18 IF APREC(0)'["TIMEOUT"
SET INDONE=1
QUIT
+19 ; handle timeouts
+20 KILL APREC(0)
+21 ; increment # of retries
SET INULRD=INULRD+1
+22 ;I INULRD>INIP("RTRY") S INORESP=1 Q ; retries NOT currently active
+23 DO WAIT^INHUVUT(INBPN,INIP("RHNG"),"",.INORESP)
IF INORESP
QUIT
+24 SET INTTOT=INTTOT+INIP("RTO")+INIP("RHNG")
+25 IF INTTOT'<INIP("TMAX")
SET INORESP=1
QUIT
End DoDot:2
QUIT
+26 ; process end of msg
+27 IF APREC[$CHAR(28)
Begin DoDot:2
+28 ; if end of msg not clean, purge buffer (513 byte msg prob)
+29 IF $PIECE(APREC,$CHAR(28),2)'=$CHAR(13)
NEW X
SET X=""
DO RECV^%INET(.X,.INCHNL,1,1)
+30 ; remove end of msg sequence; set flag
+31 SET APREC=$PIECE(APREC,$CHAR(28))
SET INDONE=1
End DoDot:2
+32 ; remove start of msg sequence
+33 IF APREC[$CHAR(11)
SET APREC=$PIECE(APREC,$CHAR(11),2)
+34 ; quit if nothing left
+35 IF '$LENGTH(APREC)
QUIT
+36 ; switch to global storage if short on memory
+37 IF $STORAGE<INSMIN
IF INREC'["^"
KILL ^UTILITY("INREC",$JOB)
MERGE ^($JOB)=@INREC
SET INREC="^UTILITY(""INREC"","_$JOB_")"
+38 SET AP=AP+1
SET @INREC@(AP)=APREC
SET INULRD=0
End DoDot:1
IF INDONE!INORESP
QUIT
+39 ; if fatal error
+40 IF $DATA(APREC(0))
SET INERR="fatal error: "_APREC(0)
QUIT 3
+41 ; if no msg received
+42 IF 'AP
SET INERR="no message received from remote system"
QUIT 1
+43 ; if remote system timed-out
+44 IF INORESP
SET INERR="remote system timed-out during transmission"
QUIT 2
+45 ; msg receipt completed - parse it
+46 DO PARSE^INHUVUT1
KILL @INREC
+47 QUIT 0
+48 ;
LOGLOCI ; LOG LOCATION input transform (4004,9.02)
+1 IF X=$EXTRACT("GLOBAL",1,$LENGTH(X))
SET X="GLOBAL"
QUIT
+2 IF $LENGTH(X)>50
KILL X
QUIT
+3 IF X[".DAT"
IF $LENGTH($$OPENSEQ^%ZTFS1(X,"W"))
CLOSE X
QUIT
+4 DO TXTPTR^INHU1(3.5,.X,.Y)
IF $DATA(X)
SET X=$PIECE(Y,U)
+5 QUIT
+6 ;
LOGLOCO ; LOG LOCATION output transform (4004,9.02)
+1 IF Y?1.N
IF $DATA(^%ZIS(1,Y,0))
SET Y=$PIECE(^(0),U)
+2 QUIT
+3 ;
LOG(MSG,TYP,ACK) ; log BACKGROUND PROCESS activity and errors
+1 ; Input : MSG (req) = status/error/debug message; status msg must be a
+2 ; string, error/debug msg can be a string (PBV) or
+3 ; an array of strings (PBR)
+4 ; TYP (opt) = msg type: S=status(def), E=error, or integer
+5 ; corresponding to level of a debug msg
+6 ; ACK (opt) = boolean flag; set true only when logging a
+7 ; positive ack (sets piece 3 of run node = $H)
+8 ; INBPN,U (req)
+9 ; INDEBUG,INDEBUGD,INHSRVR (opt)
+10 ; Output: void
+11 ; INDEBUG,INDEBUGD if not set coming in
+12 ; if debug on, will write to debug log (file, device or global)
+13 ; Local : ENUM = INTERFACE ERROR ptr
+14 ; T = timestamp
+15 ; SRVR = server number or 0 if not a multiple background proc
+16 IF '$DATA(INDEBUG)
DO DEBUG()
+17 NEW SRVR
SET SRVR=+$GET(INHSRVR)
SET TYP=$GET(TYP)
+18 ; if debugging, write to log
+19 IF INDEBUG
IF INDEBUG'<TYP
Begin DoDot:1
+20 IF $DATA(MSG)=1
IF $LENGTH(MSG)
SET MSG(1)=MSG
+21 NEW J,T
SET J=""
SET T=$$NOW^%ZTFDT
+22 IF INDEBUGD="GLOBAL"
Begin DoDot:2
+23 NEW I
SET I=$ORDER(^UTILITY("INDEBUG",INBPN,SRVR,$JOB,""),-1)
+24 ;NAKED on ^UTILITY
FOR I=I+1:1
SET J=$ORDER(MSG(J))
IF J=""
QUIT
SET ^(I)=T_U_MSG(J)
End DoDot:2
QUIT
+25 USE INDEBUGD
FOR
SET J=$ORDER(MSG(J))
IF J=""
QUIT
WRITE !,INBPN_U_SRVR_U_T_U_MSG(J)
End DoDot:1
+26 IF TYP
QUIT
+27 ; on error, log in error file and abbrev msg text to point to it
+28 IF TYP="E"
NEW ENUM
DO LOAD^INHE("","","","R","","","",.MSG,INBPN,.ENUM)
SET MSG="Error "_$GET(ENUM)
+29 ; update "run" node (format: Status$H^StatusText^LastPositiveAck$H)
+30 IF SRVR
SET $PIECE(^INRHB("RUN","SRVR",INBPN,SRVR),U,1,2)=$HOROLOG_U_MSG
IF $GET(ACK)
SET $PIECE(^(SRVR),U,3)=$HOROLOG
QUIT
+31 SET $PIECE(^INRHB("RUN",INBPN),U,1,2)=$HOROLOG_U_MSG
IF $GET(ACK)
SET $PIECE(^(INBPN),U,3)=$HOROLOG
+32 QUIT
+33 ;
DEBUG(L) ; set debug params for a BACKGROUND PROCESS
+1 ; Input : L (opt) = debug level; "" = look it up (def), 0 = turn it
+2 ; off, positive integer = set it
+3 ; also expects INBPN
+4 ; Output: void
+5 ; INDEBUG = Debug Level
+6 ; INDEBUGD = Log Location
+7 ; if debug level input is null, look it up
+8 SET INDEBUG=$SELECT($LENGTH($GET(L)):L,1:$PIECE($GET(^INTHPC(INBPN,9)),U))
+9 ; if debug off, close log loc if not a global, then kill var and quit
+10 IF 'INDEBUG
Begin DoDot:1
+11 IF $LENGTH($GET(INDEBUGD))
IF INDEBUGD'="GLOBAL"
DO ^%ZISC
KILL INDEBUGD
End DoDot:1
QUIT
+12 ; debug is on - get log loc
+13 SET INDEBUGD=$PIECE(^INTHPC(INBPN,9),U,2)
+14 ; quit if no need to open (is a global or $P)
+15 IF "GLOBAL"[INDEBUGD
IF INDEBUGD=""
SET INDEBUGD=$PRINCIPAL
QUIT
+16 ; if a device ptr, resolve it
+17 IF INDEBUGD
IF $DATA(^%ZIS(1,INDEBUGD,0))
SET INDEBUGD=$PIECE(^(0),U)
+18 ; open the device - if can't, use $P
+19 SET IOP=INDEBUGD
DO ^%ZIS
IF POP
SET IOP=""
DO ^%ZIS
+20 SET INDEBUGD=IO
+21 QUIT
