INHSYS01 ;SLT,JPD; 1 Apr 99 10:05;GIS configuration compilation utility
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
;CHCS TOOLS_460; GEN 3; 17-JUL-1997
;COPYRIGHT 1992 SAIC
Q
XTRK(%XIEN,%ROOT,%UTL,%FILE,INREPRT,%LEVEL) ;global data extract and store
;input:
; %XIEN - ien of RECORD extracting data from
; %ROOT - global root in fileman format
; %UTL - temporary storage buffer
; %FILE - file 4000,4005,4006,4004,4011,4010,4012,4090.2,4012.1,4020
; INREPRT - 0-No report
; 1-Report
; %LEVEL - Indentation level of report
N ND,INY,GBL,INIEN,INCHLD,I,INBPC,INSGM,INSGS,INSGF,INSGSF
Q:'%XIEN
S ND=%ROOT_%XIEN_")",INREPRT=+$G(INREPRT)
;
;loop through file store in ^UTILITY and get pointer relationships
F S ND=$Q(@ND) Q:%XIEN'=+$P(ND,%ROOT,2) D Q:INPOP
.;get data and store in UTILITY global
.S INY=@ND,GBL=%UTL_$P(ND,%ROOT,2),@GBL=INY
.I $$ZRONOD(ND,%XIEN,%ROOT) D Q:INPOP
..;do report, store copy of node for later
..I INREPRT D RPRT1^INHSYSUT(%LEVEL,%FILE,ND) S ^UTILITY("SVD",$J,ND)=""
.;
.;Check Transaction type file for pointers
.I %FILE=4000,$$ZRONOD(ND,%XIEN,%ROOT) D TTYPE^INHSYS02(INY,%XIEN,INREPRT,%LEVEL)
.;
.;Interface destination file 4005
.I %FILE=4005,$$ZRONOD(ND,%XIEN,%ROOT) D DF(INY,%XIEN,INREPRT,%LEVEL)
.;
.;Background Processes file 4004
.I %FILE=4004,$$ZRONOD(ND,%XIEN,%ROOT),+$P(INY,U,7) D XTRK0(+$P(INY,U,7),4005,"^INRHD(",INREPRT,%LEVEL)
.;
.;Script Generator Message File 4011
.I %FILE=4011,$$ZRONOD(ND,%XIEN,%ROOT) D SEGS(%XIEN,INREPRT,%LEVEL)
.;
.;Script Generator Segment File 4010
.I %FILE=4010,$$ZRONOD(ND,%XIEN,%ROOT) D FLDS(%XIEN,INREPRT,%LEVEL)
.;
.;Script Generator Field Field File 4012
.I %FILE=4012,$$ZRONOD(ND,%XIEN,%ROOT) D MAP(%ROOT,%XIEN,INREPRT,%LEVEL)
.;
.;Interface Message Replication
.I %FILE=4020,$$ZRONOD(ND,%XIEN,%ROOT),+$P(INY,U,2) D XTRK0(+$P(INY,U,2),4000,"^INRHT(",INREPRT,%LEVEL)
.;don't take 4012.1 data type pointer
.;I %FILE=4090.2 don't do anything with data element map func file
.;I %FILE=4012.1 - script gen data type file points to nothing
.;I %FILE=4006 - Points to nothing
Q
;
MAP(%ROOT,%XIEN,INREPRT,%LEVEL) ;Map file
; Input:
; %ROOT - Global root in fileman format
; %XIEN - Map File ien
; %LEVEL - Pointer level
N INIEN
;map pointer to 4090.2 data element map function file
S INIEN=$G(@$E(%ROOT,1,$L(%ROOT)-1)@(%XIEN,50))
;extract 4090.2
I INIEN D XTRK0(INIEN,4090.2,"^INVD(",INREPRT,%LEVEL)
Q
XTRK0(%INP,%FL,%ND,INREPRT,%LEVEL) ;
; %INP - Pointer to file from piece
; %FL - DD file number
; %ND - Root
; INREPRT - 0 no report 1 - report
; %LEVEL - Pointer level
;
I '$D(^UTILITY($J,%FL,%INP)) D XTRK(%INP,%ND,"^UTILITY($J,"""_%FL_""",",%FL,INREPRT,%LEVEL+1)
Q
DF(INY,%XIEN,INREPRT,%LEVEL) ;Destination file
;Input:
; INY-Data from node
; %XIEN - ien of 4005
; INREPRT - 0 no report
; 1 report
; %LEVEL - Pointer level
N %IP2,%IP10
; -- Transaction Type and Acceptance TT
S %IP2=+$P(INY,U,2),%IP10=+$P(INY,U,10)
; - TT pointer to file 4000 exists
I %IP2 D XTRK0(%IP2,4000,"^INRHT(",INREPRT,%LEVEL) Q:INPOP
; - Acceptance TT pointer to file 4000 exists
I %IP10 D XTRK0(%IP10,4000,"^INRHT(",INREPRT,%LEVEL) Q:INPOP
; - Primary Destination pointers to 4005, backwards and forwards
D DP(%XIEN,INREPRT,%LEVEL) Q:INPOP
;Look for background process which points to this 4005
D BP(%XIEN,INREPRT,%LEVEL) Q:INPOP
Q
DP(%XIEN,INREPRT,%LEVEL) ;Primary Destination Pointers 4005
; Input:
; %XIEN - Ien of current entry
; INREPRT - 0 no report
; 1 report
; %LEVEL - Pointer level
N INIEN
; If a sub-destination, Get primary
S INIEN=$G(^INRHD(%XIEN,7)),INIEN=$P(INIEN,U,2)
I INIEN D XTRK0(INIEN,4005,"^INRHD(",INREPRT,%LEVEL)
; Get sub-destinations
S INIEN=""
F S INIEN=$O(^INRHD("APD",%XIEN,INIEN)) Q:'INIEN D XTRK0(INIEN,4005,"^INRHD(",INREPRT,%LEVEL) Q:INPOP
Q
BP(%XIEN,INREPRT,%LEVEL) ;Background processes 4004
; Input:
; %XIEN - Ien of destination file
; INREPRT - 0 no report
; 1 report
; %LEVEL - Pointer level
N INBPC,%LEN,INIEN,I
S INBPC=$$BPC(%XIEN),%LEN=$L(INBPC,U)
F I=1:1:%LEN D Q:INPOP
.S INIEN=$P(INBPC,U,I) Q:'INIEN
.;Background Process Control entry
.D XTRK0(INIEN,4004,"^INTHPC(",INREPRT,%LEVEL)
Q
BPC(X) ;find all background processes which point to this destination 4004 cont
;input:
; X - destination ien
;return:
; INY - '^' delimited string of background process iens
;
N INY,%A
S %A=0,INY=""
F S %A=$O(^INTHPC(%A)) Q:'%A D
.I $P($G(^INTHPC(%A,0)),U,7)=X S INY=INY_$S(INY]"":U,1:"")_%A
Q INY
SEGS(%XIEN,INREPRT,%LEVEL) ;Script segs 4011
; Input:
; %XIEN - Scripts file Ien
; INREPRT - 0 no report
; 1 report
; %LEVEL - Pointer level
N INSGS,%LEN,I,INIEN
S INSGS=$$SGS(%XIEN),%LEN=$L(INSGS,U)
F I=1:1:%LEN D Q:INPOP
.S INIEN=$P(INSGS,U,I)
.;4010's script generator segment file entries
.I INIEN D XTRK0(INIEN,4010,"^INTHL7S(",INREPRT,%LEVEL)
Q
SGS(%XIEN) ;return '^' delimited string of segment iens
;input:
; %XIEN - Script Generator Message ien
;return:
; INY - '^' delimited string of segment iens
;
N INSEG,INPSEG,DA,INY
;figure out which 4010's to save
S (INY,INSEG)="" F S INSEG=$O(^INTHL7M(%XIEN,1,"B",INSEG)) Q:'INSEG D
.S INY=INY_$S(INY]"":U,1:"")_INSEG
.S DA=$O(^INTHL7M(%XIEN,1,"B",INSEG,"")),INPSEG=$S(DA'="":$P($G(^INTHL7M(%XIEN,1,DA,0)),U,11),1:"")
.S INY=INY_$S(INY]""&(INPSEG]""):U,1:"")_INPSEG
Q INY
;
FLDS(%XIEN,INREPRT,%LEVEL) ;Fields file - 4012
; Input:
; %XIEN - Fields File Ien
; INREPRT - 0 no report
; 1 report
; %LEVEL - Pointer level
N INSGF,INSGSF,I,INIEN,J
;field multiple of 4010 script gen seg file
S INSGF=$$SGF(%XIEN,.INSGF) F I=1:1:INSGF D Q:INPOP
.S INIEN=INSGF(I) Q:'INIEN
.;script generator field exists
.Q:$D(^UTILITY($J,4012,INIEN))
.;get sub field multiple entry of 4012 script gen field file
.K INSGSF S INSGSF=$$SGSF(INIEN,.INSGSF) F J=1:1:INSGSF D Q:INPOP
..N INIEN S INIEN=INSGSF(J)
..I INIEN D XTRK0(INIEN,4012,"^INTHL7F(",INREPRT,%LEVEL)
Q
SGF(X,INSGF) ;return the number of field iens found
;input:
; X - Segment ien
; INSGF - Array of field iens built, passed by referrence
;
N INFLD,INY
S (INFLD,INY)=""
F S INFLD=$O(^INTHL7S(X,1,"B",INFLD)) Q:'INFLD S INY=INY+1,INSGF(INY)=INFLD
Q +INY
;
SGSF(X,INSGSF) ;return the number of sub-field iens
;input:
; X - field ien
; INSGSF - Array of subfield iens built, passed by referrence
;
N INFLD,INY
S INFLD="",INY=1,INSGSF(1)=X
F S INFLD=$O(^INTHL7F(X,10,"B",INFLD)) Q:'INFLD S INY=INY+1,INSGSF(INY)=INFLD
Q +INY
ZRONOD(N,X,R) ;is node the first level zero node?
;input:
; N - node
; X - ien
; R - global root
;Returns 1 if node is 0 node, 0 if not
N %ZND S %ZND=R_X_",0)"
Q N=%ZND
INHSYS01 ;SLT,JPD; 1 Apr 99 10:05;GIS configuration compilation utility
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 ;CHCS TOOLS_460; GEN 3; 17-JUL-1997
+4 ;COPYRIGHT 1992 SAIC
+5 QUIT
XTRK(%XIEN,%ROOT,%UTL,%FILE,INREPRT,%LEVEL) ;global data extract and store
+1 ;input:
+2 ; %XIEN - ien of RECORD extracting data from
+3 ; %ROOT - global root in fileman format
+4 ; %UTL - temporary storage buffer
+5 ; %FILE - file 4000,4005,4006,4004,4011,4010,4012,4090.2,4012.1,4020
+6 ; INREPRT - 0-No report
+7 ; 1-Report
+8 ; %LEVEL - Indentation level of report
+9 NEW ND,INY,GBL,INIEN,INCHLD,I,INBPC,INSGM,INSGS,INSGF,INSGSF
+10 IF '%XIEN
QUIT
+11 SET ND=%ROOT_%XIEN_")"
SET INREPRT=+$GET(INREPRT)
+12 ;
+13 ;loop through file store in ^UTILITY and get pointer relationships
+14 FOR
SET ND=$QUERY(@ND)
IF %XIEN'=+$PIECE(ND,%ROOT,2)
QUIT
Begin DoDot:1
+15 ;get data and store in UTILITY global
+16 SET INY=@ND
SET GBL=%UTL_$PIECE(ND,%ROOT,2)
SET @GBL=INY
+17 IF $$ZRONOD(ND,%XIEN,%ROOT)
Begin DoDot:2
+18 ;do report, store copy of node for later
+19 IF INREPRT
DO RPRT1^INHSYSUT(%LEVEL,%FILE,ND)
SET ^UTILITY("SVD",$JOB,ND)=""
End DoDot:2
IF INPOP
QUIT
+20 ;
+21 ;Check Transaction type file for pointers
+22 IF %FILE=4000
IF $$ZRONOD(ND,%XIEN,%ROOT)
DO TTYPE^INHSYS02(INY,%XIEN,INREPRT,%LEVEL)
+23 ;
+24 ;Interface destination file 4005
+25 IF %FILE=4005
IF $$ZRONOD(ND,%XIEN,%ROOT)
DO DF(INY,%XIEN,INREPRT,%LEVEL)
+26 ;
+27 ;Background Processes file 4004
+28 IF %FILE=4004
IF $$ZRONOD(ND,%XIEN,%ROOT)
IF +$PIECE(INY,U,7)
DO XTRK0(+$PIECE(INY,U,7),4005,"^INRHD(",INREPRT,%LEVEL)
+29 ;
+30 ;Script Generator Message File 4011
+31 IF %FILE=4011
IF $$ZRONOD(ND,%XIEN,%ROOT)
DO SEGS(%XIEN,INREPRT,%LEVEL)
+32 ;
+33 ;Script Generator Segment File 4010
+34 IF %FILE=4010
IF $$ZRONOD(ND,%XIEN,%ROOT)
DO FLDS(%XIEN,INREPRT,%LEVEL)
+35 ;
+36 ;Script Generator Field Field File 4012
+37 IF %FILE=4012
IF $$ZRONOD(ND,%XIEN,%ROOT)
DO MAP(%ROOT,%XIEN,INREPRT,%LEVEL)
+38 ;
+39 ;Interface Message Replication
+40 IF %FILE=4020
IF $$ZRONOD(ND,%XIEN,%ROOT)
IF +$PIECE(INY,U,2)
DO XTRK0(+$PIECE(INY,U,2),4000,"^INRHT(",INREPRT,%LEVEL)
+41 ;don't take 4012.1 data type pointer
+42 ;I %FILE=4090.2 don't do anything with data element map func file
+43 ;I %FILE=4012.1 - script gen data type file points to nothing
+44 ;I %FILE=4006 - Points to nothing
End DoDot:1
IF INPOP
QUIT
+45 QUIT
+46 ;
MAP(%ROOT,%XIEN,INREPRT,%LEVEL) ;Map file
+1 ; Input:
+2 ; %ROOT - Global root in fileman format
+3 ; %XIEN - Map File ien
+4 ; %LEVEL - Pointer level
+5 NEW INIEN
+6 ;map pointer to 4090.2 data element map function file
+7 SET INIEN=$GET(@$EXTRACT(%ROOT,1,$LENGTH(%ROOT)-1)@(%XIEN,50))
+8 ;extract 4090.2
+9 IF INIEN
DO XTRK0(INIEN,4090.2,"^INVD(",INREPRT,%LEVEL)
+10 QUIT
XTRK0(%INP,%FL,%ND,INREPRT,%LEVEL) ;
+1 ; %INP - Pointer to file from piece
+2 ; %FL - DD file number
+3 ; %ND - Root
+4 ; INREPRT - 0 no report 1 - report
+5 ; %LEVEL - Pointer level
+6 ;
+7 IF '$DATA(^UTILITY($JOB,%FL,%INP))
DO XTRK(%INP,%ND,"^UTILITY($J,"""_%FL_""",",%FL,INREPRT,%LEVEL+1)
+8 QUIT
DF(INY,%XIEN,INREPRT,%LEVEL) ;Destination file
+1 ;Input:
+2 ; INY-Data from node
+3 ; %XIEN - ien of 4005
+4 ; INREPRT - 0 no report
+5 ; 1 report
+6 ; %LEVEL - Pointer level
+7 NEW %IP2,%IP10
+8 ; -- Transaction Type and Acceptance TT
+9 SET %IP2=+$PIECE(INY,U,2)
SET %IP10=+$PIECE(INY,U,10)
+10 ; - TT pointer to file 4000 exists
+11 IF %IP2
DO XTRK0(%IP2,4000,"^INRHT(",INREPRT,%LEVEL)
IF INPOP
QUIT
+12 ; - Acceptance TT pointer to file 4000 exists
+13 IF %IP10
DO XTRK0(%IP10,4000,"^INRHT(",INREPRT,%LEVEL)
IF INPOP
QUIT
+14 ; - Primary Destination pointers to 4005, backwards and forwards
+15 DO DP(%XIEN,INREPRT,%LEVEL)
IF INPOP
QUIT
+16 ;Look for background process which points to this 4005
+17 DO BP(%XIEN,INREPRT,%LEVEL)
IF INPOP
QUIT
+18 QUIT
DP(%XIEN,INREPRT,%LEVEL) ;Primary Destination Pointers 4005
+1 ; Input:
+2 ; %XIEN - Ien of current entry
+3 ; INREPRT - 0 no report
+4 ; 1 report
+5 ; %LEVEL - Pointer level
+6 NEW INIEN
+7 ; If a sub-destination, Get primary
+8 SET INIEN=$GET(^INRHD(%XIEN,7))
SET INIEN=$PIECE(INIEN,U,2)
+9 IF INIEN
DO XTRK0(INIEN,4005,"^INRHD(",INREPRT,%LEVEL)
+10 ; Get sub-destinations
+11 SET INIEN=""
+12 FOR
SET INIEN=$ORDER(^INRHD("APD",%XIEN,INIEN))
IF 'INIEN
QUIT
DO XTRK0(INIEN,4005,"^INRHD(",INREPRT,%LEVEL)
IF INPOP
QUIT
+13 QUIT
BP(%XIEN,INREPRT,%LEVEL) ;Background processes 4004
+1 ; Input:
+2 ; %XIEN - Ien of destination file
+3 ; INREPRT - 0 no report
+4 ; 1 report
+5 ; %LEVEL - Pointer level
+6 NEW INBPC,%LEN,INIEN,I
+7 SET INBPC=$$BPC(%XIEN)
SET %LEN=$LENGTH(INBPC,U)
+8 FOR I=1:1:%LEN
Begin DoDot:1
+9 SET INIEN=$PIECE(INBPC,U,I)
IF 'INIEN
QUIT
+10 ;Background Process Control entry
+11 DO XTRK0(INIEN,4004,"^INTHPC(",INREPRT,%LEVEL)
End DoDot:1
IF INPOP
QUIT
+12 QUIT
BPC(X) ;find all background processes which point to this destination 4004 cont
+1 ;input:
+2 ; X - destination ien
+3 ;return:
+4 ; INY - '^' delimited string of background process iens
+5 ;
+6 NEW INY,%A
+7 SET %A=0
SET INY=""
+8 FOR
SET %A=$ORDER(^INTHPC(%A))
IF '%A
QUIT
Begin DoDot:1
+9 IF $PIECE($GET(^INTHPC(%A,0)),U,7)=X
SET INY=INY_$SELECT(INY]"":U,1:"")_%A
End DoDot:1
+10 QUIT INY
SEGS(%XIEN,INREPRT,%LEVEL) ;Script segs 4011
+1 ; Input:
+2 ; %XIEN - Scripts file Ien
+3 ; INREPRT - 0 no report
+4 ; 1 report
+5 ; %LEVEL - Pointer level
+6 NEW INSGS,%LEN,I,INIEN
+7 SET INSGS=$$SGS(%XIEN)
SET %LEN=$LENGTH(INSGS,U)
+8 FOR I=1:1:%LEN
Begin DoDot:1
+9 SET INIEN=$PIECE(INSGS,U,I)
+10 ;4010's script generator segment file entries
+11 IF INIEN
DO XTRK0(INIEN,4010,"^INTHL7S(",INREPRT,%LEVEL)
End DoDot:1
IF INPOP
QUIT
+12 QUIT
SGS(%XIEN) ;return '^' delimited string of segment iens
+1 ;input:
+2 ; %XIEN - Script Generator Message ien
+3 ;return:
+4 ; INY - '^' delimited string of segment iens
+5 ;
+6 NEW INSEG,INPSEG,DA,INY
+7 ;figure out which 4010's to save
+8 SET (INY,INSEG)=""
FOR
SET INSEG=$ORDER(^INTHL7M(%XIEN,1,"B",INSEG))
IF 'INSEG
QUIT
Begin DoDot:1
+9 SET INY=INY_$SELECT(INY]"":U,1:"")_INSEG
+10 SET DA=$ORDER(^INTHL7M(%XIEN,1,"B",INSEG,""))
SET INPSEG=$SELECT(DA'="":$PIECE($GET(^INTHL7M(%XIEN,1,DA,0)),U,11),1:"")
+11 SET INY=INY_$SELECT(INY]""&(INPSEG]""):U,1:"")_INPSEG
End DoDot:1
+12 QUIT INY
+13 ;
FLDS(%XIEN,INREPRT,%LEVEL) ;Fields file - 4012
+1 ; Input:
+2 ; %XIEN - Fields File Ien
+3 ; INREPRT - 0 no report
+4 ; 1 report
+5 ; %LEVEL - Pointer level
+6 NEW INSGF,INSGSF,I,INIEN,J
+7 ;field multiple of 4010 script gen seg file
+8 SET INSGF=$$SGF(%XIEN,.INSGF)
FOR I=1:1:INSGF
Begin DoDot:1
+9 SET INIEN=INSGF(I)
IF 'INIEN
QUIT
+10 ;script generator field exists
+11 IF $DATA(^UTILITY($JOB,4012,INIEN))
QUIT
+12 ;get sub field multiple entry of 4012 script gen field file
+13 KILL INSGSF
SET INSGSF=$$SGSF(INIEN,.INSGSF)
FOR J=1:1:INSGSF
Begin DoDot:2
+14 NEW INIEN
SET INIEN=INSGSF(J)
+15 IF INIEN
DO XTRK0(INIEN,4012,"^INTHL7F(",INREPRT,%LEVEL)
End DoDot:2
IF INPOP
QUIT
End DoDot:1
IF INPOP
QUIT
+16 QUIT
SGF(X,INSGF) ;return the number of field iens found
+1 ;input:
+2 ; X - Segment ien
+3 ; INSGF - Array of field iens built, passed by referrence
+4 ;
+5 NEW INFLD,INY
+6 SET (INFLD,INY)=""
+7 FOR
SET INFLD=$ORDER(^INTHL7S(X,1,"B",INFLD))
IF 'INFLD
QUIT
SET INY=INY+1
SET INSGF(INY)=INFLD
+8 QUIT +INY
+9 ;
SGSF(X,INSGSF) ;return the number of sub-field iens
+1 ;input:
+2 ; X - field ien
+3 ; INSGSF - Array of subfield iens built, passed by referrence
+4 ;
+5 NEW INFLD,INY
+6 SET INFLD=""
SET INY=1
SET INSGSF(1)=X
+7 FOR
SET INFLD=$ORDER(^INTHL7F(X,10,"B",INFLD))
IF 'INFLD
QUIT
SET INY=INY+1
SET INSGSF(INY)=INFLD
+8 QUIT +INY
ZRONOD(N,X,R) ;is node the first level zero node?
+1 ;input:
+2 ; N - node
+3 ; X - ien
+4 ; R - global root
+5 ;Returns 1 if node is 0 node, 0 if not
+6 NEW %ZND
SET %ZND=R_X_",0)"
+7 QUIT N=%ZND
