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

LRCAPFF.m

Go to the documentation of this file. 
  1. LRCAPFF ;DALOI/PDL - Lab Mapping Set Up Utility ;04/30/12  08:51
  1.  ;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230
  1.  ;
  1.  ; SetUp File 64 Mapping for MI,SP,CY, EM
  1.  ; Called from option [LRCAPFF]
  1.  Q
  1.  ;
  1. START ;
  1.  ; Main entry point that loops until user aborts
  1.  N LRSS,LRABORT
  1.  S LRABORT=0
  1.  F  D ASK(.LRSS,.LRABORT) Q:LRABORT
  1.  Q
  1.  ;
  1. ASK(LRSS,LRABORT) ;
  1.  ; Select #60 test, check associated file #64 field #63 record.
  1.  ; Inputs
  1.  ;     LRSS: <byref> Subscript area (MI,SP,CY) (See outputs)
  1.  ;  LRABORT: <byref> See outputs
  1.  ; Outputs
  1.  ;     LRSS: Initially set by ASK and passed back to START
  1.  ;         : Passed in to set the DIC("B") in ASK
  1.  ;  LRABORT: If user wants to abort LRABORT=1
  1.  ;
  1.  N DA,DIC,DIE,DIERR,DIR,DIRUT,DIROUT,DR,DTOUT,DUOUT
  1.  N ACTION,DATA,DBCERR,LRLCK1,LRLCK2,LRMSG,NLT,REC,X,Y
  1.  N R60,R63,R64,R64061,IEN,LRFDA,STOP,TEST,WKLD,WKLDCOD
  1.  S STOP=0
  1.  S DIR(0)="SO^MI:Microbiology;SP:Surgical Pathology;CY:Cytopathology;EM:Electron Microscopy"
  1.  S DIR("A")="Choose Lab Area Subscript"
  1.  I $G(LRSS)'="" S DIR("B")=LRSS
  1.  D ^DIR
  1.  I $D(DIRUT) S LRABORT=1 Q
  1.  S LRSS=Y
  1.  ; Get lab test
  1.  S R60=0
  1.  S DIC="^LAB(60,"
  1.  S DIC(0)="AEMNQ"
  1.  S DIC("A")="Enter Laboratory Test Name: "
  1.  S DIC("S")="I $P(^LAB(60,Y,0),""^"",4)=LRSS"
  1.  D ^DIC
  1.  K DIC
  1.  I $D(DUOUT) S LRABORT=1 Q
  1.  I $D(DTOUT)!(Y=-1) Q
  1.  I Y>0 S R60=+Y
  1.  I 'R60 Q
  1.  ; lock #60
  1.  S LRLCK1=$NA(^LAB(60,R60))
  1.  S X=$$GETLOCK^LRUTIL(LRLCK1,15)
  1.  I 'X D  Q  ;
  1.  . W !,"Could not lock file #60"
  1.  ;
  1.  ; Get National VA Lab Code (R64)
  1.  S R64=0
  1.  K DIE,DA,DR,Y
  1.  S DIE="^LAB(60,"
  1.  S DIE("NO^")="OUTOK"
  1.  S DA=R60
  1.  S DR="W !,""Editing LABORATORY TEST file (#60)"";64"
  1.  D ^DIE
  1.  I $D(DTOUT)!$D(Y) D  Q
  1.  . L -@LRLCK1
  1.  ;
  1.  S R64=$P($G(^LAB(60,R60,64)),U,1)
  1.  I 'R64 D  Q
  1.  . L -@LRLCK1
  1.  . W $C(7),!!,"  No National VA Lab Code associated with this test.",!
  1.  ;
  1.  S TEST=$P(^LAB(60,R60,0),U,1)
  1.  ; lock #64
  1.  S LRLCK2=$NA(^LAM(R64))
  1.  S X=$$GETLOCK^LRUTIL(LRLCK2,15)
  1.  I 'X D  Q  ;
  1.  . W !,"Could not lock file #64"
  1.  . L -@LRLCK1 ;unlock 63
  1.  ;
  1.  S DATA=^LAM(R64,0)
  1.  S WKLD=$P(DATA,U,1)
  1.  S WKLDCOD=$P(DATA,U,2)
  1.  W !,"60 = ",TEST,"  [",R60,"]"
  1.  W !,"64 = ",WKLD," (",WKLDCOD,")  [",R64,"]"
  1.  D  ;
  1.  . N END,LRDATA
  1.  . D LINK^LR7OU4(R60,R64,0)
  1.  . ;need to handle ^
  1.  . I $G(END) S STOP=1
  1.  ;
  1.  I STOP D  Q  ;
  1.  . L -@LRLCK2
  1.  . L -@LRLCK1
  1.  ;
  1.  ; Check LEC (#64.061) entry
  1.  S DBCERR=0 ;database code error
  1.  S DATA=$G(^LAM(R64,63))
  1.  S R64061=$P(DATA,U,1)
  1.  I 'R64061 D  ;
  1.  . W !!,?10,"No Database Code on file for this NLT code.",!
  1.  ;
  1.  I R64061 D  ;
  1.  . S DATA=^LAB(64.061,R64061,0)
  1.  . S X=$P(DATA,U,1)
  1.  . W !!!,?10,"Current Database Code for this NLT code is "
  1.  . W !,?15,X," [",R64061,"]"
  1.  . S Y="I X?1"""_LRSS_"""1.E1""Rpt Date"""
  1.  . X Y
  1.  . Q:$T
  1.  . S DBCERR=1
  1.  . W !!,$C(7),?7,"** Invalid Database Code for ",LRSS," **"
  1.  . W !,?10,WKLD," (",WKLDCOD,") needs to be corrected."
  1.  . W !
  1.  . K DIR,DIROUT,DIRUT
  1.  . S DIR("A")="Do you want to fix it now"
  1.  . S DIR(0)="Y"
  1.  . D ^DIR
  1.  . I $D(DIRUT)!(Y=0) S STOP=1
  1.  ;
  1.  I STOP D  Q  ;
  1.  . L -@LRLCK2
  1.  . L -@LRLCK1
  1.  ;
  1.  I R64061 I 'DBCERR D  ;
  1.  . K DIR,DIROUT,DIRUT
  1.  . S DIR("A")="Do you want to keep this mapping"
  1.  . S DIR(0)="Y"
  1.  . S DIR("B")="Y"
  1.  . W !
  1.  . D ^DIR
  1.  . I $D(DIRUT)!(Y=1) S STOP=1
  1.  ;
  1.  I STOP D  Q  ;
  1.  . L -@LRLCK2
  1.  . L -@LRLCK1
  1.  ;
  1.  K DIR
  1.  S ACTION=""
  1.  I R64061 D  ;
  1.  . S DIR(0)="SO^M:Map Database Code;U:Unmap this code"
  1.  . D ^DIR
  1.  . S ACTION=Y
  1.  ;
  1.  I $D(DIRUT) D  Q
  1.  . L -@LRLCK2
  1.  . L -@LRLCK1
  1.  ;
  1.  I 'R64061 S ACTION="M"
  1.  ;
  1.  I ACTION="M" F  D  Q:R64061!(ACTION=-1)  ;
  1.  . K DIC,REC
  1.  . S REC=0
  1.  . S DIC=64.061
  1.  . S DIC(0)="AEMNQ"
  1.  . S DIC("A")="Select an "_LRSS_" Database Code: "
  1.  . S DIC("S")="I $P(^(0),U,1)?1"""_LRSS_""".E1""Rpt Date"""
  1.  . D ^DIC
  1.  . K DIC
  1.  . I $D(DTOUT)!$D(DUOUT) S ACTION=-1 Q
  1.  . I Y'>0 I R64061 W "<no change>",! Q
  1.  . I Y>0 S REC=+Y
  1.  . I REC I REC'=R64061 D  Q  ;
  1.  . . K IEN,LRFDA,LRMSG,DIERR
  1.  . . S IEN=R64_","
  1.  . . S LRFDA(1,64,IEN,63)=REC
  1.  . . S R64061=REC
  1.  . . D FILE^DIE("","LRFDA(1)","LRMSG")
  1.  . . I '$D(LRMSG) W !!,"Update complete."
  1.  . ;
  1.  . I 'REC I 'R64061 D  ;
  1.  . . N DIR,DIROUT,DIRUT,DTOUT,DUOUT
  1.  . . W !!,?15,"An MI/AP Database Code must be selected"
  1.  . . W !,?15,"for this test to be used with LEDI results"
  1.  . . S DIR("A")="Sure you want to exit"
  1.  . . S DIR(0)="Y"
  1.  . . S DIR("B")="N"
  1.  . . D ^DIR
  1.  . . W !
  1.  . . I Y=1!$D(DIRUT) S ACTION=-1 Q
  1.  . ;
  1.  ;
  1.  I ACTION="U" D  ;
  1.  . K IEN,LRFDA,LRMSG,DIERR
  1.  . S IEN=R64_","
  1.  . S LRFDA(1,64,IEN,63)="@"
  1.  . D FILE^DIE("","LRFDA(1)","LRMSG")
  1.  . I '$D(LRMSG) W !,"      Mapping removed."
  1.  ;
  1.  L -@LRLCK2
  1.  L -@LRLCK1
  1.  ;
  1.  Q