- 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
