Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: HLCSHDR6

HLCSHDR6.m

Go to the documentation of this file. 
  1. HLCSHDR6 ;OIRMFO/LJA - Make HL7 header for TCP ;1/27/03 15:30
  1.  ;;1.6;HEALTH LEVEL SEVEN;**93**;Oct 13, 1995
  1.  ;
  1. MARKERRA ; Mark 772 & 773 entries in error (to stop messaging)...
  1.  N %ZHO,ERR,ERREA,HLD,HLTCP,IEN772,IEN773,MSH,N02,POSX,X
  1.  D HDERR
  1.  R !!,"Enter ERROR REASON: ",ERREA:999 Q:'$T!(ERREA']"")!(ERREA[U)  ;->
  1.  F  D  Q:'IEN772  W !!,$$REPEAT^XLFSTR("-",IOM)
  1.  .  R !!," 772:  ",IEN772:9999 Q:IEN772'>0!('$T)  ;->
  1.  .  S N02=$G(^HL(772,+IEN772,0))
  1.  .  W !!,"772-0: "
  1.  .  S POSX=$X
  1.  .  W $E(N02,1,IOM-POSX)
  1.  .  S X=$G(^HL(772,+IEN772,"P")) I X]"" W !,?(POSX-3),"P: ",$E(X,1,IOM-POSX)
  1.  .  KILL HLD
  1.  .  W:$D(^HLMA("B",+IEN772)) !!,"773s:",?POSX
  1.  .  S IEN773=0
  1.  .  F  S IEN773=$O(^HLMA("B",+IEN772,IEN773)) Q:IEN773'>0  D
  1.  .  .  W:$X>POSX ! W:$X<POSX ?POSX
  1.  .  .  S HLD(IEN773)=""
  1.  .  .  S X=$G(^HLMA(+IEN773,"P")) I X]"" W "  P: ",$E(X,1,IOM-$X)
  1.  .  .  W:$X>POSX ! W:$X<POSX ?POSX
  1.  .  .  W "MSH: "
  1.  .  .  S POSX=$X
  1.  .  .  S MSH=$G(^HLMA(+IEN773,"MSH",1,0))
  1.  .  .  F  D  Q:MSH']""
  1.  .  .  .  W:$X>POSX ! W:$X<POSX ?POSX
  1.  .  .  .  W $E(MSH,1,IOM-POSX)
  1.  .  .  .  S MSH=$E(MSH,IOM-POSX+1,999)
  1.  .  R !!,"Press RETURN to mark errored, or enter '^' to abort... ",X:999 I '$T!(X]"") D  QUIT  ;->
  1.  .  .  W "  no action taken..."
  1.  .  W !!,?10,"Marking 772's #",IEN772," errored... "
  1.  .  S ERR=$$ERR(772,IEN772,ERREA)
  1.  .  W $S(ERR:"  done...",1:"Aborted!! "_$P(ERR,U,2)_"...")
  1.  .  I '$D(HLD) QUIT  ;->
  1.  .  S IEN773=0
  1.  .  F  S IEN773=$O(HLD(IEN773)) Q:IEN773'>0  D
  1.  .  .  W !,?10,"Marking 773's #",IEN773," errored... "
  1.  .  .  S ERR=$$ERR(773,IEN773,ERREA)
  1.  .  .  W $S(ERR:"  done...",1:"Aborted!! "_$P(ERR,U,2)_"...")
  1.  ;
  1.  Q
  1.  ;
  1. MARKERRG ; Global-based error marking of 772, 773...
  1.  N %ZHO,ERR,ERREA,HLD,HLTCP,IEN772,IEN773,MSH,N02,POSX,X
  1.  D HDERR
  1.  R !!,"Enter ERROR REASON: ",ERREA:999 Q:'$T!(ERREA']"")!(ERREA[U)  ;->
  1.  I '$D(^TMP("HLCSHDR5 ERR",$J)) D  QUIT  ;->
  1.  .  W !!,"No ^TMP(""HLCSHDR5 ERR"",$J) data exists..."
  1.  .  W !
  1.  W !!,"The entries in ^TMP(""HLCSHDR5 ERR"",$J) will be marked in error now."
  1.  R !!,"Press RETURN to start error marking... ",X:999 Q:'$T!(X]"")  ;->
  1.  ;
  1. ERRQ S IEN772=0
  1.  F  S IEN772=$O(^TMP("HLCSHDR5 ERR",$J,IEN772)) Q:IEN772'>0  D
  1.  .  W !,"Marking 772's #",IEN772,"... "
  1.  .  S ERR=$$ERR(772,IEN772,ERREA)
  1.  .  W $S(ERR:"  done...",1:"Aborted!! "_$P(ERR,U,2)_"...")
  1.  .  S IEN773=0
  1.  .  F  S IEN773=$O(^HLMA("B",IEN772,IEN773)) Q:IEN773'>0  D
  1.  .  .  S ERR=$$ERR(773,IEN773,ERREA)
  1.  .  .  W !,"   - 773# ",IEN773," checked..."
  1.  Q
  1.  ;
  1. HDERR W @IOF,$$CJ^XLFSTR("Error Marking Utility",IOM)
  1.  W !,$$REPEAT^XLFSTR("=",IOM)
  1.  Q
  1.  ;
  1. ERR(FILE,IEN,ERREA) ; Change status to ERROR for 772 or 773 (if the P
  1.  ; node status exists.)
  1.  ;
  1.  N DATA,ERR,HLTCP
  1.  ;
  1.  I FILE=772 D  QUIT:ERR U_$P(ERR,U,2,99) ;->
  1.  .  S ERR=""
  1.  .  I $G(^HL(772,+$G(IEN),0))']"" S ERR="1^NO 772 0 NODE" QUIT  ;->
  1.  ;
  1.  I FILE=773 D  QUIT:ERR U_$P(ERR,U,2,99) ;->
  1.  .  S HLTCP=1 ; Used by STATUS^HLTF0
  1.  .  S ERR=""
  1.  .  I $G(^HLMA(+$G(IEN),0))']"" S ERR="1^NO 773 0 NODE" ;->
  1.  ;
  1.  QUIT:$G(ERREA)']"" "^NO REASON" ;->
  1.  ;
  1.  ; Does entry need to be marked in error.  (Only mark if status
  1.  ; already exists)
  1.  S DATA=$S(FILE=772:$G(^HL(772,+IEN,"P")),1:$G(^HLMA(+IEN,"P")))
  1.  QUIT:$P(DATA,U)']"" 1 ;->
  1.  ;
  1.  D STATUS^HLTF0(IEN,4,"",ERREA,1)
  1.  ;
  1.  Q 1
  1.  ;
  1. EOR ;HLCSHDR6 - Make HL7 header for TCP ;1/27/03 15:30