HLCSHDR5 ;OIRMFO/LJA - Make HL7 header for TCP ;1/27/03 15:30
;;1.6;HEALTH LEVEL SEVEN;**93**;Oct 13, 1995
;
; The MSHALL API is not supported!
;
MSHALL ; Allows application developer, in test and development environments,
; to change almost every field in the MSH segment. This feature
; allows the testing of the ramifications of MSH field changes, avoiding
; the need to edit protocol file (and other file) entries from which
; the MSH segment fields are derived.
;
; Call here ONLY if the full suite of variables used in MSH segment
; creation are available!
;
; Call method: S HLP("SUBSCRIBER"[,n])="^^^^^MSHALL^HLCSHDR5"
; D GENERATE^HLMA(.....,.HLP)
;
; When the above HLP array is passed into the
; GENERATE^HLMA API, the MSHALL subroutine is
; invoked, giving the developer full control over
; most MSH segment fields; even those fields not
; changeable by HL*1.6*93.
;
; See HL*1.6*93 for information about the passing
; of HLP("SUBSCRIBER"[,n]) information, and the
; calling of the GENERATE^HLMA API.
;
; Warning! No audit trail (in ^HLMA or ^XTMP) is maintained.
; Full responsibility rests with the application
; developer.
;
; EC,FS -- req
;
N ACTION,CHANGE,IOINHI,IOINORM,MSHFINAL,MSHLAST,MSHORIG
N SAVE,PCE,VAL1,VAL2,X
;
D SAVEORIG
S (MSHFINAL,MSHLAST)=MSHORIG
;
MSHCONT ;
F D Q:'CHANGE
. S CHANGE=0
. D SHOWMSH
. D ASKMSH
. S MSHFINAL=$$MSH
. QUIT:MSHFINAL=MSHLAST ;->
. S CHANGE=1
. S MSHLAST=$$MSH
;
I MSHFINAL=MSHORIG W !!,"The MSH segment was not changed..."
I MSHFINAL'=MSHORIG D
. S X="IOINHI;IOINORM" D ENDR^%ZISS
. W !!,MSHORIG,!!," changed to...",!!
. F PCE=1:1:$L(MSHFINAL,FS) D
. . W:PCE'=1 FS
. . S VAL1=$P(MSHORIG,FS,PCE),VAL2=$P(MSHFINAL,FS,PCE)
. . W:VAL1'=VAL2 IOINHI
. . W VAL2
. . W IOINORM
;
S ACTION=$$DOWHAT
I ACTION="B" D G MSHCONT ;->
. QUIT:MSHFINAL=MSHORIG ;->
. W !!,"You have made some changes to the original MSH segment. Do you want to"
. W !,"""forget"" these changes, and reset the MSH segment to it's original state?"
. QUIT:'$$YN("Reset MSH segment","No",1) ;->
. D RESTORE
. S (MSHFINAL,MSHLAST)=MSHORIG
;
Q
;
YN(PMT,DEF,FF) ;
N DIR,DIRUT,DTOUT,DUOUT,X,Y
F I=1:1:$G(FF) W !
S DIR(0)="Y",DIR("A")=PMT
S:$G(DEF)]"" DIR("B")=DEF
D ^DIR
Q $S(+Y=1:1,1:"")
;
DOWHAT() ; Reenter MSH or send message...
N DIR,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="S^B:Back up and change MSH segment;C:Continue on (and send message)"
S DIR("A")="Enter ACTION",DIR("B")="Continue"
D ^DIR
QUIT $S(Y="B":"B",1:"C")
;
SHOWMSH ;
; MSHORIG -- req
N C2,C3,C4,DATA,IOINHI,IOINORM,MSH,PCE,REF,TAG,VAL,X,XEC
;
S X=MSHORIG N MSHORIG S MSHORIG=X
S C2=4,C3=18,C4=40
I $G(FS)']""!($G(EC)']"") N EC,FS S FS=U,EC="~|\&"
S X="IOINHI;IOINORM" D ENDR^%ZISS
;
W @IOF,!,$$CJ^XLFSTR("MSH Segment Values",IOM)
W !,$$REPEAT^XLFSTR("-",IOM)
W !,"#",?C2,"Field",?C3,"Variable",?C4,"Value"
W !,$$REPEAT^XLFSTR("=",IOM)
;
F PCE=1:1 S DATA=$T(FLDS+PCE) Q:$E(DATA,1,3)'=" ;;"!(DATA']"") S DATA=$P(DATA,";;",2,99) D
. S REF=$P(DATA,U),XEC=$P(DATA,U,2),TAG=$P(DATA,U,3)
. S VAL=REF
. I PCE=11 S REF=$TR(REF,"~",U)
. I XEC=1,PCE'=12 S VAL=@REF
. I XEC=2!(PCE=12) S X="S VAL="_REF X X KILL X
. W !,$J(PCE,2),?C2,$$S(TAG,12),?C3,$$S(REF,18)
. W ?C4
. I XEC=1 W IOINHI
. W VAL,IOINORM
. W $S(XEC=1:$$CHG(VAL,PCE),1:"")
;
Q
;
S(T,C) QUIT:$L(T)<(C+1) T ;->
QUIT $E(T,1,C-1)_"~"
;
CHG(VAL,PCE) ; Has data been changed?
; MSHORIG -- req
N VALORIG
S VALORIG=$P(MSHORIG,FS,+PCE)
QUIT:VALORIG=VAL "" ;->
Q " *"
;
ASKMSH ; Ask user to input different field values
N DATA,DIR,DIRUT,DTOUT,DUOUT,FIELD,PCE,TITLE,VAL,VAR,X,Y
;
W !
;
S DIR="SOA^"
F PCE=3:1:12,15:1:17 D
. S DATA=$P($T(FLDS+PCE),";;",2,999),VAR=$P(DATA,U),TITLE=$P(DATA,U,3)
. S DIR=DIR_$S(PCE>3:";",1:"")_PCE_":"_TITLE_" ("_VAR_")"
S DIR(0)=DIR
S DIR("A")="Enter FIELD #: "
D ^DIR
QUIT:+Y'>0 ;->
;
S FIELD=+Y,VAR=$P($P($T(FLDS+FIELD),";;",2,99),U)
I FIELD'=12 S VAL=@VAR
I FIELD=12 S X="S VAL="_VAR X X KILL X
;
W !!,"Current '",VAR,"' value = ",VAL
W !
;
KILL DIR,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="F",DIR("A")="Field value"
D ^DIR
QUIT:$D(DIRUT)!($D(DTOUT))!($D(DUOUT)) ;->
;
S ANS=Y
;
I ANS=VAL W " nothing changed..." QUIT ;->
;
; Make the change...
I FIELD'=12 S @VAR=ANS
I FIELD=12 S $P(PROT,U,9)=ANS
W " changed..."
;
Q
;
MSH() ;Build MSH array
N DATA,MSH,PCE,REF,TAG,XEC
;
S MSH=""
;
F PCE=1:1 S DATA=$T(FLDS+PCE) Q:$E(DATA,1,3)'=" ;;"!(DATA']"") S DATA=$P(DATA,";;",2,99) D
. S REF=$P(DATA,U),XEC=$P(DATA,U,2)
. I PCE=11 S REF=$TR(REF,"~",U)
. I XEC=0 S VAL=REF
. I XEC=1,PCE'=12 S VAL=@REF
. I XEC=2!(PCE=12) S X="S VAL="_REF X X KILL X
. S MSH=MSH_$S(MSH]"":FS,1:"")_VAL
;
Q MSH
;
SAVEORIG ; Save value of original variables...
KILL SAVE
;
S SAVE("SERAPP")=SERAPP,SAVE("SERFAC")=SERFAC
S SAVE("CLNTAPP")=CLNTAPP,SAVE("CLNTFAC")=CLNTFAC
S SAVE("HLDATE")=HLDATE,SAVE("SECURITY")=SECURITY
S SAVE("MSGTYPE")=MSGTYPE,SAVE("HLID")=HLID
S SAVE("HLPID")=HLPID,SAVE("ACCACK")=ACCACK
S SAVE("APPACK")=APPACK,SAVE("CNTRY")=CNTRY
S SAVE("$P(PROT,U,9)")=$P(PROT,U,9)
;
S MSHORIG=$$MSH
;
Q
;
RESTORE ;
N VAL,VAR
;
; restore variables...
S VAR=""
F S VAR=$O(SAVE(VAR)) Q:VAR']"" D
. QUIT:VAR["$P(PROT,U,9)" ;->
. S @VAR=SAVE(VAR)
S $P(PROT,U,9)=SAVE("$P(PROT,U,9)")
;
; Restore beginning MSH...
S (MSHFINAL,MSHLAST)=MSHORIG
;
Q
;
FLDS ; List of fields and their variables in MSH segment...
;;MSH^0
;;EC^2
;;SERAPP^1^SND-APP
;;SERFAC^1^SND-FAC
;;CLNTAPP^1^REC-APP
;;CLNTFAC^1^REC-FAC
;;HLDATE^1^D/T
;;SECURITY^1^SECURE
;;MSGTYPE^1^MSGTYPE
;;HLID^1^MSG-ID
;;HLPID^1^PID
;;$P(PROT,U,9)^1^VERSION
;;^0
;;^0^CONTINUATION
;;ACCACK^1^COMACK
;;APPACK^1^APPACK
;;CNTRY^1^COUNTRY
Q
;
PRACTICE ; Practice MSH variables...
S EC="~|\&",FS=U
S SERAPP="SND-APP",SERFAC=512,CLNTAPP="REC-APP",CLNTFAC=661
S HLDATE=200301020135,SECURITY="SEC",MSGTYPE="ORU~R01"
S HLID="543010101",HLPID="P"
S $P(PROT,U,9)="2.3",TXTP=999
S ACCACK="AL",APPACK="AL",CNTRY="US"
Q
;
;
EOR ;HLCSHDR5 - Make HL7 header for TCP ;1/27/03 15:30
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLCSHDR5 6547 printed Dec 13, 2024@01:56:37 Page 2
HLCSHDR5 ;OIRMFO/LJA - Make HL7 header for TCP ;1/27/03 15:30
+1 ;;1.6;HEALTH LEVEL SEVEN;**93**;Oct 13, 1995
+2 ;
+3 ; The MSHALL API is not supported!
+4 ;
MSHALL ; Allows application developer, in test and development environments,
+1 ; to change almost every field in the MSH segment. This feature
+2 ; allows the testing of the ramifications of MSH field changes, avoiding
+3 ; the need to edit protocol file (and other file) entries from which
+4 ; the MSH segment fields are derived.
+5 ;
+6 ; Call here ONLY if the full suite of variables used in MSH segment
+7 ; creation are available!
+8 ;
+9 ; Call method: S HLP("SUBSCRIBER"[,n])="^^^^^MSHALL^HLCSHDR5"
+10 ; D GENERATE^HLMA(.....,.HLP)
+11 ;
+12 ; When the above HLP array is passed into the
+13 ; GENERATE^HLMA API, the MSHALL subroutine is
+14 ; invoked, giving the developer full control over
+15 ; most MSH segment fields; even those fields not
+16 ; changeable by HL*1.6*93.
+17 ;
+18 ; See HL*1.6*93 for information about the passing
+19 ; of HLP("SUBSCRIBER"[,n]) information, and the
+20 ; calling of the GENERATE^HLMA API.
+21 ;
+22 ; Warning! No audit trail (in ^HLMA or ^XTMP) is maintained.
+23 ; Full responsibility rests with the application
+24 ; developer.
+25 ;
+26 ; EC,FS -- req
+27 ;
+28 NEW ACTION,CHANGE,IOINHI,IOINORM,MSHFINAL,MSHLAST,MSHORIG
+29 NEW SAVE,PCE,VAL1,VAL2,X
+30 ;
+31 DO SAVEORIG
+32 SET (MSHFINAL,MSHLAST)=MSHORIG
+33 ;
MSHCONT ;
+1 FOR
Begin DoDot:1
+2 SET CHANGE=0
+3 DO SHOWMSH
+4 DO ASKMSH
+5 SET MSHFINAL=$$MSH
+6 ;->
if MSHFINAL=MSHLAST
QUIT
+7 SET CHANGE=1
+8 SET MSHLAST=$$MSH
End DoDot:1
if 'CHANGE
QUIT
+9 ;
+10 IF MSHFINAL=MSHORIG
WRITE !!,"The MSH segment was not changed..."
+11 IF MSHFINAL'=MSHORIG
Begin DoDot:1
+12 SET X="IOINHI;IOINORM"
DO ENDR^%ZISS
+13 WRITE !!,MSHORIG,!!," changed to...",!!
+14 FOR PCE=1:1:$LENGTH(MSHFINAL,FS)
Begin DoDot:2
+15 if PCE'=1
WRITE FS
+16 SET VAL1=$PIECE(MSHORIG,FS,PCE)
SET VAL2=$PIECE(MSHFINAL,FS,PCE)
+17 if VAL1'=VAL2
WRITE IOINHI
+18 WRITE VAL2
+19 WRITE IOINORM
End DoDot:2
End DoDot:1
+20 ;
+21 SET ACTION=$$DOWHAT
+22 ;->
IF ACTION="B"
Begin DoDot:1
+23 ;->
if MSHFINAL=MSHORIG
QUIT
+24 WRITE !!,"You have made some changes to the original MSH segment. Do you want to"
+25 WRITE !,"""forget"" these changes, and reset the MSH segment to it's original state?"
+26 ;->
if '$$YN("Reset MSH segment","No",1)
QUIT
+27 DO RESTORE
+28 SET (MSHFINAL,MSHLAST)=MSHORIG
End DoDot:1
GOTO MSHCONT
+29 ;
+30 QUIT
+31 ;
YN(PMT,DEF,FF) ;
+1 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+2 FOR I=1:1:$GET(FF)
WRITE !
+3 SET DIR(0)="Y"
SET DIR("A")=PMT
+4 if $GET(DEF)]""
SET DIR("B")=DEF
+5 DO ^DIR
+6 QUIT $SELECT(+Y=1:1,1:"")
+7 ;
DOWHAT() ; Reenter MSH or send message...
+1 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+2 SET DIR(0)="S^B:Back up and change MSH segment;C:Continue on (and send message)"
+3 SET DIR("A")="Enter ACTION"
SET DIR("B")="Continue"
+4 DO ^DIR
+5 QUIT $SELECT(Y="B":"B",1:"C")
+6 ;
SHOWMSH ;
+1 ; MSHORIG -- req
+2 NEW C2,C3,C4,DATA,IOINHI,IOINORM,MSH,PCE,REF,TAG,VAL,X,XEC
+3 ;
+4 SET X=MSHORIG
NEW MSHORIG
SET MSHORIG=X
+5 SET C2=4
SET C3=18
SET C4=40
+6 IF $GET(FS)']""!($GET(EC)']"")
NEW EC,FS
SET FS=U
SET EC="~|\&"
+7 SET X="IOINHI;IOINORM"
DO ENDR^%ZISS
+8 ;
+9 WRITE @IOF,!,$$CJ^XLFSTR("MSH Segment Values",IOM)
+10 WRITE !,$$REPEAT^XLFSTR("-",IOM)
+11 WRITE !,"#",?C2,"Field",?C3,"Variable",?C4,"Value"
+12 WRITE !,$$REPEAT^XLFSTR("=",IOM)
+13 ;
+14 FOR PCE=1:1
SET DATA=$TEXT(FLDS+PCE)
if $EXTRACT(DATA,1,3)'=" ;;"!(DATA']"")
QUIT
SET DATA=$PIECE(DATA,";;",2,99)
Begin DoDot:1
+15 SET REF=$PIECE(DATA,U)
SET XEC=$PIECE(DATA,U,2)
SET TAG=$PIECE(DATA,U,3)
+16 SET VAL=REF
+17 IF PCE=11
SET REF=$TRANSLATE(REF,"~",U)
+18 IF XEC=1
IF PCE'=12
SET VAL=@REF
+19 IF XEC=2!(PCE=12)
SET X="S VAL="_REF
XECUTE X
KILL X
+20 WRITE !,$JUSTIFY(PCE,2),?C2,$$S(TAG,12),?C3,$$S(REF,18)
+21 WRITE ?C4
+22 IF XEC=1
WRITE IOINHI
+23 WRITE VAL,IOINORM
+24 WRITE $SELECT(XEC=1:$$CHG(VAL,PCE),1:"")
End DoDot:1
+25 ;
+26 QUIT
+27 ;
S(T,C) ;->
if $LENGTH(T)<(C+1)
QUIT T
+1 QUIT $EXTRACT(T,1,C-1)_"~"
+2 ;
CHG(VAL,PCE) ; Has data been changed?
+1 ; MSHORIG -- req
+2 NEW VALORIG
+3 SET VALORIG=$PIECE(MSHORIG,FS,+PCE)
+4 ;->
if VALORIG=VAL
QUIT ""
+5 QUIT " *"
+6 ;
ASKMSH ; Ask user to input different field values
+1 NEW DATA,DIR,DIRUT,DTOUT,DUOUT,FIELD,PCE,TITLE,VAL,VAR,X,Y
+2 ;
+3 WRITE !
+4 ;
+5 SET DIR="SOA^"
+6 FOR PCE=3:1:12,15:1:17
Begin DoDot:1
+7 SET DATA=$PIECE($TEXT(FLDS+PCE),";;",2,999)
SET VAR=$PIECE(DATA,U)
SET TITLE=$PIECE(DATA,U,3)
+8 SET DIR=DIR_$SELECT(PCE>3:";",1:"")_PCE_":"_TITLE_" ("_VAR_")"
End DoDot:1
+9 SET DIR(0)=DIR
+10 SET DIR("A")="Enter FIELD #: "
+11 DO ^DIR
+12 ;->
if +Y'>0
QUIT
+13 ;
+14 SET FIELD=+Y
SET VAR=$PIECE($PIECE($TEXT(FLDS+FIELD),";;",2,99),U)
+15 IF FIELD'=12
SET VAL=@VAR
+16 IF FIELD=12
SET X="S VAL="_VAR
XECUTE X
KILL X
+17 ;
+18 WRITE !!,"Current '",VAR,"' value = ",VAL
+19 WRITE !
+20 ;
+21 KILL DIR,DIRUT,DTOUT,DUOUT,X,Y
+22 SET DIR(0)="F"
SET DIR("A")="Field value"
+23 DO ^DIR
+24 ;->
if $DATA(DIRUT)!($DATA(DTOUT))!($DATA(DUOUT))
QUIT
+25 ;
+26 SET ANS=Y
+27 ;
+28 ;->
IF ANS=VAL
WRITE " nothing changed..."
QUIT
+29 ;
+30 ; Make the change...
+31 IF FIELD'=12
SET @VAR=ANS
+32 IF FIELD=12
SET $PIECE(PROT,U,9)=ANS
+33 WRITE " changed..."
+34 ;
+35 QUIT
+36 ;
MSH() ;Build MSH array
+1 NEW DATA,MSH,PCE,REF,TAG,XEC
+2 ;
+3 SET MSH=""
+4 ;
+5 FOR PCE=1:1
SET DATA=$TEXT(FLDS+PCE)
if $EXTRACT(DATA,1,3)'=" ;;"!(DATA']"")
QUIT
SET DATA=$PIECE(DATA,";;",2,99)
Begin DoDot:1
+6 SET REF=$PIECE(DATA,U)
SET XEC=$PIECE(DATA,U,2)
+7 IF PCE=11
SET REF=$TRANSLATE(REF,"~",U)
+8 IF XEC=0
SET VAL=REF
+9 IF XEC=1
IF PCE'=12
SET VAL=@REF
+10 IF XEC=2!(PCE=12)
SET X="S VAL="_REF
XECUTE X
KILL X
+11 SET MSH=MSH_$SELECT(MSH]"":FS,1:"")_VAL
End DoDot:1
+12 ;
+13 QUIT MSH
+14 ;
SAVEORIG ; Save value of original variables...
+1 KILL SAVE
+2 ;
+3 SET SAVE("SERAPP")=SERAPP
SET SAVE("SERFAC")=SERFAC
+4 SET SAVE("CLNTAPP")=CLNTAPP
SET SAVE("CLNTFAC")=CLNTFAC
+5 SET SAVE("HLDATE")=HLDATE
SET SAVE("SECURITY")=SECURITY
+6 SET SAVE("MSGTYPE")=MSGTYPE
SET SAVE("HLID")=HLID
+7 SET SAVE("HLPID")=HLPID
SET SAVE("ACCACK")=ACCACK
+8 SET SAVE("APPACK")=APPACK
SET SAVE("CNTRY")=CNTRY
+9 SET SAVE("$P(PROT,U,9)")=$PIECE(PROT,U,9)
+10 ;
+11 SET MSHORIG=$$MSH
+12 ;
+13 QUIT
+14 ;
RESTORE ;
+1 NEW VAL,VAR
+2 ;
+3 ; restore variables...
+4 SET VAR=""
+5 FOR
SET VAR=$ORDER(SAVE(VAR))
if VAR']""
QUIT
Begin DoDot:1
+6 ;->
if VAR["$P(PROT,U,9)"
QUIT
+7 SET @VAR=SAVE(VAR)
End DoDot:1
+8 SET $PIECE(PROT,U,9)=SAVE("$P(PROT,U,9)")
+9 ;
+10 ; Restore beginning MSH...
+11 SET (MSHFINAL,MSHLAST)=MSHORIG
+12 ;
+13 QUIT
+14 ;
FLDS ; List of fields and their variables in MSH segment...
+1 ;;MSH^0
+2 ;;EC^2
+3 ;;SERAPP^1^SND-APP
+4 ;;SERFAC^1^SND-FAC
+5 ;;CLNTAPP^1^REC-APP
+6 ;;CLNTFAC^1^REC-FAC
+7 ;;HLDATE^1^D/T
+8 ;;SECURITY^1^SECURE
+9 ;;MSGTYPE^1^MSGTYPE
+10 ;;HLID^1^MSG-ID
+11 ;;HLPID^1^PID
+12 ;;$P(PROT,U,9)^1^VERSION
+13 ;;^0
+14 ;;^0^CONTINUATION
+15 ;;ACCACK^1^COMACK
+16 ;;APPACK^1^APPACK
+17 ;;CNTRY^1^COUNTRY
+18 QUIT
+19 ;
PRACTICE ; Practice MSH variables...
+1 SET EC="~|\&"
SET FS=U
+2 SET SERAPP="SND-APP"
SET SERFAC=512
SET CLNTAPP="REC-APP"
SET CLNTFAC=661
+3 SET HLDATE=200301020135
SET SECURITY="SEC"
SET MSGTYPE="ORU~R01"
+4 SET HLID="543010101"
SET HLPID="P"
+5 SET $PIECE(PROT,U,9)="2.3"
SET TXTP=999
+6 SET ACCACK="AL"
SET APPACK="AL"
SET CNTRY="US"
+7 QUIT
+8 ;
+9 ;
EOR ;HLCSHDR5 - Make HL7 header for TCP ;1/27/03 15:30
