INHUT7 ; KAC ; 8 Jan 98 17:16; HL7 Utilities
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
Q
;
GETDEST(INACKTT,INA,INACKDST,INACKUIF) ; $$function - Used to support routing
; of Application Acknowledgement messages to the originating system
; when multiple instantiations of a remote system type exist. Only
; one of the input parameters (INA,INACKDST,INACKUIF) must be
; specified by the caller to route an Application Ack. If a valid
; destination cannot be identified, a fatal script error is logged
; and the O/P Ctlr will log an error in ^INTHER.
;
; Called by: SCRIPT GENERATOR MESSAGE file, Outgoing Initial MUMPS
; Code field, S INDEST=$$GETDEST^INHUT(INTT,.INA,INDEST)
;
; Input:
; INACKTT - (req) INTERFACE TRANSACTION TYPE IEN for Application
; Ack. Used for error handling.
; INA - (req) array containing information for routing
; Application Ack to originator's dest as
; specified by GIS Receiver
; INACKDST - (opt) INTERFACE DESTINATION IEN for outbound
; Application Ack as specified by user
; INACKUIF - (opt) UNIVERSAL INTERFACE IEN for outbound Application
; Ack. Contains destination specified for this
; Ack at time of Ack creation. Future implementation.
;
; Variables:
; X - scratch
; INERRMSG - error message to be returned in INHERR by Ack script
;
; Output:
; - INTERFACE DESTINATION IEN for outbound Application Ack
; - "" if fails to find valid dest
;
N INERRMSG,X
;
; GIS-Receiver-specified dest
I $G(INA("INDEST")),$D(^INRHD(INA("INDEST"),0)) Q INA("INDEST")
;
; User-specified dest
I $G(INACKDST),$D(^INRHD(INACKDST,0)) Q INACKDST
;
; Ack msg exists - use dest specified at time of msg creation
I $G(INACKUIF) S X=$P($G(^INTHU(INACKUIF,0)),U,2) I X,$D(^INRHD(X,0)) Q X
;
; Error - no valid destinations identified
S INERRMSG="Application Ack creation failed - no valid destinations identified for Ack transaction type "_$S($G(INACKTT):$P($G(^INRHT(INACKTT,0)),U),1:"")
D ERROR^INHS(INERRMSG,2) ; fatal Ack script error - set INHERR
Q ""
;
SUBESC(INREC,INDEL,INB) ;Substitute escape delimeters to and from HL7
; spec
;Input:
; INREC - Portion of HL7 MSG to check
; INDEL(opt) = FSRET values - each position is critical
; ie S INDEL="^\|~&"
; or
; array of delimiters
; S INDEL("F")="^"
; S INDEL("S")="\"
; S INDEL("R")="|"
; S INDEL("E")="~"
; S INDEL("T")="&"
; INB - I inbound, O outbound
;Returns - Record with replace values
;Outbound
Q:$G(INB)="O" $$CNVDLM(.INREC,.INDEL)
;Inbound
Q:$G(INB)="I" $$DLMCNV(.INREC,.INDEL)
Q INREC
CNVDLM(INREC,INDEL) ;;Convert delimeters to HL7 specifications if in record
; Input: INREC - Portion of HL7 MSG to check
; INDEL(opt) = FSRET values - each position is critical
; ie S INDEL="^\|~&"
; or
; array of delimiters
; S INDEL("F")="^"
; S INDEL("S")="\"
; S INDEL("R")="|"
; S INDEL("E")="~"
; S INDEL("T")="&"
; Returns - Record with replace values
;
N INF,I,J,K,E,R,S,F,T,INREC1,IND
S (INREC1,E,R,S,F,T)="",IND="FSRET"
I $L($G(INDEL)) F I=1:1:5 S @$E(IND,I)=$E(INDEL,I)
E I $D(INDEL)>1 S I="" F S I=$O(INDEL(I)) Q:I="" S @I=INDEL(I)
S:E="" E=$$ESC^INHUT() S:R="" R=$$REP^INHUT() S:S="" S=$$COMP^INHUT()
S:F="" F=$$FIELD^INHUT() S:T="" T=$$SUBCOMP^INHUT()
;
;Set array of HL7 delimters to replacement value
S J(R)=E_"R"_E,J(S)=E_"S"_E,J(E)=E_"E"_E,J(F)=E_"F"_E,J(T)=E_"T"_E
;
;loop through record looking for HL7 delimters
F K=1:1:$L(INREC) D
.;if special character doesn't exist keep else replace
.I '$D(J($E(INREC,K))) S INREC1=INREC1_$E(INREC,K)
.E S INREC1=INREC1_J($E(INREC,K))
Q INREC1
DLMCNV(INREC,INDEL) ;;HL7 specifications to correct delimitor if in record
; Input: INREC - Portion of HL7 MSG to check
; INDEL(opt) = FSRET values - each position is critical
; ie S INDEL="^\|~&"
; or
; array of delimiters
; S INDEL("F")="^"
; S INDEL("S")="\"
; S INDEL("R")="|"
; S INDEL("E")="~"
; S INDEL("T")="&"
; Returns - Record with replace values
;
N INF,I,J,K,E,R,S,F,T,INREC1,IND
S (INREC1,E,R,S,F,T)="",IND="FSRET"
I $L($G(INDEL)) F I=1:1:5 S @$E(IND,I)=$E(INDEL,I)
E I $D(INDEL)>1 S I="" F S I=$O(INDEL(I)) Q:I="" S @I=INDEL(I)
S:E="" E=$$ESC^INHUT() S:R="" R=$$REP^INHUT() S:S="" S=$$COMP^INHUT()
S:F="" F=$$FIELD^INHUT() S:T="" T=$$SUBCOMP^INHUT()
;
;Set array of HL7 delimters to replacement value
S J("R")=R,J("S")=S,J("E")=E,J("F")=F,J("T")=T
;
;loop through record looking for HL7 delimters
F S K=$F(INREC,E) Q:'K!($E(INREC,K+1)="") I $E(INREC,K+1)=E D
.S INREC1=INREC1_$E(INREC,1,K-2)
.I $D(J($E(INREC,K))) S INREC1=INREC1_J($E(INREC,K))
.E S INREC1=INREC1_$E(INREC,K-1,K+1)
.S INREC=$E(INREC,K+2,$L(INREC))
S INREC1=INREC1_INREC
Q INREC1
APPACK(INUIF,INAKMES,INASTAT,INERMSG) ;User API to ACKLOG^INHU
;
; Inputs:
; INUIF = UIF ien of ack message in Universal Interface file
; INAKMES = Acked message ID - Typically: @INV@("MSA2")
; INASTAT = Ack message status - Typically: @INV@("MSA1"), converted
; to 0=NAK or 1=ACK. ex: S INASTAT=("AA"=INASTAT)
; INERMSG = Message to store if NAK. Typically: @INV@("MSA6")
;
; Usage:
; D APPACK^INHUT(UIF,@INV@("MSA2"),@INV@("MSA1"),@INV@("MSA6"))
;
S INAKMES=$G(INAKMES),INASTAT=$G(INASTAT),INERMSG=$G(INERMSG)
N INFERR,INFMSG
S (INFERR,INFMSG)=""
;
I INAKMES="" S INFMSG="No message identified to acknowledge",INFERR=2
I 'INFERR D ;save the worst error
.I '$D(^INTHU("C",INAKMES)) S INFMSG="Acknowledge for unknown message ID - "_INAKMES,INFERR=2 Q
.I INASTAT S INASTAT=1 Q
.I $E(INASTAT,2)="A" S INASTAT=1 Q
.I INASTAT="" S INERMSG=$S($L(INERMSG):$E(INERMSG,1,475)_" ",1:"")_"No ACK status"
.S INASTAT=0
I INFERR D ERROR^INHS(INFMSG,INFERR) Q
D ACKLOG^INHU(INUIF,INAKMES,INASTAT,INERMSG)
Q
;
SETENV ;Set environment for GIS with DUZ postmaster array
S U="^",DUZ=.5,DUZ(0)="@",IO="",DTIME=1
;If Postmaster has no default division, find one and set it.
;IHS logic
I '$$SC^INHUTIL1 D SETDT^UTDT K Z Q
;CHCS logic
I '$P(^DIC(3,DUZ,0),U,16) D SETDIV
D SETDT^UTDT
D DUZAG^XUS1 ; set up agency codes, no user prompts
D ^XUDIV ; set up division. No user prompts since default div is set
K Z
Q
;
SETDIV ;Called from SETENV if needed to stuff the postmaster default division.
N INDEF,INDIV
S (INDEF,INDIV)=0 F S INDIV=$O(^DG(40.8,INDIV)) Q:'INDIV!INDEF D
.;Set as default if a) an inpatient facility and b) not inactive
.I $G(^DG(40.8,INDIV,8100)),'$G(^DG(40.8,INDIV,28)) S INDEF=INDIV
;If no divisions meet criteria, look for first non active division
I 'INDEF S INDEV=0 F S INDIV=$O(^DG(40.8,INDIV)) Q:'INDIV!INDEF D
.I '$G(^DG(40.8,INDIV,28)) S INDEF=INDIV
;If still no INDEFault, set default to first entry in 40.8
S:'INDEF INDEF=$O(^DG(40.8,0))
S DIE="^DIC(3,",DA=.5,DR="28.2///`"_INDEF D ^DIE
Q
;
INHUT7 ; KAC ; 8 Jan 98 17:16; HL7 Utilities
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 QUIT
+4 ;
GETDEST(INACKTT,INA,INACKDST,INACKUIF) ; $$function - Used to support routing
+1 ; of Application Acknowledgement messages to the originating system
+2 ; when multiple instantiations of a remote system type exist. Only
+3 ; one of the input parameters (INA,INACKDST,INACKUIF) must be
+4 ; specified by the caller to route an Application Ack. If a valid
+5 ; destination cannot be identified, a fatal script error is logged
+6 ; and the O/P Ctlr will log an error in ^INTHER.
+7 ;
+8 ; Called by: SCRIPT GENERATOR MESSAGE file, Outgoing Initial MUMPS
+9 ; Code field, S INDEST=$$GETDEST^INHUT(INTT,.INA,INDEST)
+10 ;
+11 ; Input:
+12 ; INACKTT - (req) INTERFACE TRANSACTION TYPE IEN for Application
+13 ; Ack. Used for error handling.
+14 ; INA - (req) array containing information for routing
+15 ; Application Ack to originator's dest as
+16 ; specified by GIS Receiver
+17 ; INACKDST - (opt) INTERFACE DESTINATION IEN for outbound
+18 ; Application Ack as specified by user
+19 ; INACKUIF - (opt) UNIVERSAL INTERFACE IEN for outbound Application
+20 ; Ack. Contains destination specified for this
+21 ; Ack at time of Ack creation. Future implementation.
+22 ;
+23 ; Variables:
+24 ; X - scratch
+25 ; INERRMSG - error message to be returned in INHERR by Ack script
+26 ;
+27 ; Output:
+28 ; - INTERFACE DESTINATION IEN for outbound Application Ack
+29 ; - "" if fails to find valid dest
+30 ;
+31 NEW INERRMSG,X
+32 ;
+33 ; GIS-Receiver-specified dest
+34 IF $GET(INA("INDEST"))
IF $DATA(^INRHD(INA("INDEST"),0))
QUIT INA("INDEST")
+35 ;
+36 ; User-specified dest
+37 IF $GET(INACKDST)
IF $DATA(^INRHD(INACKDST,0))
QUIT INACKDST
+38 ;
+39 ; Ack msg exists - use dest specified at time of msg creation
+40 IF $GET(INACKUIF)
SET X=$PIECE($GET(^INTHU(INACKUIF,0)),U,2)
IF X
IF $DATA(^INRHD(X,0))
QUIT X
+41 ;
+42 ; Error - no valid destinations identified
+43 SET INERRMSG="Application Ack creation failed - no valid destinations identified for Ack transaction type "_$SELECT($GET(INACKTT):$PIECE($GET(^INRHT(INACKTT,0)),U),1:"")
+44 ; fatal Ack script error - set INHERR
DO ERROR^INHS(INERRMSG,2)
+45 QUIT ""
+46 ;
SUBESC(INREC,INDEL,INB) ;Substitute escape delimeters to and from HL7
+1 ; spec
+2 ;Input:
+3 ; INREC - Portion of HL7 MSG to check
+4 ; INDEL(opt) = FSRET values - each position is critical
+5 ; ie S INDEL="^\|~&"
+6 ; or
+7 ; array of delimiters
+8 ; S INDEL("F")="^"
+9 ; S INDEL("S")="\"
+10 ; S INDEL("R")="|"
+11 ; S INDEL("E")="~"
+12 ; S INDEL("T")="&"
+13 ; INB - I inbound, O outbound
+14 ;Returns - Record with replace values
+15 ;Outbound
+16 IF $GET(INB)="O"
QUIT $$CNVDLM(.INREC,.INDEL)
+17 ;Inbound
+18 IF $GET(INB)="I"
QUIT $$DLMCNV(.INREC,.INDEL)
+19 QUIT INREC
CNVDLM(INREC,INDEL) ;;Convert delimeters to HL7 specifications if in record
+1 ; Input: INREC - Portion of HL7 MSG to check
+2 ; INDEL(opt) = FSRET values - each position is critical
+3 ; ie S INDEL="^\|~&"
+4 ; or
+5 ; array of delimiters
+6 ; S INDEL("F")="^"
+7 ; S INDEL("S")="\"
+8 ; S INDEL("R")="|"
+9 ; S INDEL("E")="~"
+10 ; S INDEL("T")="&"
+11 ; Returns - Record with replace values
+12 ;
+13 NEW INF,I,J,K,E,R,S,F,T,INREC1,IND
+14 SET (INREC1,E,R,S,F,T)=""
SET IND="FSRET"
+15 IF $LENGTH($GET(INDEL))
FOR I=1:1:5
SET @$EXTRACT(IND,I)=$EXTRACT(INDEL,I)
+16 IF '$TEST
IF $DATA(INDEL)>1
SET I=""
FOR
SET I=$ORDER(INDEL(I))
IF I=""
QUIT
SET @I=INDEL(I)
+17 IF E=""
SET E=$$ESC^INHUT()
IF R=""
SET R=$$REP^INHUT()
IF S=""
SET S=$$COMP^INHUT()
+18 IF F=""
SET F=$$FIELD^INHUT()
IF T=""
SET T=$$SUBCOMP^INHUT()
+19 ;
+20 ;Set array of HL7 delimters to replacement value
+21 SET J(R)=E_"R"_E
SET J(S)=E_"S"_E
SET J(E)=E_"E"_E
SET J(F)=E_"F"_E
SET J(T)=E_"T"_E
+22 ;
+23 ;loop through record looking for HL7 delimters
+24 FOR K=1:1:$LENGTH(INREC)
Begin DoDot:1
+25 ;if special character doesn't exist keep else replace
+26 IF '$DATA(J($EXTRACT(INREC,K)))
SET INREC1=INREC1_$EXTRACT(INREC,K)
+27 IF '$TEST
SET INREC1=INREC1_J($EXTRACT(INREC,K))
End DoDot:1
+28 QUIT INREC1
DLMCNV(INREC,INDEL) ;;HL7 specifications to correct delimitor if in record
+1 ; Input: INREC - Portion of HL7 MSG to check
+2 ; INDEL(opt) = FSRET values - each position is critical
+3 ; ie S INDEL="^\|~&"
+4 ; or
+5 ; array of delimiters
+6 ; S INDEL("F")="^"
+7 ; S INDEL("S")="\"
+8 ; S INDEL("R")="|"
+9 ; S INDEL("E")="~"
+10 ; S INDEL("T")="&"
+11 ; Returns - Record with replace values
+12 ;
+13 NEW INF,I,J,K,E,R,S,F,T,INREC1,IND
+14 SET (INREC1,E,R,S,F,T)=""
SET IND="FSRET"
+15 IF $LENGTH($GET(INDEL))
FOR I=1:1:5
SET @$EXTRACT(IND,I)=$EXTRACT(INDEL,I)
+16 IF '$TEST
IF $DATA(INDEL)>1
SET I=""
FOR
SET I=$ORDER(INDEL(I))
IF I=""
QUIT
SET @I=INDEL(I)
+17 IF E=""
SET E=$$ESC^INHUT()
IF R=""
SET R=$$REP^INHUT()
IF S=""
SET S=$$COMP^INHUT()
+18 IF F=""
SET F=$$FIELD^INHUT()
IF T=""
SET T=$$SUBCOMP^INHUT()
+19 ;
+20 ;Set array of HL7 delimters to replacement value
+21 SET J("R")=R
SET J("S")=S
SET J("E")=E
SET J("F")=F
SET J("T")=T
+22 ;
+23 ;loop through record looking for HL7 delimters
+24 FOR
SET K=$FIND(INREC,E)
IF 'K!($EXTRACT(INREC,K+1)="")
QUIT
IF $EXTRACT(INREC,K+1)=E
Begin DoDot:1
+25 SET INREC1=INREC1_$EXTRACT(INREC,1,K-2)
+26 IF $DATA(J($EXTRACT(INREC,K)))
SET INREC1=INREC1_J($EXTRACT(INREC,K))
+27 IF '$TEST
SET INREC1=INREC1_$EXTRACT(INREC,K-1,K+1)
+28 SET INREC=$EXTRACT(INREC,K+2,$LENGTH(INREC))
End DoDot:1
+29 SET INREC1=INREC1_INREC
+30 QUIT INREC1
APPACK(INUIF,INAKMES,INASTAT,INERMSG) ;User API to ACKLOG^INHU
+1 ;
+2 ; Inputs:
+3 ; INUIF = UIF ien of ack message in Universal Interface file
+4 ; INAKMES = Acked message ID - Typically: @INV@("MSA2")
+5 ; INASTAT = Ack message status - Typically: @INV@("MSA1"), converted
+6 ; to 0=NAK or 1=ACK. ex: S INASTAT=("AA"=INASTAT)
+7 ; INERMSG = Message to store if NAK. Typically: @INV@("MSA6")
+8 ;
+9 ; Usage:
+10 ; D APPACK^INHUT(UIF,@INV@("MSA2"),@INV@("MSA1"),@INV@("MSA6"))
+11 ;
+12 SET INAKMES=$GET(INAKMES)
SET INASTAT=$GET(INASTAT)
SET INERMSG=$GET(INERMSG)
+13 NEW INFERR,INFMSG
+14 SET (INFERR,INFMSG)=""
+15 ;
+16 IF INAKMES=""
SET INFMSG="No message identified to acknowledge"
SET INFERR=2
+17 ;save the worst error
IF 'INFERR
Begin DoDot:1
+18 IF '$DATA(^INTHU("C",INAKMES))
SET INFMSG="Acknowledge for unknown message ID - "_INAKMES
SET INFERR=2
QUIT
+19 IF INASTAT
SET INASTAT=1
QUIT
+20 IF $EXTRACT(INASTAT,2)="A"
SET INASTAT=1
QUIT
+21 IF INASTAT=""
SET INERMSG=$SELECT($LENGTH(INERMSG):$EXTRACT(INERMSG,1,475)_" ",1:"")_"No ACK status"
+22 SET INASTAT=0
End DoDot:1
+23 IF INFERR
DO ERROR^INHS(INFMSG,INFERR)
QUIT
+24 DO ACKLOG^INHU(INUIF,INAKMES,INASTAT,INERMSG)
+25 QUIT
+26 ;
SETENV ;Set environment for GIS with DUZ postmaster array
+1 SET U="^"
SET DUZ=.5
SET DUZ(0)="@"
SET IO=""
SET DTIME=1
+2 ;If Postmaster has no default division, find one and set it.
+3 ;IHS logic
+4 IF '$$SC^INHUTIL1
DO SETDT^UTDT
KILL Z
QUIT
+5 ;CHCS logic
+6 IF '$PIECE(^DIC(3,DUZ,0),U,16)
DO SETDIV
+7 DO SETDT^UTDT
+8 ; set up agency codes, no user prompts
DO DUZAG^XUS1
+9 ; set up division. No user prompts since default div is set
DO ^XUDIV
+10 KILL Z
+11 QUIT
+12 ;
SETDIV ;Called from SETENV if needed to stuff the postmaster default division.
+1 NEW INDEF,INDIV
+2 SET (INDEF,INDIV)=0
FOR
SET INDIV=$ORDER(^DG(40.8,INDIV))
IF 'INDIV!INDEF
QUIT
Begin DoDot:1
+3 ;Set as default if a) an inpatient facility and b) not inactive
+4 IF $GET(^DG(40.8,INDIV,8100))
IF '$GET(^DG(40.8,INDIV,28))
SET INDEF=INDIV
End DoDot:1
+5 ;If no divisions meet criteria, look for first non active division
+6 IF 'INDEF
SET INDEV=0
FOR
SET INDIV=$ORDER(^DG(40.8,INDIV))
IF 'INDIV!INDEF
QUIT
Begin DoDot:1
+7 IF '$GET(^DG(40.8,INDIV,28))
SET INDEF=INDIV
End DoDot:1
+8 ;If still no INDEFault, set default to first entry in 40.8
+9 IF 'INDEF
SET INDEF=$ORDER(^DG(40.8,0))
+10 SET DIE="^DIC(3,"
SET DA=.5
SET DR="28.2///`"_INDEF
DO ^DIE
+11 QUIT
+12 ;
