LRACMOVE ;DALOI/JMC - MOVE MAJOR/MINOR HEADERS IN LAB REPORTS FILE (64.5);July 3, 2008
;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230
;
;
EN ; Move major and/or minor header to a new location
;
N DIC,DIR,DIROUT,DIRUT,DUOUT,LRCKW,LRIEN,LRMH,LRSH,LRTYPE,X,Y
;
I '$D(^XUSEC("LRLIASON",DUZ)) W $C(7),!,"You do not have access to this option" Q
;
L +^LAB(64.5,0):DILOCKTM
I '$T W !," This entry is being edited by someone else." Q
;
S DIR(0)="SO^1:Major Header;2:Minor Header"
S DIR("A")="Select type of header to move",DIR("B")=1,DIR("?")="Select the type of cumulative report header to move."
D ^DIR
I $D(DIRUT) D END Q
;
S LRTYPE=+Y
I LRTYPE=1 S LRMH=$$MAJOR
;
I LRTYPE=2 D
. S LRMH=$$MAJOR
. I LRMH<1 Q
. S LRSH=$$MINOR
;
I LRMH<1 D END Q
I LRTYPE=2,LRSH<1 D END Q
;
D MOVETO
I LRIEN<1 D END Q
I LRTYPE=2,LRIEN(1)<1 D END Q
;
; Move the major/minor header to it's new destination
D MOVE
;
; Reindex after move
D REINDEX
;
; Run diagnostics to check for any problems introduced
W !,"Run Diagnostic Report for LAB REPORTS File",!
S LRCKW=0 D QUE^LRACDIAG
;
D END
;
Q
;
;
MAJOR() ; Select a major header
;
N DIC
S DIC(0)="AEMQZ",DIC="^LAB(64.5,1,1,"
D ^DIC
;
Q Y
;
;
MINOR() ; Select minor header within a major header
;
N DIC
S DIC(0)="AEMQZ",DIC="^LAB(64.5,1,1,"_+LRMH_",1,"
D ^DIC
;
Q Y
;
;
MOVETO ; Move the header to the destination location.
;
N DA,DIC,DO,DINUM,DIR,DIROUT,DIRUT,DUOUT,LRMOVE,X
;
I LRTYPE=1 D
. S LRIEN=$$ADDIEN(LRTYPE)
. I LRIEN<1 Q
;
;
I LRTYPE=2 D
. S LRIEN=0
. S DIR(0)="SO^1:Within an existing major header;2:To a new major header"
. S DIR("A")="Move minor header",DIR("B")=1
. D ^DIR
. I $D(DIRUT) Q
. S LRMOVE=+Y
. I LRMOVE=1 S LRIEN=$$MAJOR
. I LRMOVE=2 S LRIEN=$$ADDIEN(1,"")
. I LRIEN<1 Q
. S LRIEN(1)=$$ADDIEN(LRTYPE,LRIEN)
;
Q
;
;
ADDIEN(LRTYPE,LRIEN) ; Create new header
;
N DA,DIC,DO,DINUM,LRDA,LRX,X,Y
;
S DIC(0)="EZ",X="NEW HEADER"
I LRTYPE=1 D
. S DA(1)=1
. S DIC="^LAB(64.5,1,1,",DIC("DR")=".01;5"
. I $P(^LAB(64.5,1,1,+LRMH,0),"^",2)'="" S DIC("DR")=DIC("DR")_"//"_$P(^LAB(64.5,1,1,+LRMH,0),"^",2)
;
I LRTYPE=2 D
. S LRX=^LAB(64.5,1,1,+LRMH,1,+LRSH,0)
. S DA(2)=1,DA(1)=+LRIEN
. S DIC="^LAB(64.5,1,1,"_+LRIEN_",1,",DIC("DR")=".01;1////"_$P(LRX,"^",2)_";2////"_$P(LRX,"^",3)_";3////"_$P(LRX,"^",4)
;
D FILE^DICN
I Y>0 S LRDA=+Y_"^"_Y(0,0)
E S LRDA=Y
;
Q LRDA
;
;
MOVE ; Move the entry to the new location, re-index the new entry and delete the old entry
;
N DA,DIK
;
W !!,"Copying ",$S(LRTYPE=1:"major",1:"minor")," header: ",$S(LRTYPE=1:$P(LRMH,"^",2),1:$P(LRSH,"^",2))
W !," to ",$S(LRTYPE=1:"major",1:"minor")," header: ",$S(LRTYPE=1:$P(LRIEN,"^",2),1:$P(LRIEN(1),"^",2)),!
I LRTYPE=2 W " in the major header: ",$P(LRIEN,"^",2),!
;
I LRTYPE=1 D
. M ^LAB(64.5,1,1,+LRIEN,1)=^LAB(64.5,1,1,+LRMH,1)
. S DA=+LRIEN,DA(1)=1,DIK="^LAB(64.5,1,1,"
;
I LRTYPE=2 D
. M ^LAB(64.5,1,1,+LRIEN,1,+LRIEN(1),1)=^LAB(64.5,1,1,+LRMH,1,+LRSH,1)
. S DA=+LRIEN(1),DA(1)=+LRIEN,DA(2)=1,DIK="LAB(64.5,1,1,"_+LRIEN_",1,"
;
; Re-index the new entry
W !,"Re-indexing new ",$S(LRTYPE=1:"major",1:"minor")," header: ",$S(LRTYPE=1:$P(LRIEN,"^",2),1:$P(LRIEN(1),"^",2)),!
D IX1^DIK
;
; Delete the old entry
W !,"Deleting ",$S(LRTYPE=1:"major",1:"minor")," header: ",$S(LRTYPE=1:$P(LRMH,"^",2),1:$P(LRSH,"^",2)),!
K DA,DIK
S DA=$S(LRTYPE=1:+LRMH,1:+LRSH)
S DIK="^LAB(64.5,1,1,",DA(1)=1
I LRTYPE=2 S DIK=DIK_+LRMH_",1,",DA(1)=+LRMH,DA(2)=1
D ^DIK
;
Q
;
;
REINDEX ; Reindex headers after they have been moved.
N I,LR
S LR(1)=1,LR(2)=1,LR(3)=1
F I="A","AC","AR" K ^LAB(64.5,I)
;
W !!,"Re-indexing the LAB REPORTS file for:"
W !,"Mumps ""A"" index of the LAB TEST subfield",!?4,"(contains reference ranges, units, etc. from file 60)"
W !,"Mumps ""AC"" index of the LAB TEST LOCATION subfield",!?4,"(atomic test x-ref.)"
W !,"Mumps ""AR"" index of the LAB TEST subfield",!?4,"(site/specimen x-ref.)"
;
D MAJ^LRACDIAG
Q
;
;
END ; Release lock
L -^LAB(64.5,0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRACMOVE 4177 printed Nov 22, 2024@17:16:34 Page 2
LRACMOVE ;DALOI/JMC - MOVE MAJOR/MINOR HEADERS IN LAB REPORTS FILE (64.5);July 3, 2008
+1 ;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230
+2 ;
+3 ;
EN ; Move major and/or minor header to a new location
+1 ;
+2 NEW DIC,DIR,DIROUT,DIRUT,DUOUT,LRCKW,LRIEN,LRMH,LRSH,LRTYPE,X,Y
+3 ;
+4 IF '$DATA(^XUSEC("LRLIASON",DUZ))
WRITE $CHAR(7),!,"You do not have access to this option"
QUIT
+5 ;
+6 LOCK +^LAB(64.5,0):DILOCKTM
+7 IF '$TEST
WRITE !," This entry is being edited by someone else."
QUIT
+8 ;
+9 SET DIR(0)="SO^1:Major Header;2:Minor Header"
+10 SET DIR("A")="Select type of header to move"
SET DIR("B")=1
SET DIR("?")="Select the type of cumulative report header to move."
+11 DO ^DIR
+12 IF $DATA(DIRUT)
DO END
QUIT
+13 ;
+14 SET LRTYPE=+Y
+15 IF LRTYPE=1
SET LRMH=$$MAJOR
+16 ;
+17 IF LRTYPE=2
Begin DoDot:1
+18 SET LRMH=$$MAJOR
+19 IF LRMH<1
QUIT
+20 SET LRSH=$$MINOR
End DoDot:1
+21 ;
+22 IF LRMH<1
DO END
QUIT
+23 IF LRTYPE=2
IF LRSH<1
DO END
QUIT
+24 ;
+25 DO MOVETO
+26 IF LRIEN<1
DO END
QUIT
+27 IF LRTYPE=2
IF LRIEN(1)<1
DO END
QUIT
+28 ;
+29 ; Move the major/minor header to it's new destination
+30 DO MOVE
+31 ;
+32 ; Reindex after move
+33 DO REINDEX
+34 ;
+35 ; Run diagnostics to check for any problems introduced
+36 WRITE !,"Run Diagnostic Report for LAB REPORTS File",!
+37 SET LRCKW=0
DO QUE^LRACDIAG
+38 ;
+39 DO END
+40 ;
+41 QUIT
+42 ;
+43 ;
MAJOR() ; Select a major header
+1 ;
+2 NEW DIC
+3 SET DIC(0)="AEMQZ"
SET DIC="^LAB(64.5,1,1,"
+4 DO ^DIC
+5 ;
+6 QUIT Y
+7 ;
+8 ;
MINOR() ; Select minor header within a major header
+1 ;
+2 NEW DIC
+3 SET DIC(0)="AEMQZ"
SET DIC="^LAB(64.5,1,1,"_+LRMH_",1,"
+4 DO ^DIC
+5 ;
+6 QUIT Y
+7 ;
+8 ;
MOVETO ; Move the header to the destination location.
+1 ;
+2 NEW DA,DIC,DO,DINUM,DIR,DIROUT,DIRUT,DUOUT,LRMOVE,X
+3 ;
+4 IF LRTYPE=1
Begin DoDot:1
+5 SET LRIEN=$$ADDIEN(LRTYPE)
+6 IF LRIEN<1
QUIT
End DoDot:1
+7 ;
+8 ;
+9 IF LRTYPE=2
Begin DoDot:1
+10 SET LRIEN=0
+11 SET DIR(0)="SO^1:Within an existing major header;2:To a new major header"
+12 SET DIR("A")="Move minor header"
SET DIR("B")=1
+13 DO ^DIR
+14 IF $DATA(DIRUT)
QUIT
+15 SET LRMOVE=+Y
+16 IF LRMOVE=1
SET LRIEN=$$MAJOR
+17 IF LRMOVE=2
SET LRIEN=$$ADDIEN(1,"")
+18 IF LRIEN<1
QUIT
+19 SET LRIEN(1)=$$ADDIEN(LRTYPE,LRIEN)
End DoDot:1
+20 ;
+21 QUIT
+22 ;
+23 ;
ADDIEN(LRTYPE,LRIEN) ; Create new header
+1 ;
+2 NEW DA,DIC,DO,DINUM,LRDA,LRX,X,Y
+3 ;
+4 SET DIC(0)="EZ"
SET X="NEW HEADER"
+5 IF LRTYPE=1
Begin DoDot:1
+6 SET DA(1)=1
+7 SET DIC="^LAB(64.5,1,1,"
SET DIC("DR")=".01;5"
+8 IF $PIECE(^LAB(64.5,1,1,+LRMH,0),"^",2)'=""
SET DIC("DR")=DIC("DR")_"//"_$PIECE(^LAB(64.5,1,1,+LRMH,0),"^",2)
End DoDot:1
+9 ;
+10 IF LRTYPE=2
Begin DoDot:1
+11 SET LRX=^LAB(64.5,1,1,+LRMH,1,+LRSH,0)
+12 SET DA(2)=1
SET DA(1)=+LRIEN
+13 SET DIC="^LAB(64.5,1,1,"_+LRIEN_",1,"
SET DIC("DR")=".01;1////"_$PIECE(LRX,"^",2)_";2////"_$PIECE(LRX,"^",3)_";3////"_$PIECE(LRX,"^",4)
End DoDot:1
+14 ;
+15 DO FILE^DICN
+16 IF Y>0
SET LRDA=+Y_"^"_Y(0,0)
+17 IF '$TEST
SET LRDA=Y
+18 ;
+19 QUIT LRDA
+20 ;
+21 ;
MOVE ; Move the entry to the new location, re-index the new entry and delete the old entry
+1 ;
+2 NEW DA,DIK
+3 ;
+4 WRITE !!,"Copying ",$SELECT(LRTYPE=1:"major",1:"minor")," header: ",$SELECT(LRTYPE=1:$PIECE(LRMH,"^",2),1:$PIECE(LRSH,"^",2))
+5 WRITE !," to ",$SELECT(LRTYPE=1:"major",1:"minor")," header: ",$SELECT(LRTYPE=1:$PIECE(LRIEN,"^",2),1:$PIECE(LRIEN(1),"^",2)),!
+6 IF LRTYPE=2
WRITE " in the major header: ",$PIECE(LRIEN,"^",2),!
+7 ;
+8 IF LRTYPE=1
Begin DoDot:1
+9 MERGE ^LAB(64.5,1,1,+LRIEN,1)=^LAB(64.5,1,1,+LRMH,1)
+10 SET DA=+LRIEN
SET DA(1)=1
SET DIK="^LAB(64.5,1,1,"
End DoDot:1
+11 ;
+12 IF LRTYPE=2
Begin DoDot:1
+13 MERGE ^LAB(64.5,1,1,+LRIEN,1,+LRIEN(1),1)=^LAB(64.5,1,1,+LRMH,1,+LRSH,1)
+14 SET DA=+LRIEN(1)
SET DA(1)=+LRIEN
SET DA(2)=1
SET DIK="LAB(64.5,1,1,"_+LRIEN_",1,"
End DoDot:1
+15 ;
+16 ; Re-index the new entry
+17 WRITE !,"Re-indexing new ",$SELECT(LRTYPE=1:"major",1:"minor")," header: ",$SELECT(LRTYPE=1:$PIECE(LRIEN,"^",2),1:$PIECE(LRIEN(1),"^",2)),!
+18 DO IX1^DIK
+19 ;
+20 ; Delete the old entry
+21 WRITE !,"Deleting ",$SELECT(LRTYPE=1:"major",1:"minor")," header: ",$SELECT(LRTYPE=1:$PIECE(LRMH,"^",2),1:$PIECE(LRSH,"^",2)),!
+22 KILL DA,DIK
+23 SET DA=$SELECT(LRTYPE=1:+LRMH,1:+LRSH)
+24 SET DIK="^LAB(64.5,1,1,"
SET DA(1)=1
+25 IF LRTYPE=2
SET DIK=DIK_+LRMH_",1,"
SET DA(1)=+LRMH
SET DA(2)=1
+26 DO ^DIK
+27 ;
+28 QUIT
+29 ;
+30 ;
REINDEX ; Reindex headers after they have been moved.
+1 NEW I,LR
+2 SET LR(1)=1
SET LR(2)=1
SET LR(3)=1
+3 FOR I="A","AC","AR"
KILL ^LAB(64.5,I)
+4 ;
+5 WRITE !!,"Re-indexing the LAB REPORTS file for:"
+6 WRITE !,"Mumps ""A"" index of the LAB TEST subfield",!?4,"(contains reference ranges, units, etc. from file 60)"
+7 WRITE !,"Mumps ""AC"" index of the LAB TEST LOCATION subfield",!?4,"(atomic test x-ref.)"
+8 WRITE !,"Mumps ""AR"" index of the LAB TEST subfield",!?4,"(site/specimen x-ref.)"
+9 ;
+10 DO MAJ^LRACDIAG
+11 QUIT
+12 ;
+13 ;
END ; Release lock
+1 LOCK -^LAB(64.5,0)
+2 QUIT
