INHMGD3 ;CAR; 16 May 97 16:46;HL7 MESSAGING - MANAGEMENT OF DATA SOURCES
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
;
; MODULE NAME:
; HL7 Messaging - Data Source Display and Validation
; Handle Field (INHMGD3).
;
; PURPOSE:
; Module INHMGD3 is used to extract information describing the
; source file and field for HL7 Messaging segment fields.
;(X,INF,FLVL,.FILE,.INP)
FIELD(INFLD,INF,FLVL,FILE,INP) ;Handle a field in SCRIPT GENERATOR FIELD^4012
;
; Inputs:
; INFLD = Field index # into ^INTHL7F(INFLD,
; INF = Sequence Number
; FLVL = File SP
; FILE = File Stack
; INP = Output array (call by reference)
; Output:
; INP = Output array
;
N INSF,IN,INFLDC,INDENT,INUFL,INY,INSUPRES,INREQ,INREP,XFM,INFD
S INFLD(1)=^INTHL7S(INSEG,1,INFLD,0),INFLD(2)=INFLD,INFLD=+INFLD(1)
S INY=INFLD(1)
;get field specifications that are stored at the segment level:
S INREQ=$$YN^INHMGD1($P(INY,U,3)) ;required
S INREP=$$YN^INHMGD1($P(INY,U,4)) ;repeating field
S INUFL=$$YN^INHMGD1($P(INY,U,5)) ;used for lookup
S XFM=$$YN^INHMGD1($P(INY,U,6)) ;required to pass transform
S INFD("SQ")=INF ;sequence number
S INSVAR=$P(INSEG(0),U,2)_INF
;leaving the Flag_MessageName...SegmentName, remove any field data.
I INP S INP=$P(INP,TAB,1,8)_TAB_INF ;$P9 field sequence#
S INFLDC=INFLD,(INDENT,INSUPRES)=0
;
;check for subfields:
S INSF=$O(^INTHL7F(INFLD,10,0)),(IN(0),IN)=0
;
;Handle subfields ;INSF>0 subfields present
I INSF D Q
.S INSUPRES=1 D FD1 ;do the header field, first
.F S IN(0)=$O(^INTHL7F(INFLD,10,"AS",IN(0))) Q:'IN(0) D
..S IN(10)=$G(^INTHL7F(INFLD,10,+$O(^INTHL7F(INFLD,10,"AS",IN(0),0)),0))
..S INFLDC=+IN(10),IN=IN+1
..Q:'INFLDC Q:'$D(^INTHL7F(INFLDC,0))
..S INFLDC(0)=^INTHL7F(INFLDC,0),INSVAR=$P(INSEG(0),U,2)_INF_"."_IN
..S INREQ=$$YN^INHMGD1($P(IN(10),U,3))
..S INUFL=$$YN^INHMGD1($P(IN(10),U,4))
..S INDENT=1
..D FD1
;
FD1 ;one field
N INERR,INY
;
;get the field data
S (INY,INFLDC(0))=^INTHL7F(INFLDC,0)
;S INFLDC(4)=$G(^INTHL7F(INFLDC,4)) ;Input Xform
;S INFLDC(5)=$G(^INTHL7F(INFLDC,5)) ;Output Xform
;S INFLDC(50)=$G(^INTHL7F(INFLDC,50)) ;Map Function
S INFD("FN")=$P(INY,U) ;field name
S:$P(INY,U,2)="" $P(INY,U,2)=0
S INFD("DT")=$P($G(^INTHL7FT($P(INY,U,2),0)),U,2) ;data type abbrev
S INFD("LEN")=$P(INY,U,3) ;field length
S INFD("OIT")=$P(INY,U,5) ;override input transforms 1=yes
;
;process the field, o.k. to output column header if needed
D:INHF2<0 HDR2^INHMGD1 ;since we have data, now need to write col header
S INHF2=1 ;if we need a new page, write the col header
D PROC(.INFLDC,.INP)
S INHF2=0 ;if we need a new page, don't write the col header
Q
;
PROC(INFLDC,INP) ;Print the data source, utilizing the current Seg. File
N DICOMPX,INDESC,INDDL,INDL,INS,X,INJ,INX,INOLDX
;
;Use documented data type, if one exists.
I $P(INFLDC(0),U,12)]"" S INFD("DT")=$P(INFLDC(0),U,12)
I INFD("DT")="" D
.S ^UTILITY("INHMGD",$J,"E",INMSG,INSEG,INFLDC)=+FILE(FLVL)_U_"***NO DATA TYPE***"
;
S J(0)=FILE(FLVL),INDL=""
;Use documented data source, if one exists.
S INDL=$$LBTB^UTIL($P(INFLDC(0),U,11))
I INDL]"" S INOLDX=INDL,INDL="##"_INDL
;else use data location
I INDL="" S (INDL,INOLDX)=$$LBTB^UTIL($G(^INTHL7F(INFLDC,"C")))
;use DICOMP to get data location
I $L(INDL) D
.S INDL=$$RESOLVE(J(0),INDL)
.Q:$L(INDL)
.S ^UTILITY("INHMGD",$J,"E",INMSG,INSEG,INFLDC)=+FILE(FLVL)_U_INOLDX_" Unable to resolve or missing from Data Dictionary."
D PRINT^INHMGD4(INDL,.INP)
D:0 MAPXFRM^INHMGD4(.INFLDC)
Q
RESOLVE(INRT,INAD) ;Extrensic ***add DIC lookup
; Inputs:
; INRT = file#, or file name
; INAD = field string: e.g.: #.01:#.01:INTERNAL(#3.5)_";40.8"
; delimited by ":"
; Output:
; String containing Field#:File# (Field Name)
; with no leading spaces, and 1 space before the
; Field Name. e.g.: .01:8550 (NAME)
;
N DIC,X,Y,I,INAME,INFLD,INFIL,INJ,INS,INPY
S (INFIL,INFLD)=""
;
;fixup address from documented data source
I $E(INAD,1,2)="##" S INAD=$E(INAD,3,999) D
.S INFIL=$P(INAD,":",2) S:INFIL]"" INRT=INFIL
.S INAD=$P(INAD,":")
;
;find file number from file name:
I +INRT=0,$L(INRT) D ;make sure it's not like "8550^^CPG("
.K DIC S DIC="^DIC(",DIC(0)="FZ",X=INRT D ^DIC ;find file
.I Y>0 S INRT=+Y Q
.S DIC="^DD(",DIC(0)="FMZ",DIC("S")="I $P(^(0),U,2)" D ^DIC ;sub-file
.I Y>0 S INRT=+Y Q
S INRT=+INRT
I 'INRT D Q INAD_":"_INRT_" (FILE# MISSING***)"
.S ^UTILITY("INHMGD",$J,"E",INMSG,INSEG,INFLDC)=+FILE(FLVL)_U_"FILE# MISSING***"
;
;exit on quoted string or @ (user defined routine)
S INS=INAD
Q:INAD["@" INAD
I INAD'["INTERNAL" S X=$E(INAD) I X="""" Q INAD
;
;try a ^DD lookup
S X=$TR(INAD,"#") I X'[":" D Q:$L(INFIL) INFIL
.K DIC S DIC="^DD("_INRT_",",DIC(0)="FMZ" D ^DIC
.I Y>0 S INFIL=+Y_":"_INRT_" ("_Y(0,0)_")"
;
S J(0)=+INRT,I(0)="",DA="DA(",DQI="Y(",DICOMPX="",X=INAD
D ^DICOMP S INPY=$G(%Y)
I '$L($G(X)) Q ""
S INAME=""
;if DICOMPX has the results, just reassemble for PRINT
I $L($G(DICOMPX),U)>1 D Q INAD_$S($L(INAME):" ("_INAME_")",1:"")
.;rebuild the address for compatibility with PRINT
.S INFIL=+DICOMPX,INFLD=+$P(DICOMPX,U,2)
.S INAD=INFLD_":"_INFIL
.;
.;have the address, now look for the field name
.I $D(^DD(INFIL,INFLD,0)) S INAME=$P(^DD(INFIL,INFLD,0),U) Q
.;didn't find it, use what DICOMP returned
.I INPY'["^",+INPY'=INPY S INAME=INPY Q ;looks like text, use it.
.;still didn't find it, try using what we started with.
.I '$TR(INS,"#") S INAME=INS
;
I $L(X) D Q:$L(INFIL) INFIL
.S INFIL=""
.I INAD["NUMBER"!(INAD["#.001") S INFIL=".001:"_+FILE(FLVL)_" (NUMBER)"
.I INAD["INSITE" S INFIL="8000:4 (INSITE)"
Q ""
;
INHMGD3 ;CAR; 16 May 97 16:46;HL7 MESSAGING - MANAGEMENT OF DATA SOURCES
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 ;
+4 ; MODULE NAME:
+5 ; HL7 Messaging - Data Source Display and Validation
+6 ; Handle Field (INHMGD3).
+7 ;
+8 ; PURPOSE:
+9 ; Module INHMGD3 is used to extract information describing the
+10 ; source file and field for HL7 Messaging segment fields.
+11 ;(X,INF,FLVL,.FILE,.INP)
FIELD(INFLD,INF,FLVL,FILE,INP) ;Handle a field in SCRIPT GENERATOR FIELD^4012
+1 ;
+2 ; Inputs:
+3 ; INFLD = Field index # into ^INTHL7F(INFLD,
+4 ; INF = Sequence Number
+5 ; FLVL = File SP
+6 ; FILE = File Stack
+7 ; INP = Output array (call by reference)
+8 ; Output:
+9 ; INP = Output array
+10 ;
+11 NEW INSF,IN,INFLDC,INDENT,INUFL,INY,INSUPRES,INREQ,INREP,XFM,INFD
+12 SET INFLD(1)=^INTHL7S(INSEG,1,INFLD,0)
SET INFLD(2)=INFLD
SET INFLD=+INFLD(1)
+13 SET INY=INFLD(1)
+14 ;get field specifications that are stored at the segment level:
+15 ;required
SET INREQ=$$YN^INHMGD1($PIECE(INY,U,3))
+16 ;repeating field
SET INREP=$$YN^INHMGD1($PIECE(INY,U,4))
+17 ;used for lookup
SET INUFL=$$YN^INHMGD1($PIECE(INY,U,5))
+18 ;required to pass transform
SET XFM=$$YN^INHMGD1($PIECE(INY,U,6))
+19 ;sequence number
SET INFD("SQ")=INF
+20 SET INSVAR=$PIECE(INSEG(0),U,2)_INF
+21 ;leaving the Flag_MessageName...SegmentName, remove any field data.
+22 ;$P9 field sequence#
IF INP
SET INP=$PIECE(INP,TAB,1,8)_TAB_INF
+23 SET INFLDC=INFLD
SET (INDENT,INSUPRES)=0
+24 ;
+25 ;check for subfields:
+26 SET INSF=$ORDER(^INTHL7F(INFLD,10,0))
SET (IN(0),IN)=0
+27 ;
+28 ;Handle subfields ;INSF>0 subfields present
+29 IF INSF
Begin DoDot:1
+30 ;do the header field, first
SET INSUPRES=1
DO FD1
+31 FOR
SET IN(0)=$ORDER(^INTHL7F(INFLD,10,"AS",IN(0)))
IF 'IN(0)
QUIT
Begin DoDot:2
+32 SET IN(10)=$GET(^INTHL7F(INFLD,10,+$ORDER(^INTHL7F(INFLD,10,"AS",IN(0),0)),0))
+33 SET INFLDC=+IN(10)
SET IN=IN+1
+34 IF 'INFLDC
QUIT
IF '$DATA(^INTHL7F(INFLDC,0))
QUIT
+35 SET INFLDC(0)=^INTHL7F(INFLDC,0)
SET INSVAR=$PIECE(INSEG(0),U,2)_INF_"."_IN
+36 SET INREQ=$$YN^INHMGD1($PIECE(IN(10),U,3))
+37 SET INUFL=$$YN^INHMGD1($PIECE(IN(10),U,4))
+38 SET INDENT=1
+39 DO FD1
End DoDot:2
End DoDot:1
QUIT
+40 ;
FD1 ;one field
+1 NEW INERR,INY
+2 ;
+3 ;get the field data
+4 SET (INY,INFLDC(0))=^INTHL7F(INFLDC,0)
+5 ;S INFLDC(4)=$G(^INTHL7F(INFLDC,4)) ;Input Xform
+6 ;S INFLDC(5)=$G(^INTHL7F(INFLDC,5)) ;Output Xform
+7 ;S INFLDC(50)=$G(^INTHL7F(INFLDC,50)) ;Map Function
+8 ;field name
SET INFD("FN")=$PIECE(INY,U)
+9 IF $PIECE(INY,U,2)=""
SET $PIECE(INY,U,2)=0
+10 ;data type abbrev
SET INFD("DT")=$PIECE($GET(^INTHL7FT($PIECE(INY,U,2),0)),U,2)
+11 ;field length
SET INFD("LEN")=$PIECE(INY,U,3)
+12 ;override input transforms 1=yes
SET INFD("OIT")=$PIECE(INY,U,5)
+13 ;
+14 ;process the field, o.k. to output column header if needed
+15 ;since we have data, now need to write col header
IF INHF2<0
DO HDR2^INHMGD1
+16 ;if we need a new page, write the col header
SET INHF2=1
+17 DO PROC(.INFLDC,.INP)
+18 ;if we need a new page, don't write the col header
SET INHF2=0
+19 QUIT
+20 ;
PROC(INFLDC,INP) ;Print the data source, utilizing the current Seg. File
+1 NEW DICOMPX,INDESC,INDDL,INDL,INS,X,INJ,INX,INOLDX
+2 ;
+3 ;Use documented data type, if one exists.
+4 IF $PIECE(INFLDC(0),U,12)]""
SET INFD("DT")=$PIECE(INFLDC(0),U,12)
+5 IF INFD("DT")=""
Begin DoDot:1
+6 SET ^UTILITY("INHMGD",$JOB,"E",INMSG,INSEG,INFLDC)=+FILE(FLVL)_U_"***NO DATA TYPE***"
End DoDot:1
+7 ;
+8 SET J(0)=FILE(FLVL)
SET INDL=""
+9 ;Use documented data source, if one exists.
+10 SET INDL=$$LBTB^UTIL($PIECE(INFLDC(0),U,11))
+11 IF INDL]""
SET INOLDX=INDL
SET INDL="##"_INDL
+12 ;else use data location
+13 IF INDL=""
SET (INDL,INOLDX)=$$LBTB^UTIL($GET(^INTHL7F(INFLDC,"C")))
+14 ;use DICOMP to get data location
+15 IF $LENGTH(INDL)
Begin DoDot:1
+16 SET INDL=$$RESOLVE(J(0),INDL)
+17 IF $LENGTH(INDL)
QUIT
+18 SET ^UTILITY("INHMGD",$JOB,"E",INMSG,INSEG,INFLDC)=+FILE(FLVL)_U_INOLDX_" Unable to resolve or missing from Data Dictionary."
End DoDot:1
+19 DO PRINT^INHMGD4(INDL,.INP)
+20 IF 0
DO MAPXFRM^INHMGD4(.INFLDC)
+21 QUIT
RESOLVE(INRT,INAD) ;Extrensic ***add DIC lookup
+1 ; Inputs:
+2 ; INRT = file#, or file name
+3 ; INAD = field string: e.g.: #.01:#.01:INTERNAL(#3.5)_";40.8"
+4 ; delimited by ":"
+5 ; Output:
+6 ; String containing Field#:File# (Field Name)
+7 ; with no leading spaces, and 1 space before the
+8 ; Field Name. e.g.: .01:8550 (NAME)
+9 ;
+10 NEW DIC,X,Y,I,INAME,INFLD,INFIL,INJ,INS,INPY
+11 SET (INFIL,INFLD)=""
+12 ;
+13 ;fixup address from documented data source
+14 IF $EXTRACT(INAD,1,2)="##"
SET INAD=$EXTRACT(INAD,3,999)
Begin DoDot:1
+15 SET INFIL=$PIECE(INAD,":",2)
IF INFIL]""
SET INRT=INFIL
+16 SET INAD=$PIECE(INAD,":")
End DoDot:1
+17 ;
+18 ;find file number from file name:
+19 ;make sure it's not like "8550^^CPG("
IF +INRT=0
IF $LENGTH(INRT)
Begin DoDot:1
+20 ;find file
KILL DIC
SET DIC="^DIC("
SET DIC(0)="FZ"
SET X=INRT
DO ^DIC
+21 IF Y>0
SET INRT=+Y
QUIT
+22 ;sub-file
SET DIC="^DD("
SET DIC(0)="FMZ"
SET DIC("S")="I $P(^(0),U,2)"
DO ^DIC
+23 IF Y>0
SET INRT=+Y
QUIT
End DoDot:1
+24 SET INRT=+INRT
+25 IF 'INRT
Begin DoDot:1
+26 SET ^UTILITY("INHMGD",$JOB,"E",INMSG,INSEG,INFLDC)=+FILE(FLVL)_U_"FILE# MISSING***"
End DoDot:1
QUIT INAD_":"_INRT_" (FILE# MISSING***)"
+27 ;
+28 ;exit on quoted string or @ (user defined routine)
+29 SET INS=INAD
+30 IF INAD["@"
QUIT INAD
+31 IF INAD'["INTERNAL"
SET X=$EXTRACT(INAD)
IF X=""""
QUIT INAD
+32 ;
+33 ;try a ^DD lookup
+34 SET X=$TRANSLATE(INAD,"#")
IF X'[":"
Begin DoDot:1
+35 KILL DIC
SET DIC="^DD("_INRT_","
SET DIC(0)="FMZ"
DO ^DIC
+36 IF Y>0
SET INFIL=+Y_":"_INRT_" ("_Y(0,0)_")"
End DoDot:1
IF $LENGTH(INFIL)
QUIT INFIL
+37 ;
+38 SET J(0)=+INRT
SET I(0)=""
SET DA="DA("
SET DQI="Y("
SET DICOMPX=""
SET X=INAD
+39 DO ^DICOMP
SET INPY=$GET(%Y)
+40 IF '$LENGTH($GET(X))
QUIT ""
+41 SET INAME=""
+42 ;if DICOMPX has the results, just reassemble for PRINT
+43 IF $LENGTH($GET(DICOMPX),U)>1
Begin DoDot:1
+44 ;rebuild the address for compatibility with PRINT
+45 SET INFIL=+DICOMPX
SET INFLD=+$PIECE(DICOMPX,U,2)
+46 SET INAD=INFLD_":"_INFIL
+47 ;
+48 ;have the address, now look for the field name
+49 IF $DATA(^DD(INFIL,INFLD,0))
SET INAME=$PIECE(^DD(INFIL,INFLD,0),U)
QUIT
+50 ;didn't find it, use what DICOMP returned
+51 ;looks like text, use it.
IF INPY'["^"
IF +INPY'=INPY
SET INAME=INPY
QUIT
+52 ;still didn't find it, try using what we started with.
+53 IF '$TRANSLATE(INS,"#")
SET INAME=INS
End DoDot:1
QUIT INAD_$SELECT($LENGTH(INAME):" ("_INAME_")",1:"")
+54 ;
+55 IF $LENGTH(X)
Begin DoDot:1
+56 SET INFIL=""
+57 IF INAD["NUMBER"!(INAD["#.001")
SET INFIL=".001:"_+FILE(FLVL)_" (NUMBER)"
+58 IF INAD["INSITE"
SET INFIL="8000:4 (INSITE)"
End DoDot:1
IF $LENGTH(INFIL)
QUIT INFIL
+59 QUIT ""
+60 ;
