HLCSHDR6 ;OIRMFO/LJA - Make HL7 header for TCP ;1/27/03 15:30
;;1.6;HEALTH LEVEL SEVEN;**93**;Oct 13, 1995
;
MARKERRA ; Mark 772 & 773 entries in error (to stop messaging)...
N %ZHO,ERR,ERREA,HLD,HLTCP,IEN772,IEN773,MSH,N02,POSX,X
D HDERR
R !!,"Enter ERROR REASON: ",ERREA:999 Q:'$T!(ERREA']"")!(ERREA[U) ;->
F D Q:'IEN772 W !!,$$REPEAT^XLFSTR("-",IOM)
. R !!," 772: ",IEN772:9999 Q:IEN772'>0!('$T) ;->
. S N02=$G(^HL(772,+IEN772,0))
. W !!,"772-0: "
. S POSX=$X
. W $E(N02,1,IOM-POSX)
. S X=$G(^HL(772,+IEN772,"P")) I X]"" W !,?(POSX-3),"P: ",$E(X,1,IOM-POSX)
. KILL HLD
. W:$D(^HLMA("B",+IEN772)) !!,"773s:",?POSX
. S IEN773=0
. F S IEN773=$O(^HLMA("B",+IEN772,IEN773)) Q:IEN773'>0 D
. . W:$X>POSX ! W:$X<POSX ?POSX
. . S HLD(IEN773)=""
. . S X=$G(^HLMA(+IEN773,"P")) I X]"" W " P: ",$E(X,1,IOM-$X)
. . W:$X>POSX ! W:$X<POSX ?POSX
. . W "MSH: "
. . S POSX=$X
. . S MSH=$G(^HLMA(+IEN773,"MSH",1,0))
. . F D Q:MSH']""
. . . W:$X>POSX ! W:$X<POSX ?POSX
. . . W $E(MSH,1,IOM-POSX)
. . . S MSH=$E(MSH,IOM-POSX+1,999)
. R !!,"Press RETURN to mark errored, or enter '^' to abort... ",X:999 I '$T!(X]"") D QUIT ;->
. . W " no action taken..."
. W !!,?10,"Marking 772's #",IEN772," errored... "
. S ERR=$$ERR(772,IEN772,ERREA)
. W $S(ERR:" done...",1:"Aborted!! "_$P(ERR,U,2)_"...")
. I '$D(HLD) QUIT ;->
. S IEN773=0
. F S IEN773=$O(HLD(IEN773)) Q:IEN773'>0 D
. . W !,?10,"Marking 773's #",IEN773," errored... "
. . S ERR=$$ERR(773,IEN773,ERREA)
. . W $S(ERR:" done...",1:"Aborted!! "_$P(ERR,U,2)_"...")
;
Q
;
MARKERRG ; Global-based error marking of 772, 773...
N %ZHO,ERR,ERREA,HLD,HLTCP,IEN772,IEN773,MSH,N02,POSX,X
D HDERR
R !!,"Enter ERROR REASON: ",ERREA:999 Q:'$T!(ERREA']"")!(ERREA[U) ;->
I '$D(^TMP("HLCSHDR5 ERR",$J)) D QUIT ;->
. W !!,"No ^TMP(""HLCSHDR5 ERR"",$J) data exists..."
. W !
W !!,"The entries in ^TMP(""HLCSHDR5 ERR"",$J) will be marked in error now."
R !!,"Press RETURN to start error marking... ",X:999 Q:'$T!(X]"") ;->
;
ERRQ S IEN772=0
F S IEN772=$O(^TMP("HLCSHDR5 ERR",$J,IEN772)) Q:IEN772'>0 D
. W !,"Marking 772's #",IEN772,"... "
. S ERR=$$ERR(772,IEN772,ERREA)
. W $S(ERR:" done...",1:"Aborted!! "_$P(ERR,U,2)_"...")
. S IEN773=0
. F S IEN773=$O(^HLMA("B",IEN772,IEN773)) Q:IEN773'>0 D
. . S ERR=$$ERR(773,IEN773,ERREA)
. . W !," - 773# ",IEN773," checked..."
Q
;
HDERR W @IOF,$$CJ^XLFSTR("Error Marking Utility",IOM)
W !,$$REPEAT^XLFSTR("=",IOM)
Q
;
ERR(FILE,IEN,ERREA) ; Change status to ERROR for 772 or 773 (if the P
; node status exists.)
;
N DATA,ERR,HLTCP
;
I FILE=772 D QUIT:ERR U_$P(ERR,U,2,99) ;->
. S ERR=""
. I $G(^HL(772,+$G(IEN),0))']"" S ERR="1^NO 772 0 NODE" QUIT ;->
;
I FILE=773 D QUIT:ERR U_$P(ERR,U,2,99) ;->
. S HLTCP=1 ; Used by STATUS^HLTF0
. S ERR=""
. I $G(^HLMA(+$G(IEN),0))']"" S ERR="1^NO 773 0 NODE" ;->
;
QUIT:$G(ERREA)']"" "^NO REASON" ;->
;
; Does entry need to be marked in error. (Only mark if status
; already exists)
S DATA=$S(FILE=772:$G(^HL(772,+IEN,"P")),1:$G(^HLMA(+IEN,"P")))
QUIT:$P(DATA,U)']"" 1 ;->
;
D STATUS^HLTF0(IEN,4,"",ERREA,1)
;
Q 1
;
EOR ;HLCSHDR6 - Make HL7 header for TCP ;1/27/03 15:30
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLCSHDR6 3348 printed Sep 23, 2025@19:32:43 Page 2
HLCSHDR6 ;OIRMFO/LJA - Make HL7 header for TCP ;1/27/03 15:30
+1 ;;1.6;HEALTH LEVEL SEVEN;**93**;Oct 13, 1995
+2 ;
MARKERRA ; Mark 772 & 773 entries in error (to stop messaging)...
+1 NEW %ZHO,ERR,ERREA,HLD,HLTCP,IEN772,IEN773,MSH,N02,POSX,X
+2 DO HDERR
+3 ;->
READ !!,"Enter ERROR REASON: ",ERREA:999
if '$TEST!(ERREA']"")!(ERREA[U)
QUIT
+4 FOR
Begin DoDot:1
+5 ;->
READ !!," 772: ",IEN772:9999
if IEN772'>0!('$TEST)
QUIT
+6 SET N02=$GET(^HL(772,+IEN772,0))
+7 WRITE !!,"772-0: "
+8 SET POSX=$X
+9 WRITE $EXTRACT(N02,1,IOM-POSX)
+10 SET X=$GET(^HL(772,+IEN772,"P"))
IF X]""
WRITE !,?(POSX-3),"P: ",$EXTRACT(X,1,IOM-POSX)
+11 KILL HLD
+12 if $DATA(^HLMA("B",+IEN772))
WRITE !!,"773s:",?POSX
+13 SET IEN773=0
+14 FOR
SET IEN773=$ORDER(^HLMA("B",+IEN772,IEN773))
if IEN773'>0
QUIT
Begin DoDot:2
+15 if $X>POSX
WRITE !
if $X<POSX
WRITE ?POSX
+16 SET HLD(IEN773)=""
+17 SET X=$GET(^HLMA(+IEN773,"P"))
IF X]""
WRITE " P: ",$EXTRACT(X,1,IOM-$X)
+18 if $X>POSX
WRITE !
if $X<POSX
WRITE ?POSX
+19 WRITE "MSH: "
+20 SET POSX=$X
+21 SET MSH=$GET(^HLMA(+IEN773,"MSH",1,0))
+22 FOR
Begin DoDot:3
+23 if $X>POSX
WRITE !
if $X<POSX
WRITE ?POSX
+24 WRITE $EXTRACT(MSH,1,IOM-POSX)
+25 SET MSH=$EXTRACT(MSH,IOM-POSX+1,999)
End DoDot:3
if MSH']""
QUIT
End DoDot:2
+26 ;->
READ !!,"Press RETURN to mark errored, or enter '^' to abort... ",X:999
IF '$TEST!(X]"")
Begin DoDot:2
+27 WRITE " no action taken..."
End DoDot:2
QUIT
+28 WRITE !!,?10,"Marking 772's #",IEN772," errored... "
+29 SET ERR=$$ERR(772,IEN772,ERREA)
+30 WRITE $SELECT(ERR:" done...",1:"Aborted!! "_$PIECE(ERR,U,2)_"...")
+31 ;->
IF '$DATA(HLD)
QUIT
+32 SET IEN773=0
+33 FOR
SET IEN773=$ORDER(HLD(IEN773))
if IEN773'>0
QUIT
Begin DoDot:2
+34 WRITE !,?10,"Marking 773's #",IEN773," errored... "
+35 SET ERR=$$ERR(773,IEN773,ERREA)
+36 WRITE $SELECT(ERR:" done...",1:"Aborted!! "_$PIECE(ERR,U,2)_"...")
End DoDot:2
End DoDot:1
if 'IEN772
QUIT
WRITE !!,$$REPEAT^XLFSTR("-",IOM)
+37 ;
+38 QUIT
+39 ;
MARKERRG ; Global-based error marking of 772, 773...
+1 NEW %ZHO,ERR,ERREA,HLD,HLTCP,IEN772,IEN773,MSH,N02,POSX,X
+2 DO HDERR
+3 ;->
READ !!,"Enter ERROR REASON: ",ERREA:999
if '$TEST!(ERREA']"")!(ERREA[U)
QUIT
+4 ;->
IF '$DATA(^TMP("HLCSHDR5 ERR",$JOB))
Begin DoDot:1
+5 WRITE !!,"No ^TMP(""HLCSHDR5 ERR"",$J) data exists..."
+6 WRITE !
End DoDot:1
QUIT
+7 WRITE !!,"The entries in ^TMP(""HLCSHDR5 ERR"",$J) will be marked in error now."
+8 ;->
READ !!,"Press RETURN to start error marking... ",X:999
if '$TEST!(X]"")
QUIT
+9 ;
ERRQ SET IEN772=0
+1 FOR
SET IEN772=$ORDER(^TMP("HLCSHDR5 ERR",$JOB,IEN772))
if IEN772'>0
QUIT
Begin DoDot:1
+2 WRITE !,"Marking 772's #",IEN772,"... "
+3 SET ERR=$$ERR(772,IEN772,ERREA)
+4 WRITE $SELECT(ERR:" done...",1:"Aborted!! "_$PIECE(ERR,U,2)_"...")
+5 SET IEN773=0
+6 FOR
SET IEN773=$ORDER(^HLMA("B",IEN772,IEN773))
if IEN773'>0
QUIT
Begin DoDot:2
+7 SET ERR=$$ERR(773,IEN773,ERREA)
+8 WRITE !," - 773# ",IEN773," checked..."
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
HDERR WRITE @IOF,$$CJ^XLFSTR("Error Marking Utility",IOM)
+1 WRITE !,$$REPEAT^XLFSTR("=",IOM)
+2 QUIT
+3 ;
ERR(FILE,IEN,ERREA) ; Change status to ERROR for 772 or 773 (if the P
+1 ; node status exists.)
+2 ;
+3 NEW DATA,ERR,HLTCP
+4 ;
+5 ;->
IF FILE=772
Begin DoDot:1
+6 SET ERR=""
+7 ;->
IF $GET(^HL(772,+$GET(IEN),0))']""
SET ERR="1^NO 772 0 NODE"
QUIT
End DoDot:1
if ERR
QUIT U_$PIECE(ERR,U,2,99)
+8 ;
+9 ;->
IF FILE=773
Begin DoDot:1
+10 ; Used by STATUS^HLTF0
SET HLTCP=1
+11 SET ERR=""
+12 ;->
IF $GET(^HLMA(+$GET(IEN),0))']""
SET ERR="1^NO 773 0 NODE"
End DoDot:1
if ERR
QUIT U_$PIECE(ERR,U,2,99)
+13 ;
+14 ;->
if $GET(ERREA)']""
QUIT "^NO REASON"
+15 ;
+16 ; Does entry need to be marked in error. (Only mark if status
+17 ; already exists)
+18 SET DATA=$SELECT(FILE=772:$GET(^HL(772,+IEN,"P")),1:$GET(^HLMA(+IEN,"P")))
+19 ;->
if $PIECE(DATA,U)']""
QUIT 1
+20 ;
+21 DO STATUS^HLTF0(IEN,4,"",ERREA,1)
+22 ;
+23 QUIT 1
+24 ;
EOR ;HLCSHDR6 - Make HL7 header for TCP ;1/27/03 15:30
