LR263 ;DALOI/FHS - LR*5.2*263 PATCH ENVIRONMENT CHECK & CONVERT ROUTINE ; 5/1/99 ;
;;5.2;LAB SERVICE;**263**;Sep 27, 1994
EN ; Does not prevent loading of the transport global.
; Environment check is done only during the install.
Q:'$G(XPDENV)
D CHECK
D EXIT
Q
;
CHECK ; Perform environment check
N VER
I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D
. D BMES^XPDUTL($$CJ^XLFSTR("Terminal Device is not defined",80))
. S XPDQUIT=2
I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) D
. D BMES^XPDUTL($$CJ^XLFSTR("Please log in to set local DUZ... variables",80))
. S XPDQUIT=2
I '$D(^VA(200,$G(DUZ),0))#2 D
. D BMES^XPDUTL($$CJ^XLFSTR("You are not a valid user on this system",80))
. S XPDQUIT=2
S VER=$$VERSION^XPDUTL("LA7")
I VER'>5.1 D
. D BMES^XPDUTL($$CJ^XLFSTR("You must have LAB MESSAGING PACKAGE V5.2 Installed",80))
. S XPDQUIT=2
S VER=$$VERSION^XPDUTL("LR")
I VER'>5.1 D
. D BMES^XPDUTL($$CJ^XLFSTR("You must have LAB SERVICE PACKAGE V5.2 Installed",80))
. S XPDQUIT=2
LMI ;
N DIC,X,Y
S DIC=3.8,DIC(0)="NMXO",X="LMI" D ^DIC
I Y<1 D
. D BMES^XPDUTL($$CJ^XLFSTR("You must have Mail Group [ LMI ] defined.",80))
. S XPDQUIT=2
Q:$G(XPDQUIT)<1
S XPDIQ("XPZ1","B")="NO"
Q
;
EXIT ;
I $G(XPDQUIT) D BMES^XPDUTL($$CJ^XLFSTR("--- Install Environment Check FAILED ---",80))
I '$G(XPDQUIT) D BMES^XPDUTL($$CJ^XLFSTR("--- Environment Check is Ok ---",80))
Q
CONV ;Convert data to new DD structure
K ^TMP("LRCPT",$J),^TMP("LRCPT@",$J),LRDA,LRROOT,LRDEL,LRTXT
K ^TMP("LRCPTERR",$J)
S LRMSG="^TMP(""LRCPT"","_$J_")",CNT=0
S LRSUB="LRCPTERR",$P(LRTXT(5),"=",40)="",LRTXT(4)=""
S LRDA(1)=0 F S LRDA(1)=$O(^LAM(LRDA(1))) Q:LRDA(1)<1 D
. S LRDA=0 F S LRDA=$O(^LAM(LRDA(1),4,LRDA)) Q:LRDA<1 D
. . I '$D(^LAM(LRDA(1),4,LRDA,0)) K ^LAM(LRDA(1),4,LRDA) Q
. . S LRN=^LAM(LRDA(1),4,LRDA,0)
. . K LRROOT
. . S LRS=$P(LRN,U,2) I '$L(LRS) D BMES^XPDUTL($$CJ^XLFSTR("DATA BASE ERROR",80)) D DEL Q
. . S:LRS="L" LRS="LOINC"
. . S LRROOT(64.018,$$IENS^DILF(.LRDA),.01)=LRS_"."_+$P(LRN,U) D UPDATE
MAIL ;Send message to G.LMI local mail group
I '$O(^TMP(LRSUB,$J,0)) D BMES^XPDUTL($$CJ^XLFSTR("No CPT Errors were found - No Mail message required.",80))
I $O(^TMP(LRSUB,$J,0)) D
. D BMES^XPDUTL($$CJ^XLFSTR("Creating Mail Message containing CPT Changes",80))
. D BMES^XPDUTL($$CJ^XLFSTR("Sending message to LMI Mail Group.",80))
. N DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
. S XMSUB="WKLD CODE - CODE CHECK REPORT "_$$FMTE^XLFDT($$NOW^XLFDT,"1S")
. S XMY("G.LMI")="",XMTEXT="^TMP(""LRCPTERR"","_$J_",",XMDUZ=.5
. D ^XMD
D LNK6064
S:$D(^LAM(0))#2 $P(^(0),U,3)=99999
PUNCT ;Make venipuncture WKLD CODE(s) billable
D
. N DIC,X,Y
. S DIC="^LAM(",DIC(0)="ONMX"
. F X="89343.0000","89341.0000" D ^DIC I Y>1 D
. . I $D(^LAM(+Y,0))#2 S $P(^(0),U,5)=1
END ;
Q:$G(LRDBUG)
K ^LRO(69,"AE"),^LRO(69,"AA",0)
K ^TMP("LRCPT",$J),^TMP("LRCPT@",$J),^TMP("LRCPTERR",$J)
K CNT,I,LRCMT,LRDA,LRDEL,LRMSG,LRN,LRROOT,LRS,LRSUB,LRTXT,SUB,TXT
K XMDUZ,XMSUB,XMTEXT,XMY
Q
LNK6064 ; Relink NATIONAL VA LAB CODE with WKLD CODE file
D BMES^XPDUTL($$CJ^XLFSTR("Relinking NATIONAL VA LAB CODES TO WKLD CODES",80))
N CNT,CNTT,RT,IEN,LR64,CODE,NAME,DATA,LRX,I
S I=0 F S I=$O(^LAM(I)) Q:I<1 K ^LAM(I,7)
K ^LAM("AE","LAB(60,")
S (CNTT,CNT)=0
S LRX=0 F S LRX=$O(^LAB(60,LRX)) Q:LRX<1 D
. S CODE=+$P($G(^LAB(60,LRX,64)),U)
. Q:'$D(^LAM(CODE,0))#2 ; no code to update
. S NAME=$P(^LAB(60,LRX,0),U)
. S CNT=CNT+1 K ERR,RT,IEN
. S DATA="LAB(60,.`"_LRX,CNTT=CNTT+1
. S IEN="+1,"_CODE_",",RT(64.023,IEN,.01)=DATA
. D UPDATE^DIE("ES","RT","IEN","^LAH(""ERR243"")")
. W "."
Q
UPDATE ;
S CNT=$G(CNT)+1
D FILE^DIE("E","LRROOT","^TMP(""LRCPT"","_$J_","_CNT_")")
I $D(LRROOT) W ! D DEL Q
W:'$D(ZTQUEUED) "."
Q
DEL K LRDEL
N LRNOP
S LRTXT(2)="Removing "_LRS_" Code "_$P(LRN,U) D BMES^XPDUTL(LRTXT(2))
I $D(^LAM(LRDA(1),0))#2 S LRTXT(3)="From "_$P(^LAM(LRDA(1),0),U,2)_" "_$S($P(^(0),U,5):"+",1:"")_$P(^(0),U)
E S LRTXT(3)="DATABASE ERROR FOR ENTRY "_LRDA(1),LRNOP=1
S LRTXT(4)=$$FMTE^XLFDT($$NOW^XLFDT)
D BMES^XPDUTL(LRTXT(3))
S LRDEL(64.018,$$IENS^DILF(.LRDA),.01)="@"
D:'$G(LRNOP) FILE^DIE("E","LRDEL","TMP(""LRCPT@"","_$J_","_CNT_")")
D MSGSET(LRSUB,.LRTXT)
I '$G(LRNOP) D WP^DIE(64,LRDA(1)_",",24,"A","LRTXT","TMP(""LRCPT@"","_$J_","_CNT_")")
Q
MSGSET(SUB,TXT) ;SUB=subscript - TXT = array containing the message
N I ;
S LRCMT=$P($G(^TMP(SUB,$J,0)),U,4)
S I=0 F S I=$O(TXT(I)) Q:I<1 D
. S LRCMT=LRCMT+1,^TMP(SUB,$J,LRCMT,0)=TXT(I)
S $P(^TMP(SUB,$J,0),U,4)=LRCMT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR263 4629 printed Dec 13, 2024@02:03:33 Page 2
LR263 ;DALOI/FHS - LR*5.2*263 PATCH ENVIRONMENT CHECK & CONVERT ROUTINE ; 5/1/99 ;
+1 ;;5.2;LAB SERVICE;**263**;Sep 27, 1994
EN ; Does not prevent loading of the transport global.
+1 ; Environment check is done only during the install.
+2 if '$GET(XPDENV)
QUIT
+3 DO CHECK
+4 DO EXIT
+5 QUIT
+6 ;
CHECK ; Perform environment check
+1 NEW VER
+2 IF $SELECT('$GET(IOM):1,'$GET(IOSL):1,$GET(U)'="^":1,1:0)
Begin DoDot:1
+3 DO BMES^XPDUTL($$CJ^XLFSTR("Terminal Device is not defined",80))
+4 SET XPDQUIT=2
End DoDot:1
+5 IF $SELECT('$GET(DUZ):1,$DATA(DUZ)[0:1,$DATA(DUZ(0))[0:1,1:0)
Begin DoDot:1
+6 DO BMES^XPDUTL($$CJ^XLFSTR("Please log in to set local DUZ... variables",80))
+7 SET XPDQUIT=2
End DoDot:1
+8 IF '$DATA(^VA(200,$GET(DUZ),0))#2
Begin DoDot:1
+9 DO BMES^XPDUTL($$CJ^XLFSTR("You are not a valid user on this system",80))
+10 SET XPDQUIT=2
End DoDot:1
+11 SET VER=$$VERSION^XPDUTL("LA7")
+12 IF VER'>5.1
Begin DoDot:1
+13 DO BMES^XPDUTL($$CJ^XLFSTR("You must have LAB MESSAGING PACKAGE V5.2 Installed",80))
+14 SET XPDQUIT=2
End DoDot:1
+15 SET VER=$$VERSION^XPDUTL("LR")
+16 IF VER'>5.1
Begin DoDot:1
+17 DO BMES^XPDUTL($$CJ^XLFSTR("You must have LAB SERVICE PACKAGE V5.2 Installed",80))
+18 SET XPDQUIT=2
End DoDot:1
LMI ;
+1 NEW DIC,X,Y
+2 SET DIC=3.8
SET DIC(0)="NMXO"
SET X="LMI"
DO ^DIC
+3 IF Y<1
Begin DoDot:1
+4 DO BMES^XPDUTL($$CJ^XLFSTR("You must have Mail Group [ LMI ] defined.",80))
+5 SET XPDQUIT=2
End DoDot:1
+6 if $GET(XPDQUIT)<1
QUIT
+7 SET XPDIQ("XPZ1","B")="NO"
+8 QUIT
+9 ;
EXIT ;
+1 IF $GET(XPDQUIT)
DO BMES^XPDUTL($$CJ^XLFSTR("--- Install Environment Check FAILED ---",80))
+2 IF '$GET(XPDQUIT)
DO BMES^XPDUTL($$CJ^XLFSTR("--- Environment Check is Ok ---",80))
+3 QUIT
CONV ;Convert data to new DD structure
+1 KILL ^TMP("LRCPT",$JOB),^TMP("LRCPT@",$JOB),LRDA,LRROOT,LRDEL,LRTXT
+2 KILL ^TMP("LRCPTERR",$JOB)
+3 SET LRMSG="^TMP(""LRCPT"","_$JOB_")"
SET CNT=0
+4 SET LRSUB="LRCPTERR"
SET $PIECE(LRTXT(5),"=",40)=""
SET LRTXT(4)=""
+5 SET LRDA(1)=0
FOR
SET LRDA(1)=$ORDER(^LAM(LRDA(1)))
if LRDA(1)<1
QUIT
Begin DoDot:1
+6 SET LRDA=0
FOR
SET LRDA=$ORDER(^LAM(LRDA(1),4,LRDA))
if LRDA<1
QUIT
Begin DoDot:2
+7 IF '$DATA(^LAM(LRDA(1),4,LRDA,0))
KILL ^LAM(LRDA(1),4,LRDA)
QUIT
+8 SET LRN=^LAM(LRDA(1),4,LRDA,0)
+9 KILL LRROOT
+10 SET LRS=$PIECE(LRN,U,2)
IF '$LENGTH(LRS)
DO BMES^XPDUTL($$CJ^XLFSTR("DATA BASE ERROR",80))
DO DEL
QUIT
+11 if LRS="L"
SET LRS="LOINC"
+12 SET LRROOT(64.018,$$IENS^DILF(.LRDA),.01)=LRS_"."_+$PIECE(LRN,U)
DO UPDATE
End DoDot:2
End DoDot:1
MAIL ;Send message to G.LMI local mail group
+1 IF '$ORDER(^TMP(LRSUB,$JOB,0))
DO BMES^XPDUTL($$CJ^XLFSTR("No CPT Errors were found - No Mail message required.",80))
+2 IF $ORDER(^TMP(LRSUB,$JOB,0))
Begin DoDot:1
+3 DO BMES^XPDUTL($$CJ^XLFSTR("Creating Mail Message containing CPT Changes",80))
+4 DO BMES^XPDUTL($$CJ^XLFSTR("Sending message to LMI Mail Group.",80))
+5 NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
+6 SET XMSUB="WKLD CODE - CODE CHECK REPORT "_$$FMTE^XLFDT($$NOW^XLFDT,"1S")
+7 SET XMY("G.LMI")=""
SET XMTEXT="^TMP(""LRCPTERR"","_$JOB_","
SET XMDUZ=.5
+8 DO ^XMD
End DoDot:1
+9 DO LNK6064
+10 if $DATA(^LAM(0))#2
SET $PIECE(^(0),U,3)=99999
PUNCT ;Make venipuncture WKLD CODE(s) billable
+1 Begin DoDot:1
+2 NEW DIC,X,Y
+3 SET DIC="^LAM("
SET DIC(0)="ONMX"
+4 FOR X="89343.0000","89341.0000"
DO ^DIC
IF Y>1
Begin DoDot:2
+5 IF $DATA(^LAM(+Y,0))#2
SET $PIECE(^(0),U,5)=1
End DoDot:2
End DoDot:1
END ;
+1 if $GET(LRDBUG)
QUIT
+2 KILL ^LRO(69,"AE"),^LRO(69,"AA",0)
+3 KILL ^TMP("LRCPT",$JOB),^TMP("LRCPT@",$JOB),^TMP("LRCPTERR",$JOB)
+4 KILL CNT,I,LRCMT,LRDA,LRDEL,LRMSG,LRN,LRROOT,LRS,LRSUB,LRTXT,SUB,TXT
+5 KILL XMDUZ,XMSUB,XMTEXT,XMY
+6 QUIT
LNK6064 ; Relink NATIONAL VA LAB CODE with WKLD CODE file
+1 DO BMES^XPDUTL($$CJ^XLFSTR("Relinking NATIONAL VA LAB CODES TO WKLD CODES",80))
+2 NEW CNT,CNTT,RT,IEN,LR64,CODE,NAME,DATA,LRX,I
+3 SET I=0
FOR
SET I=$ORDER(^LAM(I))
if I<1
QUIT
KILL ^LAM(I,7)
+4 KILL ^LAM("AE","LAB(60,")
+5 SET (CNTT,CNT)=0
+6 SET LRX=0
FOR
SET LRX=$ORDER(^LAB(60,LRX))
if LRX<1
QUIT
Begin DoDot:1
+7 SET CODE=+$PIECE($GET(^LAB(60,LRX,64)),U)
+8 ; no code to update
if '$DATA(^LAM(CODE,0))#2
QUIT
+9 SET NAME=$PIECE(^LAB(60,LRX,0),U)
+10 SET CNT=CNT+1
KILL ERR,RT,IEN
+11 SET DATA="LAB(60,.`"_LRX
SET CNTT=CNTT+1
+12 SET IEN="+1,"_CODE_","
SET RT(64.023,IEN,.01)=DATA
+13 DO UPDATE^DIE("ES","RT","IEN","^LAH(""ERR243"")")
+14 WRITE "."
End DoDot:1
+15 QUIT
UPDATE ;
+1 SET CNT=$GET(CNT)+1
+2 DO FILE^DIE("E","LRROOT","^TMP(""LRCPT"","_$JOB_","_CNT_")")
+3 IF $DATA(LRROOT)
WRITE !
DO DEL
QUIT
+4 if '$DATA(ZTQUEUED)
WRITE "."
+5 QUIT
DEL KILL LRDEL
+1 NEW LRNOP
+2 SET LRTXT(2)="Removing "_LRS_" Code "_$PIECE(LRN,U)
DO BMES^XPDUTL(LRTXT(2))
+3 IF $DATA(^LAM(LRDA(1),0))#2
SET LRTXT(3)="From "_$PIECE(^LAM(LRDA(1),0),U,2)_" "_$SELECT($PIECE(^(0),U,5):"+",1:"")_$PIECE(^(0),U)
+4 IF '$TEST
SET LRTXT(3)="DATABASE ERROR FOR ENTRY "_LRDA(1)
SET LRNOP=1
+5 SET LRTXT(4)=$$FMTE^XLFDT($$NOW^XLFDT)
+6 DO BMES^XPDUTL(LRTXT(3))
+7 SET LRDEL(64.018,$$IENS^DILF(.LRDA),.01)="@"
+8 if '$GET(LRNOP)
DO FILE^DIE("E","LRDEL","TMP(""LRCPT@"","_$JOB_","_CNT_")")
+9 DO MSGSET(LRSUB,.LRTXT)
+10 IF '$GET(LRNOP)
DO WP^DIE(64,LRDA(1)_",",24,"A","LRTXT","TMP(""LRCPT@"","_$JOB_","_CNT_")")
+11 QUIT
MSGSET(SUB,TXT) ;SUB=subscript - TXT = array containing the message
+1 ;
NEW I
+2 SET LRCMT=$PIECE($GET(^TMP(SUB,$JOB,0)),U,4)
+3 SET I=0
FOR
SET I=$ORDER(TXT(I))
if I<1
QUIT
Begin DoDot:1
+4 SET LRCMT=LRCMT+1
SET ^TMP(SUB,$JOB,LRCMT,0)=TXT(I)
End DoDot:1
+5 SET $PIECE(^TMP(SUB,$JOB,0),U,4)=LRCMT
+6 QUIT
