INHUT5 ;JPD,KAC; 6 Feb 96 13:25;utilities
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
Q
;
INITIALS(X) ;Make initials from name
; Input: X (req) = name from which to extract initials
; format : LAST,FIRST MIDDLE
; Output: returns initials
Q $E($P(X,",",2))_$E($P(X," ",2))_$E(X)
NUM(X) ;--Converts a string to a number
; Input - X - String
; Returns - Numeric value
N I,Y
S Y="" F I=1:1:$L(X) S:"-.0123456789"[$E(X,I) Y=Y_$E(X,I)
Q +Y
F Q:$Y'<($G(IOSL)-5) W !
W !,?IOM/2-11,"*** End of Report ***"
I $E(IOST)="C" W ! I $$CR^UTSRD
Q ""
DATIM() ;date/time function
; Returns: Y - Date/time
N Y,%,%H,%I,X
D NOW^%DTC S Y=% D DD^%DT
Q Y
;
MUMPS ; Input transform for Selective Routing M Code free text fields (SRMC).
; Customized input transform adds ability to check for application
; team code that uses argumentless Locks or Kills.
;
; Input:
; X = value input by user
;
; Output:
; Kill X if value entered doesn't meet restrictions imposed by
; transform.
;
Q:'$D(X)
; disallow argumentless Locks
I (X?1"L"." ")!(X?.E1" "1"L"2" ".E)!(X?.E1" "1"L"." ")!(X?1"LOCK"." ")!(X?.E1" "1"LOCK"2" ".E)!(X?.E1" "1"LOCK"." ") K X Q
; disallow argumentless Kills
I (X?1"K"." ")!(X?.E1" "1"K"2" ".E)!(X?.E1" "1"K"." ")!(X?1"KILL"." ")!(X?.E1" "1"KILL"2" ".E)!(X?.E1" "1"KILL"." ") K X Q
I $$SC^INHUTIL1 D MUMPS^DIED ; validate M syntax
;;Modified for IHS to call DIM directly
I '$$SC^INHUTIL1 D ^DIM
Q
;
FINDRID(INSRDATA,INDEST) ; $$function - Determine if there is a match of
; RouteID in 1st subscript of INSRDATA array
; Input:
; INSRDATA - array of RouteID nodes to be checked with Destination Route ID table
; INDEST - INTERFACE DESTINATION IEN containing list of RouteIDs to ck
;
; Output:
; 1: Match NOT-FOUND
; 0: Match FOUND
;
N %,FNDDEST
; Loop through INSRDATA("RouteID") using "B" xref to identify a match in
; the destination's Route ID table
S FNDDEST=1,%="" F S %=$O(INSRDATA(%)) Q:'$L(%) I $O(^INRHD(INDEST,9,"B",%,0)) S FNDDEST=0 Q
Q FNDDEST
;
RCVSCRN(INSRCTL,INSRDATA,INA,INDA) ; Default Inbound Receiver screen.
; Provides screening logic based on minimum requirements for
; accepting a message at the Receiver process.
;
; Logic: If Receiving Facility field in MSH of inbound msg matches
; a Route ID entry for this inbound destination, accept msg into
; database, else, suppress receipt of msg.
;
; Called by: Application entry point (RCVSCRN^INHUT).
; D RCVSCRN^INHUT5(.INSRCTL,.INSRDATA,.INA,.INDA)
;
; Input:
; INSRCTL - array - screening logic control information
; "INTT" - (opt) INTERFACE TRANSACTION IEN for inbound msg
; "INDEST" - (req) INTERFACE DESTINATION IEN for inbound msg
; "INBPC" - (opt) BACKGROUND PROCESS CONTROL IEN for inbound msg
; "MSH" - (req) HL7 Message Header (MSH) string (not parsed)
; from inbound msg
; INA - (opt) Not used.
; INDA - (opt) Not used.
;
; Variables:
; INDELIM - HL7 Field Separator for inbound msg
; INRCVFAC - HL7 Receiving Facility field from inbound msg
;
; Output:
; INSRDATA - (pbr) array - screening logic return values
; false = receive msg into database
; true = suppress receipt of msg
; "Route ID" - identifies system to which to route msg. Multiple
; entries are allowed.
;
N INDELIM,INRCVFAC
K INSRDATA
I '$L($G(INSRCTL("MSH"))) S INSRDATA=0 Q ; no MSH - receive msg
;
; get Receiving Facility field from msg
S INDELIM=$E(INSRCTL("MSH"),4)
S INRCVFAC=$P(INSRCTL("MSH"),INDELIM,6)
;
I $L(INRCVFAC) S INSRDATA(INRCVFAC)="" Q ; return Route ID for lookup
;
; Receiving Facility = ""
; 1) no DEST - receive msg
; 2) Route IDs exist - suppress msg
; NO Route IDs - receive msg
S INSRDATA=$S('$G(INSRCTL("INDEST")):0,1:$D(^INRHD(INSRCTL("INDEST"),9,"B")))
Q
;
INHUT5 ;JPD,KAC; 6 Feb 96 13:25;utilities
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 QUIT
+4 ;
INITIALS(X) ;Make initials from name
+1 ; Input: X (req) = name from which to extract initials
+2 ; format : LAST,FIRST MIDDLE
+3 ; Output: returns initials
+4 QUIT $EXTRACT($PIECE(X,",",2))_$EXTRACT($PIECE(X," ",2))_$EXTRACT(X)
NUM(X) ;--Converts a string to a number
+1 ; Input - X - String
+2 ; Returns - Numeric value
+3 NEW I,Y
+4 SET Y=""
FOR I=1:1:$LENGTH(X)
IF "-.0123456789"[$EXTRACT(X,I)
SET Y=Y_$EXTRACT(X,I)
+5 QUIT +Y
+1 FOR
IF $Y'<($GET(IOSL)-5)
QUIT
WRITE !
+2 WRITE !,?IOM/2-11,"*** End of Report ***"
+3 IF $EXTRACT(IOST)="C"
WRITE !
IF $$CR^UTSRD
+4 QUIT ""
DATIM() ;date/time function
+1 ; Returns: Y - Date/time
+2 NEW Y,%,%H,%I,X
+3 DO NOW^%DTC
SET Y=%
DO DD^%DT
+4 QUIT Y
+5 ;
MUMPS ; Input transform for Selective Routing M Code free text fields (SRMC).
+1 ; Customized input transform adds ability to check for application
+2 ; team code that uses argumentless Locks or Kills.
+3 ;
+4 ; Input:
+5 ; X = value input by user
+6 ;
+7 ; Output:
+8 ; Kill X if value entered doesn't meet restrictions imposed by
+9 ; transform.
+10 ;
+11 IF '$DATA(X)
QUIT
+12 ; disallow argumentless Locks
+13 IF (X?1"L"." ")!(X?.E1" "1"L"2" ".E)!(X?.E1" "1"L"." ")!(X?1"LOCK"." ")!(X?.E1" "1"LOCK"2" ".E)!(X?.E1" "1"LOCK"." ")
KILL X
QUIT
+14 ; disallow argumentless Kills
+15 IF (X?1"K"." ")!(X?.E1" "1"K"2" ".E)!(X?.E1" "1"K"." ")!(X?1"KILL"." ")!(X?.E1" "1"KILL"2" ".E)!(X?.E1" "1"KILL"." ")
KILL X
QUIT
+16 ; validate M syntax
IF $$SC^INHUTIL1
DO MUMPS^DIED
+17 ;;Modified for IHS to call DIM directly
+18 IF '$$SC^INHUTIL1
DO ^DIM
+19 QUIT
+20 ;
FINDRID(INSRDATA,INDEST) ; $$function - Determine if there is a match of
+1 ; RouteID in 1st subscript of INSRDATA array
+2 ; Input:
+3 ; INSRDATA - array of RouteID nodes to be checked with Destination Route ID table
+4 ; INDEST - INTERFACE DESTINATION IEN containing list of RouteIDs to ck
+5 ;
+6 ; Output:
+7 ; 1: Match NOT-FOUND
+8 ; 0: Match FOUND
+9 ;
+10 NEW %,FNDDEST
+11 ; Loop through INSRDATA("RouteID") using "B" xref to identify a match in
+12 ; the destination's Route ID table
+13 SET FNDDEST=1
SET %=""
FOR
SET %=$ORDER(INSRDATA(%))
IF '$LENGTH(%)
QUIT
IF $ORDER(^INRHD(INDEST,9,"B",%,0))
SET FNDDEST=0
QUIT
+14 QUIT FNDDEST
+15 ;
RCVSCRN(INSRCTL,INSRDATA,INA,INDA) ; Default Inbound Receiver screen.
+1 ; Provides screening logic based on minimum requirements for
+2 ; accepting a message at the Receiver process.
+3 ;
+4 ; Logic: If Receiving Facility field in MSH of inbound msg matches
+5 ; a Route ID entry for this inbound destination, accept msg into
+6 ; database, else, suppress receipt of msg.
+7 ;
+8 ; Called by: Application entry point (RCVSCRN^INHUT).
+9 ; D RCVSCRN^INHUT5(.INSRCTL,.INSRDATA,.INA,.INDA)
+10 ;
+11 ; Input:
+12 ; INSRCTL - array - screening logic control information
+13 ; "INTT" - (opt) INTERFACE TRANSACTION IEN for inbound msg
+14 ; "INDEST" - (req) INTERFACE DESTINATION IEN for inbound msg
+15 ; "INBPC" - (opt) BACKGROUND PROCESS CONTROL IEN for inbound msg
+16 ; "MSH" - (req) HL7 Message Header (MSH) string (not parsed)
+17 ; from inbound msg
+18 ; INA - (opt) Not used.
+19 ; INDA - (opt) Not used.
+20 ;
+21 ; Variables:
+22 ; INDELIM - HL7 Field Separator for inbound msg
+23 ; INRCVFAC - HL7 Receiving Facility field from inbound msg
+24 ;
+25 ; Output:
+26 ; INSRDATA - (pbr) array - screening logic return values
+27 ; false = receive msg into database
+28 ; true = suppress receipt of msg
+29 ; "Route ID" - identifies system to which to route msg. Multiple
+30 ; entries are allowed.
+31 ;
+32 NEW INDELIM,INRCVFAC
+33 KILL INSRDATA
+34 ; no MSH - receive msg
IF '$LENGTH($GET(INSRCTL("MSH")))
SET INSRDATA=0
QUIT
+35 ;
+36 ; get Receiving Facility field from msg
+37 SET INDELIM=$EXTRACT(INSRCTL("MSH"),4)
+38 SET INRCVFAC=$PIECE(INSRCTL("MSH"),INDELIM,6)
+39 ;
+40 ; return Route ID for lookup
IF $LENGTH(INRCVFAC)
SET INSRDATA(INRCVFAC)=""
QUIT
+41 ;
+42 ; Receiving Facility = ""
+43 ; 1) no DEST - receive msg
+44 ; 2) Route IDs exist - suppress msg
+45 ; NO Route IDs - receive msg
+46 SET INSRDATA=$SELECT('$GET(INSRCTL("INDEST")):0,1:$DATA(^INRHD(INSRCTL("INDEST"),9,"B")))
+47 QUIT
+48 ;
