LA80 ;DALOI/STAFF - LA*5.2*80 KIDS ROUTINE ;3/25/13 11:02
;;5.2;AUTOMATED LAB INSTRUMENTS;**80**;Sep 27, 1994;Build 19
;
Q
POST ;
; KIDS Post install for LA*5.2*80
D REMOVE,ADD1,ADD2
Q
;
REMOVE ;
; Remove LOINC code 22638-1 from the SP Comment concept.
N LRCNPTNM,LRLNC
S LRCNPTNM="SP COMMENT",LRLNC="22638-1"
D REMLNC(LRCNPTNM,LRLNC)
Q
;
REMLNC(LRCNPTNM,LRLNC) ;
; Remove LOINC code from concept.
N LRCNCPT,LRID
S LRCNCPT=$O(^LAB(62.47,"B",LRCNPTNM,0))
I +LRCNCPT D
.S LRID=$O(^LAB(62.47,LRCNCPT,1,"B",LRLNC,0))
.I +LRID D REMSENT(+LRCNCPT,+LRID,LRLNC)
Q
;
REMSENT(LRCNCPT,LRID,LRLNC) ;
; Remove Sub-file Entry.
N DA,DIK
S DA(1)=LRCNCPT
S DA=LRID
S DIK="^LAB(62.47,"_DA(1)_",1,"
L +^LAB(62.47,DA(1)):$G(DILOCKTM,5)
I $T D Q
.D ^DIK
.L -^LAB(62.47,DA(1))
D BMES("*** Unable to obtain lock for ^LAB(62.47,"_DA(1)_") to remove LOINC code "_LRLNC_" ***")
Q
;
ADD1 ;
; Add LOINC code 24419-4 to CY Gross Description, and EM Gross
; Description concepts.
N DIC,X,Y
S DIC="^LAB(62.47,",DIC(0)="X"
F X="CY","EM" D
.S X=X_" GROSS DESCRIPTION"
.D ^DIC
.Q:Y=-1
.D ADDLNC(+Y,"24419-4")
Q
;
ADD2 ;
; Add LOINC code 22638-1 to SP Gross Description, CY Gross
; Description, and EM Gross Description concepts.
N DIC,X,Y
S DIC="^LAB(62.47,",DIC(0)="X"
F X="SP","CY","EM" D
.S X=X_" GROSS DESCRIPTION"
.D ^DIC
.Q:Y=-1
.D ADDLNC(+Y,"22638-1")
Q
;
ADDLNC(LRCNCPT,LRLNC) ;
; Add LOINC code to concept
N DA,DIC,X,Y,LRFPRIV,DIE,DR
S DA(1)=LRCNCPT,DIC="^LAB(62.47,"_DA(1)_",1,",DIC(0)="L"
S X=LRLNC
L +^LAB(62.47,DA(1)):$G(DILOCKTM,5)
I '$T D Q
.D BMES("*** Unable to obtain lock for ^LAB(62.47,"_DA(1)_") to add LOINC code "_LRLNC_" ***")
D ^DIC
I Y=-1 D Q
.L -^LAB(62.47,DA(1))
;
S LRFPRIV=1,DIE=DIC ;LRFPRIV is needed for editing #.05
K DIC
S DA(1)=LRCNCPT,DA=+Y,DR=".02///LN;.03///1;.05///1"
D ^DIE
L -^LAB(62.47,DA(1))
Q
;
BMES(STR) ;
; Write string
D BMES^XPDUTL($$TRIM^XLFSTR($$CJ^XLFSTR(STR,$G(IOM,80)),"R"," "))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA80 2067 printed Dec 13, 2024@01:41:12 Page 2
LA80 ;DALOI/STAFF - LA*5.2*80 KIDS ROUTINE ;3/25/13 11:02
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**80**;Sep 27, 1994;Build 19
+2 ;
+3 QUIT
POST ;
+1 ; KIDS Post install for LA*5.2*80
+2 DO REMOVE
DO ADD1
DO ADD2
+3 QUIT
+4 ;
REMOVE ;
+1 ; Remove LOINC code 22638-1 from the SP Comment concept.
+2 NEW LRCNPTNM,LRLNC
+3 SET LRCNPTNM="SP COMMENT"
SET LRLNC="22638-1"
+4 DO REMLNC(LRCNPTNM,LRLNC)
+5 QUIT
+6 ;
REMLNC(LRCNPTNM,LRLNC) ;
+1 ; Remove LOINC code from concept.
+2 NEW LRCNCPT,LRID
+3 SET LRCNCPT=$ORDER(^LAB(62.47,"B",LRCNPTNM,0))
+4 IF +LRCNCPT
Begin DoDot:1
+5 SET LRID=$ORDER(^LAB(62.47,LRCNCPT,1,"B",LRLNC,0))
+6 IF +LRID
DO REMSENT(+LRCNCPT,+LRID,LRLNC)
End DoDot:1
+7 QUIT
+8 ;
REMSENT(LRCNCPT,LRID,LRLNC) ;
+1 ; Remove Sub-file Entry.
+2 NEW DA,DIK
+3 SET DA(1)=LRCNCPT
+4 SET DA=LRID
+5 SET DIK="^LAB(62.47,"_DA(1)_",1,"
+6 LOCK +^LAB(62.47,DA(1)):$GET(DILOCKTM,5)
+7 IF $TEST
Begin DoDot:1
+8 DO ^DIK
+9 LOCK -^LAB(62.47,DA(1))
End DoDot:1
QUIT
+10 DO BMES("*** Unable to obtain lock for ^LAB(62.47,"_DA(1)_") to remove LOINC code "_LRLNC_" ***")
+11 QUIT
+12 ;
ADD1 ;
+1 ; Add LOINC code 24419-4 to CY Gross Description, and EM Gross
+2 ; Description concepts.
+3 NEW DIC,X,Y
+4 SET DIC="^LAB(62.47,"
SET DIC(0)="X"
+5 FOR X="CY","EM"
Begin DoDot:1
+6 SET X=X_" GROSS DESCRIPTION"
+7 DO ^DIC
+8 if Y=-1
QUIT
+9 DO ADDLNC(+Y,"24419-4")
End DoDot:1
+10 QUIT
+11 ;
ADD2 ;
+1 ; Add LOINC code 22638-1 to SP Gross Description, CY Gross
+2 ; Description, and EM Gross Description concepts.
+3 NEW DIC,X,Y
+4 SET DIC="^LAB(62.47,"
SET DIC(0)="X"
+5 FOR X="SP","CY","EM"
Begin DoDot:1
+6 SET X=X_" GROSS DESCRIPTION"
+7 DO ^DIC
+8 if Y=-1
QUIT
+9 DO ADDLNC(+Y,"22638-1")
End DoDot:1
+10 QUIT
+11 ;
ADDLNC(LRCNCPT,LRLNC) ;
+1 ; Add LOINC code to concept
+2 NEW DA,DIC,X,Y,LRFPRIV,DIE,DR
+3 SET DA(1)=LRCNCPT
SET DIC="^LAB(62.47,"_DA(1)_",1,"
SET DIC(0)="L"
+4 SET X=LRLNC
+5 LOCK +^LAB(62.47,DA(1)):$GET(DILOCKTM,5)
+6 IF '$TEST
Begin DoDot:1
+7 DO BMES("*** Unable to obtain lock for ^LAB(62.47,"_DA(1)_") to add LOINC code "_LRLNC_" ***")
End DoDot:1
QUIT
+8 DO ^DIC
+9 IF Y=-1
Begin DoDot:1
+10 LOCK -^LAB(62.47,DA(1))
End DoDot:1
QUIT
+11 ;
+12 ;LRFPRIV is needed for editing #.05
SET LRFPRIV=1
SET DIE=DIC
+13 KILL DIC
+14 SET DA(1)=LRCNCPT
SET DA=+Y
SET DR=".02///LN;.03///1;.05///1"
+15 DO ^DIE
+16 LOCK -^LAB(62.47,DA(1))
+17 QUIT
+18 ;
BMES(STR) ;
+1 ; Write string
+2 DO BMES^XPDUTL($$TRIM^XLFSTR($$CJ^XLFSTR(STR,$GET(IOM,80)),"R"," "))
+3 QUIT
