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

LRACMOVE.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ;
  1. EN ; Move major and/or minor header to a new location
  1.  ;
  1.  N DIC,DIR,DIROUT,DIRUT,DUOUT,LRCKW,LRIEN,LRMH,LRSH,LRTYPE,X,Y
  1.  ;
  1.  I '$D(^XUSEC("LRLIASON",DUZ)) W $C(7),!,"You do not have access to this option" Q
  1.  ;
  1.  L +^LAB(64.5,0):DILOCKTM
  1.  I '$T W !," This entry is being edited by someone else." Q
  1.  ;
  1.  S DIR(0)="SO^1:Major Header;2:Minor Header"
  1.  S DIR("A")="Select type of header to move",DIR("B")=1,DIR("?")="Select the type of cumulative report header to move."
  1.  D ^DIR
  1.  I $D(DIRUT) D END Q
  1.  ;
  1.  S LRTYPE=+Y
  1.  I LRTYPE=1 S LRMH=$$MAJOR
  1.  ;
  1.  I LRTYPE=2 D
  1.  . S LRMH=$$MAJOR
  1.  . I LRMH<1 Q
  1.  . S LRSH=$$MINOR
  1.  ;
  1.  I LRMH<1 D END Q
  1.  I LRTYPE=2,LRSH<1 D END Q
  1.  ;
  1.  D MOVETO
  1.  I LRIEN<1 D END Q
  1.  I LRTYPE=2,LRIEN(1)<1 D END Q
  1.  ;
  1.  ; Move the major/minor header to it's new destination
  1.  D MOVE
  1.  ;
  1.  ; Reindex after move
  1.  D REINDEX
  1.  ;
  1.  ; Run diagnostics to check for any problems introduced
  1.  W !,"Run Diagnostic Report for LAB REPORTS File",!
  1.  S LRCKW=0 D QUE^LRACDIAG
  1.  ;
  1.  D END
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. MAJOR() ; Select a major header
  1.  ;
  1.  N DIC
  1.  S DIC(0)="AEMQZ",DIC="^LAB(64.5,1,1,"
  1.  D ^DIC
  1.  ;
  1.  Q Y
  1.  ;
  1.  ;
  1. MINOR() ; Select minor header within a major header
  1.  ;
  1.  N DIC
  1.  S DIC(0)="AEMQZ",DIC="^LAB(64.5,1,1,"_+LRMH_",1,"
  1.  D ^DIC
  1.  ;
  1.  Q Y
  1.  ;
  1.  ;
  1. MOVETO ; Move the header to the destination location.
  1.  ;
  1.  N DA,DIC,DO,DINUM,DIR,DIROUT,DIRUT,DUOUT,LRMOVE,X
  1.  ;
  1.  I LRTYPE=1 D
  1.  . S LRIEN=$$ADDIEN(LRTYPE)
  1.  . I LRIEN<1 Q
  1.  ;
  1.  ;
  1.  I LRTYPE=2 D
  1.  . S LRIEN=0
  1.  . S DIR(0)="SO^1:Within an existing major header;2:To a new major header"
  1.  . S DIR("A")="Move minor header",DIR("B")=1
  1.  . D ^DIR
  1.  . I $D(DIRUT) Q
  1.  . S LRMOVE=+Y
  1.  . I LRMOVE=1 S LRIEN=$$MAJOR
  1.  . I LRMOVE=2 S LRIEN=$$ADDIEN(1,"")
  1.  . I LRIEN<1 Q
  1.  . S LRIEN(1)=$$ADDIEN(LRTYPE,LRIEN)
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. ADDIEN(LRTYPE,LRIEN) ; Create new header
  1.  ;
  1.  N DA,DIC,DO,DINUM,LRDA,LRX,X,Y
  1.  ;
  1.  S DIC(0)="EZ",X="NEW HEADER"
  1.  I LRTYPE=1 D
  1.  . S DA(1)=1
  1.  . S DIC="^LAB(64.5,1,1,",DIC("DR")=".01;5"
  1.  . I $P(^LAB(64.5,1,1,+LRMH,0),"^",2)'="" S DIC("DR")=DIC("DR")_"//"_$P(^LAB(64.5,1,1,+LRMH,0),"^",2)
  1.  ;
  1.  I LRTYPE=2 D
  1.  . S LRX=^LAB(64.5,1,1,+LRMH,1,+LRSH,0)
  1.  . S DA(2)=1,DA(1)=+LRIEN
  1.  . S DIC="^LAB(64.5,1,1,"_+LRIEN_",1,",DIC("DR")=".01;1////"_$P(LRX,"^",2)_";2////"_$P(LRX,"^",3)_";3////"_$P(LRX,"^",4)
  1.  ;
  1.  D FILE^DICN
  1.  I Y>0 S LRDA=+Y_"^"_Y(0,0)
  1.  E  S LRDA=Y
  1.  ;
  1.  Q LRDA
  1.  ;
  1.  ;
  1. MOVE ; Move the entry to the new location, re-index the new entry and delete the old entry
  1.  ;
  1.  N DA,DIK
  1.  ;
  1.  W !!,"Copying ",$S(LRTYPE=1:"major",1:"minor")," header: ",$S(LRTYPE=1:$P(LRMH,"^",2),1:$P(LRSH,"^",2))
  1.  W !," to ",$S(LRTYPE=1:"major",1:"minor")," header: ",$S(LRTYPE=1:$P(LRIEN,"^",2),1:$P(LRIEN(1),"^",2)),!
  1.  I LRTYPE=2 W "  in the major header: ",$P(LRIEN,"^",2),!
  1.  ;
  1.  I LRTYPE=1 D
  1.  . M ^LAB(64.5,1,1,+LRIEN,1)=^LAB(64.5,1,1,+LRMH,1)
  1.  . S DA=+LRIEN,DA(1)=1,DIK="^LAB(64.5,1,1,"
  1.  ;
  1.  I LRTYPE=2 D
  1.  . M ^LAB(64.5,1,1,+LRIEN,1,+LRIEN(1),1)=^LAB(64.5,1,1,+LRMH,1,+LRSH,1)
  1.  . S DA=+LRIEN(1),DA(1)=+LRIEN,DA(2)=1,DIK="LAB(64.5,1,1,"_+LRIEN_",1,"
  1.  ;
  1.  ; Re-index the new entry
  1.  W !,"Re-indexing new ",$S(LRTYPE=1:"major",1:"minor")," header: ",$S(LRTYPE=1:$P(LRIEN,"^",2),1:$P(LRIEN(1),"^",2)),!
  1.  D IX1^DIK
  1.  ;
  1.  ; Delete the old entry
  1.  W !,"Deleting ",$S(LRTYPE=1:"major",1:"minor")," header: ",$S(LRTYPE=1:$P(LRMH,"^",2),1:$P(LRSH,"^",2)),!
  1.  K DA,DIK
  1.  S DA=$S(LRTYPE=1:+LRMH,1:+LRSH)
  1.  S DIK="^LAB(64.5,1,1,",DA(1)=1
  1.  I LRTYPE=2 S DIK=DIK_+LRMH_",1,",DA(1)=+LRMH,DA(2)=1
  1.  D ^DIK
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. REINDEX ; Reindex headers after they have been moved.
  1.  N I,LR
  1.  S LR(1)=1,LR(2)=1,LR(3)=1
  1.  F I="A","AC","AR" K ^LAB(64.5,I)
  1.  ;
  1.  W !!,"Re-indexing the LAB REPORTS file for:"
  1.  W !,"Mumps ""A"" index of the LAB TEST subfield",!?4,"(contains reference ranges, units, etc. from file 60)"
  1.  W !,"Mumps ""AC"" index of the LAB TEST LOCATION subfield",!?4,"(atomic test x-ref.)"
  1.  W !,"Mumps ""AR"" index of the LAB TEST subfield",!?4,"(site/specimen x-ref.)"
  1.  ;
  1.  D MAJ^LRACDIAG
  1.  Q
  1.  ;
  1.  ;
  1. END ; Release lock
  1.  L -^LAB(64.5,0)
  1.  Q