source: FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR4.m@ 1713

HLCSHDR4 ;SFIRMFO/LJA - Reset MSH Segment Fields ;10/09/2007 15:05
 ;;1.6;HEALTH LEVEL SEVEN;**93,108,122**;Oct 13, 1995;Build 14
 ;Per VHA Directive 2004-038, this routine should not be modified
 ;
DEBUG(STORE) ; If HLP set up for debugging, capture VIEW...
 ; HLMSH773 -- req
 ;
 N NOW,NUM,VAR,VARS,X,XTMP
 ;
 ; 1=some, 2=all
 S STORE=$S(STORE=1:1,STORE=2:2,1:0) QUIT:'STORE  ;->
 ;
 S NOW=$$NOW^XLFDT
 ;
 S XTMP="HLCSHDR3 "_HLMSH773
 S:'$D(^XTMP(XTMP,0)) ^XTMP(XTMP,0)=$$FMADD^XLFDT(NOW,0,4)_U_NOW_U_"Debug data created by DEBUG~HLCSHDR4"
 ;
 S NUM=$O(^XTMP(XTMP,":"),-1)+1
 ;
 ; Grab only critical (some) variables?
 I STORE=1 D
 .
 .  ; Sending information...
 .  S ^XTMP(XTMP,NUM,"SA")=HLMSHSAO_U_HLSAN_U_HLMSHSAN
 .  S ^XTMP(XTMP,NUM,"SF")=HLMSHSFO_U_HLSFN_U_HLMSHSFN
 .
 .  ; Receiving information...
 .  S ^XTMP(XTMP,NUM,"RA")=HLMSHRAO_U_HLRAN_U_HLMSHRAN
 .  S ^XTMP(XTMP,NUM,"RF")=HLMSHRFO_U_HLRFN_U_HLMSHRFN
 .
 .  ; Other information...    (HLMSHPRE and HLMSHPRS hold 2 pieces!)
 .  S ^XTMP(XTMP,NUM,0)=NOW_U_HLMSH772_U_HLMSHPRE_U_HLMSHPRS
 .  S ^XTMP(XTMP,NUM,1)=HLMSHPRO
 ;
 ; Grab all variables?
 I STORE=2 D
 .  S X="^XTMP("""_XTMP_""","_NUM_","
 .  D DOLRO^%ZOSV
 ;
 QUIT
 ;
SHOW N I773
 F  R !!,"Enter 773 IEN: ",I773:60 Q:I773'>0  D
 .  D SHOW773(I773)
 QUIT
 ;
SHOW773(I773) ; Show Dynamic Routing MSH Field Reset Details
 N DIV,MSH,N90,N91
 ;
 S N90=$G(^HLMA(+I773,90)),N91=$G(^HLMA(+I773,91))
 I (N90_N91)']"" D  QUIT  ;->
 .  W "  no debug data found..."
 ;
 S MSH=$G(^HLMA(+I773,"MSH",1,0)) QUIT:MSH']""  ;->
 S DIV=$E(MSH,4)
 ;
 W !!,$$CJ^XLFSTR(" 773 # "_I773_" ",IOM,"=")
 ;
 D HDR(90,N90)
 ;
 W !
 D HDR(91,N91)
 ;
 W !!,$E(MSH,1,IOM)
 ;
 S C1=10,C2=30,C3=50
 W !!,?C1,"Original (91)",?2,"Array (90)",?3,"MSH-Segment"
 W !,$$REPEAT^XLFSTR("-",IOM)
 D LINE("snd app",1,2,3)
 D LINE("snd fac",3,3,4)
 D LINE("rec app",5,4,5)
 D LINE("rec fac",7,5,6)
 ;
 QUIT
 ;
LINE(HDR,PCE1,PCE2,PCE3) ; Print one comparison line...
 N P1,P2,P3,P4
 S P1=$P(N91,U,PCE1),P2=$P(N90,U,PCE2),P3=$P(MSH,DIV,PCE3),P4=$P(N91,U,PCE1+1)
 W !,HDR,":",?C1,P1,?2,P2,?3,P3,$S(P4]"":" ["_P4_"]",1:"")
 QUIT
 ;
HDR(NUM,DATA) N TXT
 S TXT=$S(NUM=90:"Array (90)",NUM=91:"Original (91)",1:"")
 W !,$$CJ^XLFSTR("---------- "_TXT_" ----------",IOM)
 W $$CJ^XLFSTR(DATA,IOM)
 QUIT
 ;
SET(NEW,VAR,PCE) ; This subroutine performs these actions:
 ; (1) Resets variables used in MSH segment
 ; (2) Resets SERAPP and CLNTAPP in ^HLMA(#,0)
 ; (3) Sets HLMSH91 nodes if overwrite occurs by ARRAY value.
 ;     If overwrite occurs by M code, the overwrite has already
 ;     been recorded in HLMSH91.  (An overwrite produced by M code
 ;     is never overwritten by ARRAY data.)
 ;
 N IEN771N,IEN771O,HLTCP
 ;
 ; VAR is the name of the variable, and not it's value...
 S PRE=@VAR ; PRE is now the value of the VAR (pre-overwrite) variable...
 ;
 ; Tests whether anything was changed...
 QUIT:NEW']""  ;-> No new value exists to change to...
 QUIT:NEW=PRE  ;-> New value = Original value.  Nothing changed...
 ;
 ; THIS IS THE EPICENTER!!  This is where the variables used in
 ; the MSH segment is overwritten.
 S @VAR=NEW
 ;
 ; If PRE exists at this point, it was done by M code...
 QUIT:$P(HLMSH91,U,PCE)]""  ;->
 ;
 ; Change was made, but not by M code.  Must be by array...
 S $P(HLMSH91,U,PCE)=PRE,$P(HLMSH91,U,PCE+1)="A"
 ;
 ; patch HL*1.6*122: for "^" as component separater
 S $P(HLMSH91,U,PCE+2,999)=""
 ;
 ; Upgrade ^HLMA(#,0)...
 QUIT:PCE'=1&(PCE'=5)  ;->
 ;
 ; patch HL*1.6*108 start
 ;S IEN771O=$O(^HL(771,"B",PRE,0)) QUIT:IEN771O'>0  ;-> Orig IEN
 ;S IEN771N=$O(^HL(771,"B",NEW,0)) QUIT:IEN771N'>0  ;-> New IEN
 S IEN771O=$O(^HL(771,"B",$E(PRE,1,30),0)) QUIT:IEN771O'>0  ;-> Orig IEN
 S IEN771N=$O(^HL(771,"B",$E(NEW,1,30),0)) QUIT:IEN771N'>0  ;-> New IEN
 ; patch HL*1.6*108 end
 ;
 QUIT:'IEN771O!('IEN771N)!(IEN771O=IEN771N)  ;->
 S HLTCP=1 ; So 773 is updated...
 I PCE=1 D UPDATE^HLTF0(MTIENS,"","O","","",IEN771N)
 I PCE=5 D UPDATE^HLTF0(MTIENS,"","O","",IEN771N)
 ;
 QUIT
 ;
FIELDS ; Display the Protocol file fields used by the VistA HL7 package,
 ; when messages are received, to find the event and subscriber
 ; protocols.
 N BY,DIC,DIOEND,L
 ;
 D HD
 ;
 W !
 ;
 S L="",DIC="^ORD(101,",BY="[HL PROTOCOL MESSAGING FIELDS]"
 S DIOEND="D EXPL^HLCSHDR4"
 D EN1^DIP
 ;
 Q
 ;
HD W @IOF,$$CJ^XLFSTR("HL7 Protocol Messaging Fields",IOM)
 W !,$$REPEAT^XLFSTR("=",IOM)
 W !,"This 'HL7 Protocol Messaging Fields' report holds information that will help"
 W !,"you determine the effects from changes to routing-related fields in the MSH"
 W !,"segment when messages are sent between or within VistA HL7 systems."
 W !,"Additional explanation is included at the bottom of the report."
 Q
 ;
EXPL N I,T QUIT:'$$EXPL1("Press RETURN for 'printout help', or '^' to exit... ")  X "F I=1:1 S T=$T(EXPL+I) QUIT:T'["";;""  W !,$P(T,"";;"",2,99)" S I=$$EXPL1("Press RETURN to exit... ",1)
 ;;
 ;;When messages are received, their SENDING APPLICATION (MSH-3), MESSAGE
 ;;TYPE (MSH-9), EVENT TYPE (MSH-9), and HL7 VERSION (MSH-12) fields are used to
 ;;find the event driver protocol to be used in processing the just-received
 ;;message. After the event protocol is found, that protocol's subscriber
 ;;protocols are evaluated.  The subscriber protocol with a RECEIVING 
 ;;APPLICATION value that matches the RECEIVING APPLICATION field in the MSH
 ;;segment (MSH-5) is used.
 ;;
 ;;The first line for every "section" in the printout is the event driver
 ;;protocol. Lines preceded by dashes, are related subscriber protocols.  An
 ;;example is shown below.
 ;;
 ;;Snd/Rec App's    mTYP   eTYP   Ver        Protocol                     Link
 ;;------------------------------------------------------------------------------
 ;;AC-VOICERAD      ORU    R01    2.3    |   AC ORU SERVER
 ;;-AC-RADIOLOGY    ORU    R01    2.3    |   AC ORU CLIENT                NC  TCP
 ;;
 ;;In this example, the 'AC-VOICERAD' line holds information for the 'AC ORU
 ;;SERVER' event protocol.  And, the '-AC-RADIOLOGY' line holds information for
 ;;the 'AC ORU CLIENT' subscriber protocol.
 Q
 ;
EXPL1(PMT,FF) ;
 N DIR,DIRUT,DTOUT,DUOUT,X,Y
 QUIT:$E($G(IOST),1,2)'="C-" 1 ;->
 F X=1:1:$G(FF) W !
 S DIR(0)="EA",DIR("A")=PMT
 D ^DIR
 QUIT $S(Y=1:1,1:"")
 ;
M ; Covered by Integration Agreement #3988
 ; Application developers may call here when creating new messages,
 ; when experimenting with M code to evaluate and conditionally change
 ; routing-related fields. 
 ;
 ; This API is called immediately before the MSH segment is created.
 N IOINHI,IOINORM,MSHOLD,MSHNEW,MSHPRE,X
 ;
 S X="IOINHI;IOINORM" D ENDR^%ZISS
 ;
 S MSHOLD=$$MSHBUILD(0),MSHPRE=$$MSHBUILD(1)
 W !!,"The original MSH segment is...",!!,IOINHI,MSHOLD,IOINORM
 I MSHPRE'=MSHOLD D
 .  W !!,"The MSH segment, after modification by passed-in data, is..."
 .  W !!,IOINHI,MSHPRE,IOINORM
 ;
 D MVAR("SENDING APPLICATION","HLMSHSAN","SERAPP")
 D MVAR("SENDING FACILITY","HLMSHSFN","SERFAC")
 D MVAR("RECEIVING APPLICATION","HLMSHRAN","CLNTAPP")
 D MVAR("RECEIVING FACILITY","HLMSHRFN","CLNTFAC")
 ;
 S MSHNEW=$$MSHBUILD
 I MSHNEW'=MSHPRE D
 .  W !!,"Before your changes above, the modified MSH segment was..."
 .  W !!,IOINHI,MSHPRE,IOINORM
 .  W !!,"After your changes, the MSH segment is..."
 .  W !!,IOINHI,MSHNEW,IOINORM
 W !!,$$REPEAT^XLFSTR("-",IOM)
 W !!,"Message being sent..."
 W !
 ;
 Q
 ;
MVAR(FLD,VAR,VARO) ; Generic resetting of variable...
 ;IOINHI,IOINORM -- req
 N ANS
 W !!,?4,"Protocol-derived value of ",FLD,": "
 W IOINHI,@VARO,IOINORM
 W !,"Passed-in value of ",FLD," (",VAR,"): "
 W IOINHI,@VAR,IOINORM
 W !,?10,"Enter new value for ",FLD,": "
 R ANS:60 Q:'$T  ;->
 I ANS[U!(ANS']"") D
 .  W !!,?10,"No changes will be made..."
 I ANS'[U&(ANS]"") D
 .  S @VAR=ANS
 .  W !!,?10,"The variable ",IOINHI,VAR,IOINORM
 .  W " will be changed to '",IOINHI,ANS,IOINORM,"'."
 .  W !,?10,"This value will be stored in the ",FLD
 .  W !,?10,"field in the MSH segment..."
 .  W !!,$$REPEAT^XLFSTR("-",IOM)
 Q
 ;
MSHBUILD(TYPE) ; Build MSH using current variables...
 N MSH,PCE,RAN,RFN,SAN,SFN
 S MSH="MSH"_FS_EC
 I $G(TYPE)=0 F PCE=SERAPP,SERFAC,CLNTAPP,CLNTFAC,HLDATE,SECURITY,MSGTYPE,HLID,HLPID,$P(PROT,U,9),"",$G(^HL(772,TXTP,1)),ACCACK,APPACK,CNTRY D
 .  S MSH=MSH_FS_PCE
 I $G(TYPE)'=0 D
 .  S SAN=HLMSHSAN,SAN=$S(SAN]"":SAN,1:SERAPP)
 .  S SFN=HLMSHSFN,SFN=$S(SFN]"":SFN,1:SERFAC)
 .  S RAN=HLMSHRAN,RAN=$S(RAN]"":RAN,1:CLNTAPP)
 .  S RFN=HLMSHRFN,RFN=$S(RFN]"":RFN,1:CLNTFAC)
 .  F PCE=SAN,SFN,RAN,RFN,HLDATE,SECURITY,MSGTYPE,HLID,HLPID,$P(PROT,U,9),"",$G(^HL(772,TXTP,1)),ACCACK,APPACK,CNTRY D
 .  .  S MSH=MSH_FS_PCE
 QUIT MSH
 ;
EOR ;HLCSHDR4 - Reset MSH Segment Fields ;9/12/02 11:50