LA7VLCM3 ;DALOI/JDB - LAB CODE MAPPING FILE UTILITIES ;12/27/11 09:57
;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229
;
Q
;
CODSETOK(R6247,R624701,CODE,CS,DISP) ;
; Is the combination of CODE and CODE SYSTEM valid?
; Used with IDENTIFIER and CODING SYSTEM fields of #62.4701
; Needs to be safe to use within recursive FM DD calls
; Inputs
; R6247: <opt>#62.47 IEN
; R624701: <opt>#62.4701 IEN
; CODE: <opt>Code
; CS: <opt>Code Set
; DISP: <opt>Display (show user messages? dflt=NO)
; Outputs
; 1 if CODE and CODSET are good, 0 if not
;
; Call with combination of R6247 & R624701, or CODE & CS, or
; R6247 & R624701 & (CODE or CS)
N OK,X,X1,X2,Y,DA,IENS,LAT,TARG,DIE,DIC,DIERR
Q:$G(DIUTIL)="VERIFY FIELDS" 1
S R6247=$G(R6247),R624701=$G(R624701)
S CODE=$G(CODE),CS=$G(CS),DISP=+$G(DISP)
S LAT=$T,OK=1
I R6247,R624701 D ;
. S IENS=R624701_","_R6247_","
. D GETS^DIQ(62.4701,IENS,".01;.02","E","TARG")
. I CODE="" S CODE=$G(TARG(62.4701,IENS,.01,"E"))
. I CS="" S CS=$G(TARG(62.4701,IENS,.02,"E"))
;
I CODE="" S CS="" ;if Code is null, there is nothing to validate against Code System
;
I CS="LN" S OK=$$ISLOINC(CODE)
;
I CS="SCT" D ;
. S X=$$CODE^LRSCT(CODE,"SCT",DT)
. I X<1 S OK=0
;
I CS="99VA64",'$O(^LAM("E",CODE,0)) S OK=0
;
I 'OK,DISP=1,'$$ISQUIET^LRXREF() D EN^DDIOL(" **Code/Set mismatch**",,"$C(32,7)")
;
I LAT ;reset $T
Q OK
;
;
ISLOINC(CODE) ;
; Returns if code is a valid LOINC code
; Needs to be FM DD safe
N STATUS,MSG,R953,X,Y,X1,X2,DA,IENS,DIC,DIE,LAX,DIERR
S CODE=$G(CODE),(R953,STATUS)=0
; cant use $$FIND1 here -- not sym table safe causes problems when used inside the Input Xform for field .02
;
; Check LOINC codes for both forms of storage - with and without checksum in #.01.
I CODE'="" S R953=$O(^LAB(95.3,"B",CODE,0))
I 'R953 D
. S LAX=$P(CODE,"-",1)
. I LAX'="" S R953=$O(^LAB(95.3,"B",LAX,0))
;
I R953 D
. K MSG
. S LAX=$$GET1^DIQ(95.3,R953_",",.01,"","","MSG")
. I LAX=CODE S STATUS=1
;
Q STATUS
;
;
CLONE ;
; Clone Msg Cfg in 62.47
N DIC,DIR,R6248S,R6248T,R6247,R624701,NODE,CODE,CS,MSGCFG
N LAMSG,CNT,CNT2,LAFDA,LAIEN,LAIEN2,LRFPRIV,X,DIERR
S DIC=62.48
S DIC(0)="AENOQ"
S DIC("S")="I $D(^LAB(62.47,""AG"",+Y))"
S DIC("A")="Source Message Configuration: "
D ^DIC
K DIC
S R6248S=+Y
Q:R6248S'>0
S DIC=62.48
S DIC(0)="AENOQ"
S DIC("S")="I '$D(^LAB(62.47,""AG"",+Y))"
S DIC("A")="Destination Message Configuration: "
D ^DIC
K DIC
S R6248T=+Y
Q:R6248T'>0
;
S DIR(0)="Y"
S DIR("A")="Continue with cloning? "
S DIR("B")="N"
S DIR("?")="Yes will copy the settings for the Source Configuration into File #62.47 for the Target Configuration"
D ^DIR
Q:'Y
;
I '$$GETLOCK^LRUTIL("^LAB(62.47)",,0) D Q ;
. W !!,"Could not lock file. Try later.",$C(7) H 3
;
S (CNT,CNT2)=0
S NODE="^LAB(62.47,""AG"",R6248S,0)"
F S NODE=$Q(@NODE) Q:NODE="" Q:$QS(NODE,2)'="AG" Q:$QS(NODE,3)'=R6248S D ;
. S CNT=CNT+1
. S R6247=$QS(NODE,4)
. S R624701=$QS(NODE,5)
. K LAIEN,LAIENB,LADATA,LAFDA
. S LAIEN=R624701_","_R6247_","
. S LAFLDS=".01;.02;.03;.04;.05;2.1;2.2"
. D GETS^DIQ(62.4701,LAIEN,LAFLDS,"I","LADATA","")
. Q:'$D(LADATA)
. S CODE=LADATA(62.4701,LAIEN,.01,"I")
. S CS=LADATA(62.4701,LAIEN,.02,"I")
. S MSGCFG=LADATA(62.4701,LAIEN,2.2,"I")
. ;
. S R624701=-1
. ; If target msg cfg not in file you can just add the record
. I '$D(^LAB(62.47,"AG",R6248T)) S R624701=0
. ; if MSG CFG is in xref need to check each CODE record
. I R624701=-1 D ;
. . K LADATA2,LAMSG,DIERR
. . D FIND^DIC(62.4701,","_R6247_",","@;.01I;.02I;2.2I","OQX",CODE,"","B^","","","LADATA2","LAMSG")
. . Q:'$D(LADATA2)
. . N FOUND,ID
. . S FOUND=0
. . S ID=0
. . F S ID=$O(LADATA2("DILIST","ID",ID)) Q:'ID D Q:FOUND ;
. . . S X=LADATA2("DILIST","ID",ID,2.2)
. . . Q:X'=R6248T
. . . S X=LADATA2("DILIST","ID",ID,.02)
. . . Q:X'=CODSYS
. . . S FOUND=1 S R624701=LADATA("DILIST",2,ID) Q
. . ;
. ; build FDA array for filing
. K LADATA2,LAMSG
. S FLD=""
. I R624701>0 S LAIEN2=R624701_","
. I R624701'>0 S LAIEN2="+1,"
. S LAIEN2=LAIEN2_R6247_","
. ;
. F I=1:1:$L(LAFLDS,";") S FLD=$P(LAFLDS,";",I) D ;
. . S X=$G(LADATA(62.4701,LAIEN,FLD,"I"))
. . I FLD=2.2 S X=R6248T
. . S LAFDA(1,62.4701,LAIEN2,FLD)=X
. S LRFPRIV=1
. I R624701'>0 D UPDATE^DIE("","LAFDA(1)","","LAMSG")
. I R624701>0 D FILE^DIE("","LAFDA(1)","LAMSG")
. I '$D(LAMSG) S CNT2=CNT2+1
;
L -^LAB(62.47)
W !!," Records found: ",CNT
W !," Records added: ",CNT2,!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VLCM3 4650 printed Dec 13, 2024@01:40:39 Page 2
LA7VLCM3 ;DALOI/JDB - LAB CODE MAPPING FILE UTILITIES ;12/27/11 09:57
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229
+2 ;
+3 QUIT
+4 ;
CODSETOK(R6247,R624701,CODE,CS,DISP) ;
+1 ; Is the combination of CODE and CODE SYSTEM valid?
+2 ; Used with IDENTIFIER and CODING SYSTEM fields of #62.4701
+3 ; Needs to be safe to use within recursive FM DD calls
+4 ; Inputs
+5 ; R6247: <opt>#62.47 IEN
+6 ; R624701: <opt>#62.4701 IEN
+7 ; CODE: <opt>Code
+8 ; CS: <opt>Code Set
+9 ; DISP: <opt>Display (show user messages? dflt=NO)
+10 ; Outputs
+11 ; 1 if CODE and CODSET are good, 0 if not
+12 ;
+13 ; Call with combination of R6247 & R624701, or CODE & CS, or
+14 ; R6247 & R624701 & (CODE or CS)
+15 NEW OK,X,X1,X2,Y,DA,IENS,LAT,TARG,DIE,DIC,DIERR
+16 if $GET(DIUTIL)="VERIFY FIELDS"
QUIT 1
+17 SET R6247=$GET(R6247)
SET R624701=$GET(R624701)
+18 SET CODE=$GET(CODE)
SET CS=$GET(CS)
SET DISP=+$GET(DISP)
+19 SET LAT=$TEST
SET OK=1
+20 ;
IF R6247
IF R624701
Begin DoDot:1
+21 SET IENS=R624701_","_R6247_","
+22 DO GETS^DIQ(62.4701,IENS,".01;.02","E","TARG")
+23 IF CODE=""
SET CODE=$GET(TARG(62.4701,IENS,.01,"E"))
+24 IF CS=""
SET CS=$GET(TARG(62.4701,IENS,.02,"E"))
End DoDot:1
+25 ;
+26 ;if Code is null, there is nothing to validate against Code System
IF CODE=""
SET CS=""
+27 ;
+28 IF CS="LN"
SET OK=$$ISLOINC(CODE)
+29 ;
+30 ;
IF CS="SCT"
Begin DoDot:1
+31 SET X=$$CODE^LRSCT(CODE,"SCT",DT)
+32 IF X<1
SET OK=0
End DoDot:1
+33 ;
+34 IF CS="99VA64"
IF '$ORDER(^LAM("E",CODE,0))
SET OK=0
+35 ;
+36 IF 'OK
IF DISP=1
IF '$$ISQUIET^LRXREF()
DO EN^DDIOL(" **Code/Set mismatch**",,"$C(32,7)")
+37 ;
+38 ;reset $T
IF LAT
+39 QUIT OK
+40 ;
+41 ;
ISLOINC(CODE) ;
+1 ; Returns if code is a valid LOINC code
+2 ; Needs to be FM DD safe
+3 NEW STATUS,MSG,R953,X,Y,X1,X2,DA,IENS,DIC,DIE,LAX,DIERR
+4 SET CODE=$GET(CODE)
SET (R953,STATUS)=0
+5 ; cant use $$FIND1 here -- not sym table safe causes problems when used inside the Input Xform for field .02
+6 ;
+7 ; Check LOINC codes for both forms of storage - with and without checksum in #.01.
+8 IF CODE'=""
SET R953=$ORDER(^LAB(95.3,"B",CODE,0))
+9 IF 'R953
Begin DoDot:1
+10 SET LAX=$PIECE(CODE,"-",1)
+11 IF LAX'=""
SET R953=$ORDER(^LAB(95.3,"B",LAX,0))
End DoDot:1
+12 ;
+13 IF R953
Begin DoDot:1
+14 KILL MSG
+15 SET LAX=$$GET1^DIQ(95.3,R953_",",.01,"","","MSG")
+16 IF LAX=CODE
SET STATUS=1
End DoDot:1
+17 ;
+18 QUIT STATUS
+19 ;
+20 ;
CLONE ;
+1 ; Clone Msg Cfg in 62.47
+2 NEW DIC,DIR,R6248S,R6248T,R6247,R624701,NODE,CODE,CS,MSGCFG
+3 NEW LAMSG,CNT,CNT2,LAFDA,LAIEN,LAIEN2,LRFPRIV,X,DIERR
+4 SET DIC=62.48
+5 SET DIC(0)="AENOQ"
+6 SET DIC("S")="I $D(^LAB(62.47,""AG"",+Y))"
+7 SET DIC("A")="Source Message Configuration: "
+8 DO ^DIC
+9 KILL DIC
+10 SET R6248S=+Y
+11 if R6248S'>0
QUIT
+12 SET DIC=62.48
+13 SET DIC(0)="AENOQ"
+14 SET DIC("S")="I '$D(^LAB(62.47,""AG"",+Y))"
+15 SET DIC("A")="Destination Message Configuration: "
+16 DO ^DIC
+17 KILL DIC
+18 SET R6248T=+Y
+19 if R6248T'>0
QUIT
+20 ;
+21 SET DIR(0)="Y"
+22 SET DIR("A")="Continue with cloning? "
+23 SET DIR("B")="N"
+24 SET DIR("?")="Yes will copy the settings for the Source Configuration into File #62.47 for the Target Configuration"
+25 DO ^DIR
+26 if 'Y
QUIT
+27 ;
+28 ;
IF '$$GETLOCK^LRUTIL("^LAB(62.47)",,0)
Begin DoDot:1
+29 WRITE !!,"Could not lock file. Try later.",$CHAR(7)
HANG 3
End DoDot:1
QUIT
+30 ;
+31 SET (CNT,CNT2)=0
+32 SET NODE="^LAB(62.47,""AG"",R6248S,0)"
+33 ;
FOR
SET NODE=$QUERY(@NODE)
if NODE=""
QUIT
if $QSUBSCRIPT(NODE,2)'="AG"
QUIT
if $QSUBSCRIPT(NODE,3)'=R6248S
QUIT
Begin DoDot:1
+34 SET CNT=CNT+1
+35 SET R6247=$QSUBSCRIPT(NODE,4)
+36 SET R624701=$QSUBSCRIPT(NODE,5)
+37 KILL LAIEN,LAIENB,LADATA,LAFDA
+38 SET LAIEN=R624701_","_R6247_","
+39 SET LAFLDS=".01;.02;.03;.04;.05;2.1;2.2"
+40 DO GETS^DIQ(62.4701,LAIEN,LAFLDS,"I","LADATA","")
+41 if '$DATA(LADATA)
QUIT
+42 SET CODE=LADATA(62.4701,LAIEN,.01,"I")
+43 SET CS=LADATA(62.4701,LAIEN,.02,"I")
+44 SET MSGCFG=LADATA(62.4701,LAIEN,2.2,"I")
+45 ;
+46 SET R624701=-1
+47 ; If target msg cfg not in file you can just add the record
+48 IF '$DATA(^LAB(62.47,"AG",R6248T))
SET R624701=0
+49 ; if MSG CFG is in xref need to check each CODE record
+50 ;
IF R624701=-1
Begin DoDot:2
+51 KILL LADATA2,LAMSG,DIERR
+52 DO FIND^DIC(62.4701,","_R6247_",","@;.01I;.02I;2.2I","OQX",CODE,"","B^","","","LADATA2","LAMSG")
+53 if '$DATA(LADATA2)
QUIT
+54 NEW FOUND,ID
+55 SET FOUND=0
+56 SET ID=0
+57 ;
FOR
SET ID=$ORDER(LADATA2("DILIST","ID",ID))
if 'ID
QUIT
Begin DoDot:3
+58 SET X=LADATA2("DILIST","ID",ID,2.2)
+59 if X'=R6248T
QUIT
+60 SET X=LADATA2("DILIST","ID",ID,.02)
+61 if X'=CODSYS
QUIT
+62 SET FOUND=1
SET R624701=LADATA("DILIST",2,ID)
QUIT
End DoDot:3
if FOUND
QUIT
+63 ;
End DoDot:2
+64 ; build FDA array for filing
+65 KILL LADATA2,LAMSG
+66 SET FLD=""
+67 IF R624701>0
SET LAIEN2=R624701_","
+68 IF R624701'>0
SET LAIEN2="+1,"
+69 SET LAIEN2=LAIEN2_R6247_","
+70 ;
+71 ;
FOR I=1:1:$LENGTH(LAFLDS,";")
SET FLD=$PIECE(LAFLDS,";",I)
Begin DoDot:2
+72 SET X=$GET(LADATA(62.4701,LAIEN,FLD,"I"))
+73 IF FLD=2.2
SET X=R6248T
+74 SET LAFDA(1,62.4701,LAIEN2,FLD)=X
End DoDot:2
+75 SET LRFPRIV=1
+76 IF R624701'>0
DO UPDATE^DIE("","LAFDA(1)","","LAMSG")
+77 IF R624701>0
DO FILE^DIE("","LAFDA(1)","LAMSG")
+78 IF '$DATA(LAMSG)
SET CNT2=CNT2+1
End DoDot:1
+79 ;
+80 LOCK -^LAB(62.47)
+81 WRITE !!," Records found: ",CNT
+82 WRITE !," Records added: ",CNT2,!
+83 QUIT
