INHMGD11 ;CAR; 10 April 97 11:03;HL7 MESSAGING - PRINT PAGE1(&2)
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
;
; MODULE NAME:
; HL7 Messaging - Display Header Page (Page: 1 and 2)
;
; Inputs:
; INDA = D0 in ^INTHL7M(D0,
; INMSG0 = is ^INTHL7M(D0,0)
; INHDR = the Header text (ARRAY, call by reference)
;
; Outputs: NONE
PAGE1(INMSG,INMSG0,INHDR) ;callable routine to print Page 1 & 2.
;Provides a brief synopsis of the data contained in ^INTHL7M for
;this message.
; Inputs:
; INMSG = the main index (ien) for this message, into ^INTHL7M(INMSG
; INMSG0 = the ^INTHL7M(INDA,0) array. I assume you already have it
; in local memory.
; INHDR = the page header array, from HSET^YourRtn.
;
N INDEX,INJ,INK,INL,INMSGT,INX,INY
;
S ING=$G(ING,0)
I IOM=132 S ING=IOM-12 N IOM S IOM=ING,ING=8
;setup for field column (see INHMGD4 for remainder of columns)
S INS2=$S(IOM>90:58,1:47)+ING ;start of column2
;
;Write 3 line header, and "***** Message **..."
D HEADER^INHMGD1
S DATA="""***** Message ""_$$DASH^INHMGD1(80-16,""*"")"
D WRITE^INHMGD1
;
S X=INMSG0
;Write Message Name and Inactive: YES or NO
S DATA="$E($P(X,U),1,45),?(80-15+ING),""Inactive: ""_$$YN^INHMGD1($P(X,U,8),1)"
D WRITE^INHMGD1
;
;Add message notes from ^INTHL7M(INMSG,3,INDEX,0) word processing field.
D WRAPWP("^INTHL7M("_INMSG_",3,",.INMSGT,73)
F INJ=1:1:INMSGT S Y=INMSGT(INJ),DATA=""" ""_Y" D WRITE^INHMGD1
;
;Event Type and Message Type:
S DATA="!,?ING+3,""Event Type:"",?ING+15,$E($P(X,U,2),1,20),?ING+41,"
S DATA=DATA_"""Message Type:"",?ING+56,$E($P(X,U,6),1,3)" D WRITE^INHMGD1
;
;Sending Application and Receiving Application:
S X=$G(^INTHL7M(INMSG,7))
S DATA="?ING+1,""Send Applic.:"",?ING+15,$E($P(X,U),1,25)"
S DATA=DATA_",?ING+41,""Rec. Applic.:"",?ING+55,$E($P(X,U,3),1,25)"
D WRITE^INHMGD1
;
;Sending Facility and Receiving Facility:
S DATA="?ING+5,""Facility:"",?ING+15,$E($P(X,U,2),1,25),?ING+45,"
S DATA=DATA_"""Facility:"",?ING+55,$E($P(X,U,4),1,25)" D WRITE^INHMGD1
;
;Processing ID, HL7 Version and Lookup Parameter:
S X=INMSG0,Y=$P(X,U,3)
S INX=$S(Y="P":"PRODUCTION",Y="D":"DEBUG",Y="T":"TRAINING",1:Y)
S INY=$$LKPRM^INHMGD1($P(X,U,7))
S DATA="""Processing ID:"",?ING+15,INX"
S DATA=DATA_",?ING+28,""HL7 Version:"",?ING+41,$E($P(X,U,4),1,5)"
S DATA=DATA_",?ING+48,""Lookup Parameter:"",?ING+66,INY"
D WRITE^INHMGD1
;
;Accept Ack. and Application Ack:
S Y=$P(X,U,10) ;Accept Ack.
S INX=$S(Y="AL":"ALWAYS",Y="ER":"ERROR/REJECT",Y="NE":"NEVER",Y="SU":"SUCCESS ONLY",1:Y)
S Y=$P(X,U,11) ;Application Ack:
S INY=$S(Y="AL":"ALWAYS",Y="ER":"ERROR/REJECT",Y="NE":"NEVER",Y="SU":"SUCCESS ONLY",1:Y)
S DATA="?ING+3,""Accept Ack:"",?ING+15,INX,?ING+49,""Application Ack:"",?ING+66,INY"
D WRITE^INHMGD1
;
;Root File and Audited?
S Y=$P(X,U,5)
S INX=$E($S(Y="":Y,$D(^DIC(Y,0))#2:$P(^DIC(Y,0),U),1:" "_Y),1,40)
S INY=$$YN^INHMGD1($P(X,U,9),1)
S DATA="?ING+4,""Root File:"",?ING+15,INX,?ING+57,""Audited:"",?ING+66,INY"
D WRITE^INHMGD1
;
;Routine for Lookup/Store:"
S INY=$G(^INTHL7M(INDA,5)),INX=1,INX(1)=""
D WRAPS(INY,.INX,IOM-29)
S DATA="""Routine for Lookup/Store:"",?ING+26,INX(1)" D WRITE^INHMGD1
I INX>1 F INJ=2:1:INX S DATA="?ING+26,INX(INJ)" D WRITE^INHMGD1
K INX
;
;Sort Transaction Types by Name:
S DATA="""Transaction Types:""" D WRITE^INHMGD1
S INJ=0 F S INJ=$O(^INTHL7M(INDA,2,INJ)) Q:'INJ D
.;get the pointer to ^INRHT from each node descendendent from 2
.S INK=+$P($G(^INTHL7M(INDA,2,INJ,0)),U) Q:'INK
.S INL=$P($G(^INRHT(INK,0)),U) Q:INL=""
.;save the 1st piece (Transaction Type) in ^INRHT
.S INX(INL)=""
S INJ=0 F S INJ=$O(INX(INJ)) D Q:INJ=""
.S DATA="?ING+4,INJ" D WRITE^INHMGD1
;
;Let's not try to put it all on the first page:
I IOSL-$Y<10 D HEADER^INHMGD1
;
;MUMPS Code for Lookup:
D WRAPWP("^INTHL7M("_INDA_",4,",.INX,IOM-24-3)
S DATA="""MUMPS Code for Lookup:"",?ING+24,INX(1)" D WRITE^INHMGD1
I $D(INX(2)) D
.S INJ=1 F S INJ=$O(INX(INJ)) Q:'INJ D
..S DATA="?ING+24,INX(INJ)" D WRITE^INHMGD1
K INX
;
;Outgoing Initial MUMPS Code:"
D WRAPWP("^INTHL7M("_INDA_",6,",.INX,IOM-30-3)
S DATA="""Outgoing Initial MUMPS Code:"",?ING+30,INX(1)" D WRITE^INHMGD1
I $D(INX(2)) D
.S INJ=1 F S INJ=$O(INX(INJ)) Q:'INJ D
..S DATA="?ING+30,INX(INJ)" D WRITE^INHMGD1
K INX
;
;Generated Scripts -"
S DATA="""Generated Scripts -""" D WRITE^INHMGD1
S INJ=$G(^INTHL7M(INDA,"S"))
S INK=$P(INJ,U),INL=$P(INJ,U,2),(INX,INY)=""
I INK S INX=$E($P($G(^INRHS(INK,0)),U),1,60) ;input
I INL S INY=$E($P($G(^INRHS(INL,0)),U),1,60) ;output
S DATA="?ING+3,""Input: "",INX" D WRITE^INHMGD1
S DATA="?ING+2,""Output: "",INY" D WRITE^INHMGD1
;
Q
WRAPWP(INGN,INO,INW) ;WP wrapping routine, doesn't force wrap if text
; will fit on current line.
; Inputs:
; INGN = global name and nodes e.g. "^INTHL7M(12181,3,"
; INO = name of the output array (call by Reference)
; INW = width of the output field
; Outputs:
; INO = output array
;
N INA,INDEX
S INO=1,INO(1)="",INW=$G(INW,35)
S INDEX=0 F S INDEX=$O(@(INGN_INDEX_")")) Q:'INDEX D
.S INA=$G(@(INGN_INDEX_",0)")),INO(INO)=$G(INO(INO))
.;add a space if continuing on from a previous line
.S INA=$S($E(INA)=" "!(INO(INO)=""):INA,1:" "_INA)
.I $L(INO(INO)_INA)'>INW S INO(INO)=INO(INO)_INA,INO=INO+1 Q
.D WRAPS(INA,.INO,INW)
I '$D(INO(INO)) S INO=INO-1
Q
WRAPS(INA,INO,INW) ;Array Wrapping routine - Completes WRAP.
; Inputs:
; INA = input, a long string.
; INO = output array (call by reference)
; INW = desired width of output array
; Output:
; INO = output array
;
N INS
S INO=$G(INO,1),INO(INO)=$G(INO(INO))_INA
F Q:$L(INO(INO))'>INW D
.;find a space to break the line
.F INS=INW:-1:1 Q:$E(INO(INO),INS)=" "
.S:INS'>1 INS=INW ;if space not found
.S INO(INO+1)=$E(INO(INO),INS+1,999) ;keep remainder of line
.S INO(INO)=$E(INO(INO),1,INS),INO=INO+1 ;copy 1st part to output array
Q
INHMGD11 ;CAR; 10 April 97 11:03;HL7 MESSAGING - PRINT PAGE1(&2)
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 ;
+4 ; MODULE NAME:
+5 ; HL7 Messaging - Display Header Page (Page: 1 and 2)
+6 ;
+7 ; Inputs:
+8 ; INDA = D0 in ^INTHL7M(D0,
+9 ; INMSG0 = is ^INTHL7M(D0,0)
+10 ; INHDR = the Header text (ARRAY, call by reference)
+11 ;
+12 ; Outputs: NONE
PAGE1(INMSG,INMSG0,INHDR) ;callable routine to print Page 1 & 2.
+1 ;Provides a brief synopsis of the data contained in ^INTHL7M for
+2 ;this message.
+3 ; Inputs:
+4 ; INMSG = the main index (ien) for this message, into ^INTHL7M(INMSG
+5 ; INMSG0 = the ^INTHL7M(INDA,0) array. I assume you already have it
+6 ; in local memory.
+7 ; INHDR = the page header array, from HSET^YourRtn.
+8 ;
+9 NEW INDEX,INJ,INK,INL,INMSGT,INX,INY
+10 ;
+11 SET ING=$GET(ING,0)
+12 IF IOM=132
SET ING=IOM-12
NEW IOM
SET IOM=ING
SET ING=8
+13 ;setup for field column (see INHMGD4 for remainder of columns)
+14 ;start of column2
SET INS2=$SELECT(IOM>90:58,1:47)+ING
+15 ;
+16 ;Write 3 line header, and "***** Message **..."
+17 DO HEADER^INHMGD1
+18 SET DATA="""***** Message ""_$$DASH^INHMGD1(80-16,""*"")"
+19 DO WRITE^INHMGD1
+20 ;
+21 SET X=INMSG0
+22 ;Write Message Name and Inactive: YES or NO
+23 SET DATA="$E($P(X,U),1,45),?(80-15+ING),""Inactive: ""_$$YN^INHMGD1($P(X,U,8),1)"
+24 DO WRITE^INHMGD1
+25 ;
+26 ;Add message notes from ^INTHL7M(INMSG,3,INDEX,0) word processing field.
+27 DO WRAPWP("^INTHL7M("_INMSG_",3,",.INMSGT,73)
+28 FOR INJ=1:1:INMSGT
SET Y=INMSGT(INJ)
SET DATA=""" ""_Y"
DO WRITE^INHMGD1
+29 ;
+30 ;Event Type and Message Type:
+31 SET DATA="!,?ING+3,""Event Type:"",?ING+15,$E($P(X,U,2),1,20),?ING+41,"
+32 SET DATA=DATA_"""Message Type:"",?ING+56,$E($P(X,U,6),1,3)"
DO WRITE^INHMGD1
+33 ;
+34 ;Sending Application and Receiving Application:
+35 SET X=$GET(^INTHL7M(INMSG,7))
+36 SET DATA="?ING+1,""Send Applic.:"",?ING+15,$E($P(X,U),1,25)"
+37 SET DATA=DATA_",?ING+41,""Rec. Applic.:"",?ING+55,$E($P(X,U,3),1,25)"
+38 DO WRITE^INHMGD1
+39 ;
+40 ;Sending Facility and Receiving Facility:
+41 SET DATA="?ING+5,""Facility:"",?ING+15,$E($P(X,U,2),1,25),?ING+45,"
+42 SET DATA=DATA_"""Facility:"",?ING+55,$E($P(X,U,4),1,25)"
DO WRITE^INHMGD1
+43 ;
+44 ;Processing ID, HL7 Version and Lookup Parameter:
+45 SET X=INMSG0
SET Y=$PIECE(X,U,3)
+46 SET INX=$SELECT(Y="P":"PRODUCTION",Y="D":"DEBUG",Y="T":"TRAINING",1:Y)
+47 SET INY=$$LKPRM^INHMGD1($PIECE(X,U,7))
+48 SET DATA="""Processing ID:"",?ING+15,INX"
+49 SET DATA=DATA_",?ING+28,""HL7 Version:"",?ING+41,$E($P(X,U,4),1,5)"
+50 SET DATA=DATA_",?ING+48,""Lookup Parameter:"",?ING+66,INY"
+51 DO WRITE^INHMGD1
+52 ;
+53 ;Accept Ack. and Application Ack:
+54 ;Accept Ack.
SET Y=$PIECE(X,U,10)
+55 SET INX=$SELECT(Y="AL":"ALWAYS",Y="ER":"ERROR/REJECT",Y="NE":"NEVER",Y="SU":"SUCCESS ONLY",1:Y)
+56 ;Application Ack:
SET Y=$PIECE(X,U,11)
+57 SET INY=$SELECT(Y="AL":"ALWAYS",Y="ER":"ERROR/REJECT",Y="NE":"NEVER",Y="SU":"SUCCESS ONLY",1:Y)
+58 SET DATA="?ING+3,""Accept Ack:"",?ING+15,INX,?ING+49,""Application Ack:"",?ING+66,INY"
+59 DO WRITE^INHMGD1
+60 ;
+61 ;Root File and Audited?
+62 SET Y=$PIECE(X,U,5)
+63 SET INX=$EXTRACT($SELECT(Y="":Y,$DATA(^DIC(Y,0))#2:$PIECE(^DIC(Y,0),U),1:" "_Y),1,40)
+64 SET INY=$$YN^INHMGD1($PIECE(X,U,9),1)
+65 SET DATA="?ING+4,""Root File:"",?ING+15,INX,?ING+57,""Audited:"",?ING+66,INY"
+66 DO WRITE^INHMGD1
+67 ;
+68 ;Routine for Lookup/Store:"
+69 SET INY=$GET(^INTHL7M(INDA,5))
SET INX=1
SET INX(1)=""
+70 DO WRAPS(INY,.INX,IOM-29)
+71 SET DATA="""Routine for Lookup/Store:"",?ING+26,INX(1)"
DO WRITE^INHMGD1
+72 IF INX>1
FOR INJ=2:1:INX
SET DATA="?ING+26,INX(INJ)"
DO WRITE^INHMGD1
+73 KILL INX
+74 ;
+75 ;Sort Transaction Types by Name:
+76 SET DATA="""Transaction Types:"""
DO WRITE^INHMGD1
+77 SET INJ=0
FOR
SET INJ=$ORDER(^INTHL7M(INDA,2,INJ))
IF 'INJ
QUIT
Begin DoDot:1
+78 ;get the pointer to ^INRHT from each node descendendent from 2
+79 SET INK=+$PIECE($GET(^INTHL7M(INDA,2,INJ,0)),U)
IF 'INK
QUIT
+80 SET INL=$PIECE($GET(^INRHT(INK,0)),U)
IF INL=""
QUIT
+81 ;save the 1st piece (Transaction Type) in ^INRHT
+82 SET INX(INL)=""
End DoDot:1
+83 SET INJ=0
FOR
SET INJ=$ORDER(INX(INJ))
Begin DoDot:1
+84 SET DATA="?ING+4,INJ"
DO WRITE^INHMGD1
End DoDot:1
IF INJ=""
QUIT
+85 ;
+86 ;Let's not try to put it all on the first page:
+87 IF IOSL-$Y<10
DO HEADER^INHMGD1
+88 ;
+89 ;MUMPS Code for Lookup:
+90 DO WRAPWP("^INTHL7M("_INDA_",4,",.INX,IOM-24-3)
+91 SET DATA="""MUMPS Code for Lookup:"",?ING+24,INX(1)"
DO WRITE^INHMGD1
+92 IF $DATA(INX(2))
Begin DoDot:1
+93 SET INJ=1
FOR
SET INJ=$ORDER(INX(INJ))
IF 'INJ
QUIT
Begin DoDot:2
+94 SET DATA="?ING+24,INX(INJ)"
DO WRITE^INHMGD1
End DoDot:2
End DoDot:1
+95 KILL INX
+96 ;
+97 ;Outgoing Initial MUMPS Code:"
+98 DO WRAPWP("^INTHL7M("_INDA_",6,",.INX,IOM-30-3)
+99 SET DATA="""Outgoing Initial MUMPS Code:"",?ING+30,INX(1)"
DO WRITE^INHMGD1
+100 IF $DATA(INX(2))
Begin DoDot:1
+101 SET INJ=1
FOR
SET INJ=$ORDER(INX(INJ))
IF 'INJ
QUIT
Begin DoDot:2
+102 SET DATA="?ING+30,INX(INJ)"
DO WRITE^INHMGD1
End DoDot:2
End DoDot:1
+103 KILL INX
+104 ;
+105 ;Generated Scripts -"
+106 SET DATA="""Generated Scripts -"""
DO WRITE^INHMGD1
+107 SET INJ=$GET(^INTHL7M(INDA,"S"))
+108 SET INK=$PIECE(INJ,U)
SET INL=$PIECE(INJ,U,2)
SET (INX,INY)=""
+109 ;input
IF INK
SET INX=$EXTRACT($PIECE($GET(^INRHS(INK,0)),U),1,60)
+110 ;output
IF INL
SET INY=$EXTRACT($PIECE($GET(^INRHS(INL,0)),U),1,60)
+111 SET DATA="?ING+3,""Input: "",INX"
DO WRITE^INHMGD1
+112 SET DATA="?ING+2,""Output: "",INY"
DO WRITE^INHMGD1
+113 ;
+114 QUIT
WRAPWP(INGN,INO,INW) ;WP wrapping routine, doesn't force wrap if text
+1 ; will fit on current line.
+2 ; Inputs:
+3 ; INGN = global name and nodes e.g. "^INTHL7M(12181,3,"
+4 ; INO = name of the output array (call by Reference)
+5 ; INW = width of the output field
+6 ; Outputs:
+7 ; INO = output array
+8 ;
+9 NEW INA,INDEX
+10 SET INO=1
SET INO(1)=""
SET INW=$GET(INW,35)
+11 SET INDEX=0
FOR
SET INDEX=$ORDER(@(INGN_INDEX_")"))
IF 'INDEX
QUIT
Begin DoDot:1
+12 SET INA=$GET(@(INGN_INDEX_",0)"))
SET INO(INO)=$GET(INO(INO))
+13 ;add a space if continuing on from a previous line
+14 SET INA=$SELECT($EXTRACT(INA)=" "!(INO(INO)=""):INA,1:" "_INA)
+15 IF $LENGTH(INO(INO)_INA)'>INW
SET INO(INO)=INO(INO)_INA
SET INO=INO+1
QUIT
+16 DO WRAPS(INA,.INO,INW)
End DoDot:1
+17 IF '$DATA(INO(INO))
SET INO=INO-1
+18 QUIT
WRAPS(INA,INO,INW) ;Array Wrapping routine - Completes WRAP.
+1 ; Inputs:
+2 ; INA = input, a long string.
+3 ; INO = output array (call by reference)
+4 ; INW = desired width of output array
+5 ; Output:
+6 ; INO = output array
+7 ;
+8 NEW INS
+9 SET INO=$GET(INO,1)
SET INO(INO)=$GET(INO(INO))_INA
+10 FOR
IF $LENGTH(INO(INO))'>INW
QUIT
Begin DoDot:1
+11 ;find a space to break the line
+12 FOR INS=INW:-1:1
IF $EXTRACT(INO(INO),INS)=" "
QUIT
+13 ;if space not found
IF INS'>1
SET INS=INW
+14 ;keep remainder of line
SET INO(INO+1)=$EXTRACT(INO(INO),INS+1,999)
+15 ;copy 1st part to output array
SET INO(INO)=$EXTRACT(INO(INO),1,INS)
SET INO=INO+1
End DoDot:1
+16 QUIT
