LRAR02 ; IHS/DIR/AAB - COMPARE MAJOR HEADERS 062096 12/12/96 10:16 ; [ 07/22/2002 1:05 PM ]
;;5.2;LR;**1002,1013**;JUL 15, 2002
;;5.2;LAB SERVICE;**111**;Sep 27, 1994
INIT ;
;
;
;----------------------------------------------------------------------
;------Here is where we check the major header and force to perm.
;
CHECKX S LRMH=$P($P(LRDAT,U,9),":") ;Major Header
S LRFG=$P($P(LRDAT,U,9),":",2) ;PAGE
;
; Checking all the test for different major header
;
;
S TEST=.5
F S TEST=$O(^LR(LRDFN,"CH",LRIDT,TEST)) Q:+TEST'>0 D
. Q:$D(^TMP("LRT2",TEST))#2
. D SET
;--------------------------------------------------------------------
;
;
Q
;
;
SET ;
;
;W !!,"I'VE CROSSED OVER......."
S LRT1="^LAB(64.5,1,1)"
F S LRT1=$Q(@LRT1) Q:+$P(LRT1,",",2)'>0 D
. I $P(@LRT1,";",2)=TEST S LRMHX=$P(LRT1,",",4) Q:'LRMHX D
.. ;W !,"TEST=",TEST," ",$P(LRT1,",",4),"<---64.5 ^LR--->",LRMH R VVVV
.. I LRMH'=LRMHX D MORE
Q
;
MORE ;
;S LRIDT=0
S:'$D(^TMP("LRT2",TEST))#2 ^(TEST)=""
;F S LRIDT=$O(^LRO(68,"AC",LRDFN,LRIDT)) Q:LRIDT<1 D
;-----------------------------------------------------------------
I $E(IOST,1,2)="C-" D
. ;W !!,"Found a diferent major header. I will increment page now."
;
;
;
S ^LAR("DHZ",LRDFN,LRIDT,$P(^DD(63.04,TEST,0),U))=PNM_U_LRMH_U_LRMHX_U_(9999999-LRIDT)
;
I '$D(^LR(LRDFN,"PG",LRMHX)) S ^LR(LRDFN,"PG",LRMHX)=LRMHX_U_1
E S $P(^LR(LRDFN,"PG",LRMHX),U,2)=$P(^(LRMHX),U,2)+1
S LRPG5=$P(^LR(LRDFN,"CH",LRIDT,0),U,9) I '$D(LRPG5) D QUIT
. S LRPG5=$P(^LR(LRDFN,"PG",LRMHX),U)
. S LRPG5=LRPG5_":"_$P(^LR(LRDFN,"PG",LRMHX),U,2) K LRPG5
I $D(LRPG5) S $P(^LR(LRDFN,"CH",LRIDT,0),U,9)=$P($P(^(0),U,9),":",2)+1
;
;
Q
LRAR02 ; IHS/DIR/AAB - COMPARE MAJOR HEADERS 062096 12/12/96 10:16 ; [ 07/22/2002 1:05 PM ]
+1 ;;5.2;LR;**1002,1013**;JUL 15, 2002
+2 ;;5.2;LAB SERVICE;**111**;Sep 27, 1994
INIT ;
+1 ;
+2 ;
+3 ;----------------------------------------------------------------------
+4 ;------Here is where we check the major header and force to perm.
+5 ;
CHECKX ;Major Header
SET LRMH=$PIECE($PIECE(LRDAT,U,9),":")
+1 ;PAGE
SET LRFG=$PIECE($PIECE(LRDAT,U,9),":",2)
+2 ;
+3 ; Checking all the test for different major header
+4 ;
+5 ;
+6 SET TEST=.5
+7 FOR
SET TEST=$ORDER(^LR(LRDFN,"CH",LRIDT,TEST))
IF +TEST'>0
QUIT
Begin DoDot:1
+8 IF $DATA(^TMP("LRT2",TEST))#2
QUIT
+9 DO SET
End DoDot:1
+10 ;--------------------------------------------------------------------
+11 ;
+12 ;
+13 QUIT
+14 ;
+15 ;
SET ;
+1 ;
+2 ;W !!,"I'VE CROSSED OVER......."
+3 SET LRT1="^LAB(64.5,1,1)"
+4 FOR
SET LRT1=$QUERY(@LRT1)
IF +$PIECE(LRT1,",",2)'>0
QUIT
Begin DoDot:1
+5 IF $PIECE(@LRT1,";",2)=TEST
SET LRMHX=$PIECE(LRT1,",",4)
IF 'LRMHX
QUIT
Begin DoDot:2
+6 ;W !,"TEST=",TEST," ",$P(LRT1,",",4),"<---64.5 ^LR--->",LRMH R VVVV
+7 IF LRMH'=LRMHX
DO MORE
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
MORE ;
+1 ;S LRIDT=0
+2 IF '$DATA(^TMP("LRT2",TEST))#2
SET ^(TEST)=""
+3 ;F S LRIDT=$O(^LRO(68,"AC",LRDFN,LRIDT)) Q:LRIDT<1 D
+4 ;-----------------------------------------------------------------
+5 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+6 ;W !!,"Found a diferent major header. I will increment page now."
End DoDot:1
+7 ;
+8 ;
+9 ;
+10 SET ^LAR("DHZ",LRDFN,LRIDT,$PIECE(^DD(63.04,TEST,0),U))=PNM_U_LRMH_U_LRMHX_U_(9999999-LRIDT)
+11 ;
+12 IF '$DATA(^LR(LRDFN,"PG",LRMHX))
SET ^LR(LRDFN,"PG",LRMHX)=LRMHX_U_1
+13 IF '$TEST
SET $PIECE(^LR(LRDFN,"PG",LRMHX),U,2)=$PIECE(^(LRMHX),U,2)+1
+14 SET LRPG5=$PIECE(^LR(LRDFN,"CH",LRIDT,0),U,9)
IF '$DATA(LRPG5)
Begin DoDot:1
+15 SET LRPG5=$PIECE(^LR(LRDFN,"PG",LRMHX),U)
+16 SET LRPG5=LRPG5_":"_$PIECE(^LR(LRDFN,"PG",LRMHX),U,2)
KILL LRPG5
End DoDot:1
QUIT
+17 IF $DATA(LRPG5)
SET $PIECE(^LR(LRDFN,"CH",LRIDT,0),U,9)=$PIECE($PIECE(^(0),U,9),":",2)+1
+18 ;
+19 ;
+20 QUIT
