LRCAPFF ;DALOI/PDL - Lab Mapping Set Up Utility ;04/30/12 08:51
;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230
;
; SetUp File 64 Mapping for MI,SP,CY, EM
; Called from option [LRCAPFF]
Q
;
START ;
; Main entry point that loops until user aborts
N LRSS,LRABORT
S LRABORT=0
F D ASK(.LRSS,.LRABORT) Q:LRABORT
Q
;
ASK(LRSS,LRABORT) ;
; Select #60 test, check associated file #64 field #63 record.
; Inputs
; LRSS: <byref> Subscript area (MI,SP,CY) (See outputs)
; LRABORT: <byref> See outputs
; Outputs
; LRSS: Initially set by ASK and passed back to START
; : Passed in to set the DIC("B") in ASK
; LRABORT: If user wants to abort LRABORT=1
;
N DA,DIC,DIE,DIERR,DIR,DIRUT,DIROUT,DR,DTOUT,DUOUT
N ACTION,DATA,DBCERR,LRLCK1,LRLCK2,LRMSG,NLT,REC,X,Y
N R60,R63,R64,R64061,IEN,LRFDA,STOP,TEST,WKLD,WKLDCOD
S STOP=0
S DIR(0)="SO^MI:Microbiology;SP:Surgical Pathology;CY:Cytopathology;EM:Electron Microscopy"
S DIR("A")="Choose Lab Area Subscript"
I $G(LRSS)'="" S DIR("B")=LRSS
D ^DIR
I $D(DIRUT) S LRABORT=1 Q
S LRSS=Y
; Get lab test
S R60=0
S DIC="^LAB(60,"
S DIC(0)="AEMNQ"
S DIC("A")="Enter Laboratory Test Name: "
S DIC("S")="I $P(^LAB(60,Y,0),""^"",4)=LRSS"
D ^DIC
K DIC
I $D(DUOUT) S LRABORT=1 Q
I $D(DTOUT)!(Y=-1) Q
I Y>0 S R60=+Y
I 'R60 Q
; lock #60
S LRLCK1=$NA(^LAB(60,R60))
S X=$$GETLOCK^LRUTIL(LRLCK1,15)
I 'X D Q ;
. W !,"Could not lock file #60"
;
; Get National VA Lab Code (R64)
S R64=0
K DIE,DA,DR,Y
S DIE="^LAB(60,"
S DIE("NO^")="OUTOK"
S DA=R60
S DR="W !,""Editing LABORATORY TEST file (#60)"";64"
D ^DIE
I $D(DTOUT)!$D(Y) D Q
. L -@LRLCK1
;
S R64=$P($G(^LAB(60,R60,64)),U,1)
I 'R64 D Q
. L -@LRLCK1
. W $C(7),!!," No National VA Lab Code associated with this test.",!
;
S TEST=$P(^LAB(60,R60,0),U,1)
; lock #64
S LRLCK2=$NA(^LAM(R64))
S X=$$GETLOCK^LRUTIL(LRLCK2,15)
I 'X D Q ;
. W !,"Could not lock file #64"
. L -@LRLCK1 ;unlock 63
;
S DATA=^LAM(R64,0)
S WKLD=$P(DATA,U,1)
S WKLDCOD=$P(DATA,U,2)
W !,"60 = ",TEST," [",R60,"]"
W !,"64 = ",WKLD," (",WKLDCOD,") [",R64,"]"
D ;
. N END,LRDATA
. D LINK^LR7OU4(R60,R64,0)
. ;need to handle ^
. I $G(END) S STOP=1
;
I STOP D Q ;
. L -@LRLCK2
. L -@LRLCK1
;
; Check LEC (#64.061) entry
S DBCERR=0 ;database code error
S DATA=$G(^LAM(R64,63))
S R64061=$P(DATA,U,1)
I 'R64061 D ;
. W !!,?10,"No Database Code on file for this NLT code.",!
;
I R64061 D ;
. S DATA=^LAB(64.061,R64061,0)
. S X=$P(DATA,U,1)
. W !!!,?10,"Current Database Code for this NLT code is "
. W !,?15,X," [",R64061,"]"
. S Y="I X?1"""_LRSS_"""1.E1""Rpt Date"""
. X Y
. Q:$T
. S DBCERR=1
. W !!,$C(7),?7,"** Invalid Database Code for ",LRSS," **"
. W !,?10,WKLD," (",WKLDCOD,") needs to be corrected."
. W !
. K DIR,DIROUT,DIRUT
. S DIR("A")="Do you want to fix it now"
. S DIR(0)="Y"
. D ^DIR
. I $D(DIRUT)!(Y=0) S STOP=1
;
I STOP D Q ;
. L -@LRLCK2
. L -@LRLCK1
;
I R64061 I 'DBCERR D ;
. K DIR,DIROUT,DIRUT
. S DIR("A")="Do you want to keep this mapping"
. S DIR(0)="Y"
. S DIR("B")="Y"
. W !
. D ^DIR
. I $D(DIRUT)!(Y=1) S STOP=1
;
I STOP D Q ;
. L -@LRLCK2
. L -@LRLCK1
;
K DIR
S ACTION=""
I R64061 D ;
. S DIR(0)="SO^M:Map Database Code;U:Unmap this code"
. D ^DIR
. S ACTION=Y
;
I $D(DIRUT) D Q
. L -@LRLCK2
. L -@LRLCK1
;
I 'R64061 S ACTION="M"
;
I ACTION="M" F D Q:R64061!(ACTION=-1) ;
. K DIC,REC
. S REC=0
. S DIC=64.061
. S DIC(0)="AEMNQ"
. S DIC("A")="Select an "_LRSS_" Database Code: "
. S DIC("S")="I $P(^(0),U,1)?1"""_LRSS_""".E1""Rpt Date"""
. D ^DIC
. K DIC
. I $D(DTOUT)!$D(DUOUT) S ACTION=-1 Q
. I Y'>0 I R64061 W "<no change>",! Q
. I Y>0 S REC=+Y
. I REC I REC'=R64061 D Q ;
. . K IEN,LRFDA,LRMSG,DIERR
. . S IEN=R64_","
. . S LRFDA(1,64,IEN,63)=REC
. . S R64061=REC
. . D FILE^DIE("","LRFDA(1)","LRMSG")
. . I '$D(LRMSG) W !!,"Update complete."
. ;
. I 'REC I 'R64061 D ;
. . N DIR,DIROUT,DIRUT,DTOUT,DUOUT
. . W !!,?15,"An MI/AP Database Code must be selected"
. . W !,?15,"for this test to be used with LEDI results"
. . S DIR("A")="Sure you want to exit"
. . S DIR(0)="Y"
. . S DIR("B")="N"
. . D ^DIR
. . W !
. . I Y=1!$D(DIRUT) S ACTION=-1 Q
. ;
;
I ACTION="U" D ;
. K IEN,LRFDA,LRMSG,DIERR
. S IEN=R64_","
. S LRFDA(1,64,IEN,63)="@"
. D FILE^DIE("","LRFDA(1)","LRMSG")
. I '$D(LRMSG) W !," Mapping removed."
;
L -@LRLCK2
L -@LRLCK1
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCAPFF 4620 printed Oct 16, 2024@18:13:43 Page 2
LRCAPFF ;DALOI/PDL - Lab Mapping Set Up Utility ;04/30/12 08:51
+1 ;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230
+2 ;
+3 ; SetUp File 64 Mapping for MI,SP,CY, EM
+4 ; Called from option [LRCAPFF]
+5 QUIT
+6 ;
START ;
+1 ; Main entry point that loops until user aborts
+2 NEW LRSS,LRABORT
+3 SET LRABORT=0
+4 FOR
DO ASK(.LRSS,.LRABORT)
if LRABORT
QUIT
+5 QUIT
+6 ;
ASK(LRSS,LRABORT) ;
+1 ; Select #60 test, check associated file #64 field #63 record.
+2 ; Inputs
+3 ; LRSS: <byref> Subscript area (MI,SP,CY) (See outputs)
+4 ; LRABORT: <byref> See outputs
+5 ; Outputs
+6 ; LRSS: Initially set by ASK and passed back to START
+7 ; : Passed in to set the DIC("B") in ASK
+8 ; LRABORT: If user wants to abort LRABORT=1
+9 ;
+10 NEW DA,DIC,DIE,DIERR,DIR,DIRUT,DIROUT,DR,DTOUT,DUOUT
+11 NEW ACTION,DATA,DBCERR,LRLCK1,LRLCK2,LRMSG,NLT,REC,X,Y
+12 NEW R60,R63,R64,R64061,IEN,LRFDA,STOP,TEST,WKLD,WKLDCOD
+13 SET STOP=0
+14 SET DIR(0)="SO^MI:Microbiology;SP:Surgical Pathology;CY:Cytopathology;EM:Electron Microscopy"
+15 SET DIR("A")="Choose Lab Area Subscript"
+16 IF $GET(LRSS)'=""
SET DIR("B")=LRSS
+17 DO ^DIR
+18 IF $DATA(DIRUT)
SET LRABORT=1
QUIT
+19 SET LRSS=Y
+20 ; Get lab test
+21 SET R60=0
+22 SET DIC="^LAB(60,"
+23 SET DIC(0)="AEMNQ"
+24 SET DIC("A")="Enter Laboratory Test Name: "
+25 SET DIC("S")="I $P(^LAB(60,Y,0),""^"",4)=LRSS"
+26 DO ^DIC
+27 KILL DIC
+28 IF $DATA(DUOUT)
SET LRABORT=1
QUIT
+29 IF $DATA(DTOUT)!(Y=-1)
QUIT
+30 IF Y>0
SET R60=+Y
+31 IF 'R60
QUIT
+32 ; lock #60
+33 SET LRLCK1=$NAME(^LAB(60,R60))
+34 SET X=$$GETLOCK^LRUTIL(LRLCK1,15)
+35 ;
IF 'X
Begin DoDot:1
+36 WRITE !,"Could not lock file #60"
End DoDot:1
QUIT
+37 ;
+38 ; Get National VA Lab Code (R64)
+39 SET R64=0
+40 KILL DIE,DA,DR,Y
+41 SET DIE="^LAB(60,"
+42 SET DIE("NO^")="OUTOK"
+43 SET DA=R60
+44 SET DR="W !,""Editing LABORATORY TEST file (#60)"";64"
+45 DO ^DIE
+46 IF $DATA(DTOUT)!$DATA(Y)
Begin DoDot:1
+47 LOCK -@LRLCK1
End DoDot:1
QUIT
+48 ;
+49 SET R64=$PIECE($GET(^LAB(60,R60,64)),U,1)
+50 IF 'R64
Begin DoDot:1
+51 LOCK -@LRLCK1
+52 WRITE $CHAR(7),!!," No National VA Lab Code associated with this test.",!
End DoDot:1
QUIT
+53 ;
+54 SET TEST=$PIECE(^LAB(60,R60,0),U,1)
+55 ; lock #64
+56 SET LRLCK2=$NAME(^LAM(R64))
+57 SET X=$$GETLOCK^LRUTIL(LRLCK2,15)
+58 ;
IF 'X
Begin DoDot:1
+59 WRITE !,"Could not lock file #64"
+60 ;unlock 63
LOCK -@LRLCK1
End DoDot:1
QUIT
+61 ;
+62 SET DATA=^LAM(R64,0)
+63 SET WKLD=$PIECE(DATA,U,1)
+64 SET WKLDCOD=$PIECE(DATA,U,2)
+65 WRITE !,"60 = ",TEST," [",R60,"]"
+66 WRITE !,"64 = ",WKLD," (",WKLDCOD,") [",R64,"]"
+67 ;
Begin DoDot:1
+68 NEW END,LRDATA
+69 DO LINK^LR7OU4(R60,R64,0)
+70 ;need to handle ^
+71 IF $GET(END)
SET STOP=1
End DoDot:1
+72 ;
+73 ;
IF STOP
Begin DoDot:1
+74 LOCK -@LRLCK2
+75 LOCK -@LRLCK1
End DoDot:1
QUIT
+76 ;
+77 ; Check LEC (#64.061) entry
+78 ;database code error
SET DBCERR=0
+79 SET DATA=$GET(^LAM(R64,63))
+80 SET R64061=$PIECE(DATA,U,1)
+81 ;
IF 'R64061
Begin DoDot:1
+82 WRITE !!,?10,"No Database Code on file for this NLT code.",!
End DoDot:1
+83 ;
+84 ;
IF R64061
Begin DoDot:1
+85 SET DATA=^LAB(64.061,R64061,0)
+86 SET X=$PIECE(DATA,U,1)
+87 WRITE !!!,?10,"Current Database Code for this NLT code is "
+88 WRITE !,?15,X," [",R64061,"]"
+89 SET Y="I X?1"""_LRSS_"""1.E1""Rpt Date"""
+90 XECUTE Y
+91 if $TEST
QUIT
+92 SET DBCERR=1
+93 WRITE !!,$CHAR(7),?7,"** Invalid Database Code for ",LRSS," **"
+94 WRITE !,?10,WKLD," (",WKLDCOD,") needs to be corrected."
+95 WRITE !
+96 KILL DIR,DIROUT,DIRUT
+97 SET DIR("A")="Do you want to fix it now"
+98 SET DIR(0)="Y"
+99 DO ^DIR
+100 IF $DATA(DIRUT)!(Y=0)
SET STOP=1
End DoDot:1
+101 ;
+102 ;
IF STOP
Begin DoDot:1
+103 LOCK -@LRLCK2
+104 LOCK -@LRLCK1
End DoDot:1
QUIT
+105 ;
+106 ;
IF R64061
IF 'DBCERR
Begin DoDot:1
+107 KILL DIR,DIROUT,DIRUT
+108 SET DIR("A")="Do you want to keep this mapping"
+109 SET DIR(0)="Y"
+110 SET DIR("B")="Y"
+111 WRITE !
+112 DO ^DIR
+113 IF $DATA(DIRUT)!(Y=1)
SET STOP=1
End DoDot:1
+114 ;
+115 ;
IF STOP
Begin DoDot:1
+116 LOCK -@LRLCK2
+117 LOCK -@LRLCK1
End DoDot:1
QUIT
+118 ;
+119 KILL DIR
+120 SET ACTION=""
+121 ;
IF R64061
Begin DoDot:1
+122 SET DIR(0)="SO^M:Map Database Code;U:Unmap this code"
+123 DO ^DIR
+124 SET ACTION=Y
End DoDot:1
+125 ;
+126 IF $DATA(DIRUT)
Begin DoDot:1
+127 LOCK -@LRLCK2
+128 LOCK -@LRLCK1
End DoDot:1
QUIT
+129 ;
+130 IF 'R64061
SET ACTION="M"
+131 ;
+132 ;
IF ACTION="M"
FOR
Begin DoDot:1
+133 KILL DIC,REC
+134 SET REC=0
+135 SET DIC=64.061
+136 SET DIC(0)="AEMNQ"
+137 SET DIC("A")="Select an "_LRSS_" Database Code: "
+138 SET DIC("S")="I $P(^(0),U,1)?1"""_LRSS_""".E1""Rpt Date"""
+139 DO ^DIC
+140 KILL DIC
+141 IF $DATA(DTOUT)!$DATA(DUOUT)
SET ACTION=-1
QUIT
+142 IF Y'>0
IF R64061
WRITE "<no change>",!
QUIT
+143 IF Y>0
SET REC=+Y
+144 ;
IF REC
IF REC'=R64061
Begin DoDot:2
+145 KILL IEN,LRFDA,LRMSG,DIERR
+146 SET IEN=R64_","
+147 SET LRFDA(1,64,IEN,63)=REC
+148 SET R64061=REC
+149 DO FILE^DIE("","LRFDA(1)","LRMSG")
+150 IF '$DATA(LRMSG)
WRITE !!,"Update complete."
End DoDot:2
QUIT
+151 ;
+152 ;
IF 'REC
IF 'R64061
Begin DoDot:2
+153 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT
+154 WRITE !!,?15,"An MI/AP Database Code must be selected"
+155 WRITE !,?15,"for this test to be used with LEDI results"
+156 SET DIR("A")="Sure you want to exit"
+157 SET DIR(0)="Y"
+158 SET DIR("B")="N"
+159 DO ^DIR
+160 WRITE !
+161 IF Y=1!$DATA(DIRUT)
SET ACTION=-1
QUIT
End DoDot:2
+162 ;
End DoDot:1
if R64061!(ACTION=-1)
QUIT
+163 ;
+164 ;
IF ACTION="U"
Begin DoDot:1
+165 KILL IEN,LRFDA,LRMSG,DIERR
+166 SET IEN=R64_","
+167 SET LRFDA(1,64,IEN,63)="@"
+168 DO FILE^DIE("","LRFDA(1)","LRMSG")
+169 IF '$DATA(LRMSG)
WRITE !," Mapping removed."
End DoDot:1
+170 ;
+171 LOCK -@LRLCK2
+172 LOCK -@LRLCK1
+173 ;
+174 QUIT
