LR163 ;DALISC/FHS - LR*5.2*163 PATCH ENVIRONMENT CHECK ROUTINE
;;5.2;LAB SERVICE;**163**;Sep 27, 1994
EN0 ;
Q:'$G(XPDENV)
L +^LRO(69,"AA"):15 I '$T D BMES^XPDUTL($$CJ^XLFSTR(" Unable to successfully lock the ^LRO(69,AA) global. ",80)) S XPQUIT=2
I '$D(^LAM(0))#2 D BMES^XPDUTL($$CJ^XLFSTR("There is no WKLD CODE file.",80)) S XPQUIT=2
I $$VERSION^XPDUTL("ICPT")'="6.0" D BMES^XPDUTL($$CJ^XLFSTR("You must install ICPT V6.0 Package first.",80)) S XPQUIT=2
I '$O(^LAM(0)) D BMES^XPDUTL($$CJ^XLFSTR("There is no data in your WKLD CODE file.",80)) S XPDQUIT=2
I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D BMES^XPDUTL($$CJ^XLFSTR("Terminal Device in not defined.",80)) S XPDQUIT=2
I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) 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 BMES^XPDUTL($$CJ^XLFSTR("You are not a valid user on this system.",80)) S XPDQUIT=2
I +$G(^LAM("VR"))'>5.1 D BMES^XPDUTL($$CJ^XLFSTR("You must have LAB V5.2 or greater Installed.",80)) S XPDQUIT=2
I $G(XPDQUIT) D BMES^XPDUTL($$CJ^XLFSTR("Install environment check FAILED.",80)) L -^LRO(69,"AA")
I '$G(XPDQUIT) D BMES^XPDUTL($$CJ^XLFSTR("Environment Check is Ok ---",80))
Q
PRE ;LR*5.2*163 AFTER USER COMMITS ROUTINE KIDS INSTALL"
ENPRE ;
Q:'$D(XPDNM)
;Cleanup broken X-Ref
N I,N
S I=0 F S I=$O(^LAM(I)) Q:I<1 D
. Q:'$D(^LAM(I,"7","B","LRDATA"))
. S N=0 F S N=$O(^LAM(I,7,"B","LRDATA",N)) Q:N<1 D
. . K ^LAM(I,7,"B","LRDATA",N),^LAM(I,7,N,0)
. . I $P(^LAM(I,7,0),U,4) S $P(^LAM(I,7,0),U,4)=$P(^LAM(I,7,0),U,4)-1
I $D(^LAB(64.81,0))#2 S X=$P(^(0),U,1,2) K ^LAB(64.81) S ^LAB(64.81,0)=X
S:$D(^LAM(0))#2 $P(^LAM(0),U,3)=2225 D
. D BMES^XPDUTL($$CJ^XLFSTR("Removing 'Reserve 2 field (#8) in WKLD CODE file (#64).",80))
. D BMES^XPDUTL($$CJ^XLFSTR("The field will be renamed 'PRICE'.",80))
. N DA,DIK
. S DA=8,DIK="^DD(64," D ^DIK
D BMES^XPDUTL($$CJ^XLFSTR("Removing 'Reserve 2 field (#8) in WKLD CODE SUFFIX file (#64.2).",80))
D BMES^XPDUTL($$CJ^XLFSTR("The field will be renamed 'PRICE'.",80)) D
. N DA,DIK
. S DA=8,DIK="^DD(64.2," D ^DIK
D BMES^XPDUTL($$CJ^XLFSTR("Removing existing CPT codes for WKLD CODE file.",80))
W ! S I=0 F S I=$O(^LAM(I)) Q:I<1 D
. I '$D(^LAM(I,0))#2 K ^LAM(I) Q
. S:'$P(^LAM(I,0),U,7) $P(^(0),U,7)=38 K:$D(^LAM(I,4)) ^LAM(I,4) W:'(I#50) "."
K ^LAM("AD")
D SPCK
D BMES^XPDUTL($$CJ^XLFSTR("** Pre Install Step Complete **",80))
Q
PURG ;
K DIK,DA S DIK="^LAB(64.81,",DA=LRIEN,DA(1)=64.81 D ^DIK K DIK
Q
SPCK K ^XTMP("LR","SPELL ERR")
S ^XTMP("LR","SPELL ERR")="LR*5.2*163 Spelling errors"
D BMES^XPDUTL($$CJ^XLFSTR("Correcting Duplicates or Spelling Errors",80))
D BMES^XPDUTL($$CJ^XLFSTR("Names that begin with 'X*' have codes that are incorrect.",80))
K CK S CK="" F I=1:1 S LN=$T(SPELL+I) Q:$P(LN,";;",2)="STOP" S CK(I)=LN
S I=0 F S I=$O(CK(I)) Q:I<1 D BMES^XPDUTL($$CJ^XLFSTR($P(CK(I),";",3)_" "_$P(CK(I),";",4),80))
K DIC S DIC=64,DIC(0)="XNZM"
S II=0 F S II=$O(CK(II)) Q:II<1 D
. S X=$P(CK(II),";",3)_".0000",NM=$P(CK(II),";",4) D ^DIC
. I Y<1 D BMES^XPDUTL($$CJ^XLFSTR("*** Unable to find WKLD Code [ "_X_" ] in your file #64 ****",80)) Q
. ;W !,Y W:Y>1 !,Y(0)
. S LNX=$P(Y,U,2) I LNX'=NM S CK=1 D FILE
D BMES^XPDUTL($$CJ^XLFSTR("Spelling updates completed.",80))
Q
SPELL ;
;;97485;X*Hepatitis C RNA;
;;STOP
FILE ;
N LRROOT,DA
D BMES^XPDUTL($$CJ^XLFSTR("Correcting Spelling of entry "_+Y_" from "_LNX_" to "_NM,80))
S DA=+Y,LRROOT(64,DA_",",.01)=NM
D FILE^DIE("","LRROOT",^XTMP("LR","SPELL ERR"))
Q
POST ;LR*5.2*163 POST INSTALL ROUTINE KIDS INSTALL"
ENPOS ;
S:$D(^LAM(0))#2 $P(^(0),U,3)=99999 S $P(^LAB(69.9,1,"VSIT"),U)=1
D BMES^XPDUTL($$CJ^XLFSTR("LABORATORY SITE FILE (#69.9) field PCE/VSIT ON (#615)",80))
D BMES^XPDUTL($$CJ^XLFSTR("is set to transmit CPT codes ONLY - No stop code transmission.",80))
I '$O(^LAB(64.81,0)) W $C(7) D BMES^XPDUTL($$CJ^XLFSTR("No data in file # 64.81 - No linking done.",80)) G MSG
D BMES^XPDUTL($$CJ^XLFSTR("** Starting CPT to NLT linking - Standby **",80))
CPT ;
S LRACTDT="MARCH 1, 1997" W !
K DIE S LRIEN=0,DIE="^LAM(" F S LRIEN=$O(^LAB(64.81,LRIEN)) Q:LRIEN<1 I $D(^(LRIEN,0))#2 S DATA=^(0) D I '$P(^LAB(64.81,LRIEN,0),U,9) D PURG
. S LRNLT=$P(DATA,U,2),LRCPT=$P(DATA,U,3),LRRNAME=$P(DATA,U,8)
. Q:'LRNLT!('LRCPT)
. W:'(LRIEN#50) "." D LK
I '$O(^LAB(64.81,0)) D BMES^XPDUTL($$CJ^XLFSTR("Database Upgrade Completed Successfully",80)) G MSG
D BMES^XPDUTL($$CJ^XLFSTR(" Database Upgrade is Incomplete - Use FM to print upgrade errors",80))
D BMES^XPDUTL($$CJ^XLFSTR("stored in the LAB NLT/CPT CODES (#64.81) file.",80))
MSG ;
D BMES^XPDUTL($$CJ^XLFSTR("Checking File pointer integrity",80))
D
. S LRI=0 F S LRI=$O(^LAB(64.2,LRI)) Q:LRI<1 I $D(^(LRI,0)),'$D(^LAB(64.3,+$P(^(0),U,14),0)) D
. . N DIE,DA,DR W "."
. . S DR="11///1",DA=LRI,DIE="^LAB(64.2," D ^DIE
D
. S LRI=0 F S LRI=$O(^LAM(LRI)) Q:LRI<1 I $D(^(LRI,0)),'$D(^LAB(64.3,+$P(^(0),U,14),0)) D
. . N DIE,DA,DR W "*"
. . S DR="12///1",DA=LRI,DIE="^LAM(" D ^DIE
D BMES^XPDUTL($$CJ^XLFSTR("Use 'Workload code list option [LRCAPD] for a full listing of",80))
D BMES^XPDUTL($$CJ^XLFSTR("ALL NLT Codes used in Laboratory Test File (#60).",80))
D BMES^XPDUTL($$CJ^XLFSTR("You can also use the [Edit or Print WKLD CODES] option for a listing",80))
D BMES^XPDUTL($$CJ^XLFSTR("of linked CPT linked NLT codes.",80))
L -^LAB(69,"AA")
D BMES^XPDUTL($$CJ^XLFSTR("** Post install completed **",80))
Q
LK ;
S LRCODE=0 F S LRCODE=+$O(^LAM("C",LRNLT_" ",LRCODE)) Q:LRCODE<1 D
. K DA S TAG="*",DA=LRCODE I '$D(^LAM(DA,0))#2 D ERR Q
. S TAG="|" I +$P(^LAM(DA,0),U,2)'[+LRNLT D ERR Q
. K DR D ADD
Q
ADD ;
Q:$D(^LAM(DA,4,"B",LRCPT))
Q:'$P($G(^LAM(DA,0)),U,2) Q:$P(^(0),U,2)'[+LRNLT
S DA(1)=4,DR="18///"_LRCPT_";",DR(1,64)="18///"_LRCPT,DR(2,64.018)=".01///"_LRCPT_";2///"_LRACTDT_";5///"_"CPT"
W:$G(LRDBUG) "DA = ",DA_" " D ^DIE I $D(^LAM(DA,4,"B",LRCPT)) W:$G(LRDBUG) ". - " Q
S TAG="/" D ERR
Q
ERR ;
S:'$D(TAG) TAG="+" S $P(^LAB(64.81,LRIEN,0),U,9)=$P(^(0),U,9)_LRNLT_TAG
W $C(7) D BMES^XPDUTL($$CJ^XLFSTR("Error Processing WKLD CODE "_LRNLT_" Logged in "_LRIEN,80)) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR163 6267 printed Dec 13, 2024@02:03:20 Page 2
LR163 ;DALISC/FHS - LR*5.2*163 PATCH ENVIRONMENT CHECK ROUTINE
+1 ;;5.2;LAB SERVICE;**163**;Sep 27, 1994
EN0 ;
+1 if '$GET(XPDENV)
QUIT
+2 LOCK +^LRO(69,"AA"):15
IF '$TEST
DO BMES^XPDUTL($$CJ^XLFSTR(" Unable to successfully lock the ^LRO(69,AA) global. ",80))
SET XPQUIT=2
+3 IF '$DATA(^LAM(0))#2
DO BMES^XPDUTL($$CJ^XLFSTR("There is no WKLD CODE file.",80))
SET XPQUIT=2
+4 IF $$VERSION^XPDUTL("ICPT")'="6.0"
DO BMES^XPDUTL($$CJ^XLFSTR("You must install ICPT V6.0 Package first.",80))
SET XPQUIT=2
+5 IF '$ORDER(^LAM(0))
DO BMES^XPDUTL($$CJ^XLFSTR("There is no data in your WKLD CODE file.",80))
SET XPDQUIT=2
+6 IF $SELECT('$GET(IOM):1,'$GET(IOSL):1,$GET(U)'="^":1,1:0)
DO BMES^XPDUTL($$CJ^XLFSTR("Terminal Device in not defined.",80))
SET XPDQUIT=2
+7 IF $SELECT('$GET(DUZ):1,$DATA(DUZ)[0:1,$DATA(DUZ(0))[0:1,1:0)
DO BMES^XPDUTL($$CJ^XLFSTR("Please Log in to set local DUZ... variables.",80))
SET XPDQUIT=2
+8 IF '$DATA(^VA(200,$GET(DUZ),0))#2
DO BMES^XPDUTL($$CJ^XLFSTR("You are not a valid user on this system.",80))
SET XPDQUIT=2
+9 IF +$GET(^LAM("VR"))'>5.1
DO BMES^XPDUTL($$CJ^XLFSTR("You must have LAB V5.2 or greater Installed.",80))
SET XPDQUIT=2
+10 IF $GET(XPDQUIT)
DO BMES^XPDUTL($$CJ^XLFSTR("Install environment check FAILED.",80))
LOCK -^LRO(69,"AA")
+11 IF '$GET(XPDQUIT)
DO BMES^XPDUTL($$CJ^XLFSTR("Environment Check is Ok ---",80))
+12 QUIT
PRE ;LR*5.2*163 AFTER USER COMMITS ROUTINE KIDS INSTALL"
ENPRE ;
+1 if '$DATA(XPDNM)
QUIT
+2 ;Cleanup broken X-Ref
+3 NEW I,N
+4 SET I=0
FOR
SET I=$ORDER(^LAM(I))
if I<1
QUIT
Begin DoDot:1
+5 if '$DATA(^LAM(I,"7","B","LRDATA"))
QUIT
+6 SET N=0
FOR
SET N=$ORDER(^LAM(I,7,"B","LRDATA",N))
if N<1
QUIT
Begin DoDot:2
+7 KILL ^LAM(I,7,"B","LRDATA",N),^LAM(I,7,N,0)
+8 IF $PIECE(^LAM(I,7,0),U,4)
SET $PIECE(^LAM(I,7,0),U,4)=$PIECE(^LAM(I,7,0),U,4)-1
End DoDot:2
End DoDot:1
+9 IF $DATA(^LAB(64.81,0))#2
SET X=$PIECE(^(0),U,1,2)
KILL ^LAB(64.81)
SET ^LAB(64.81,0)=X
+10 if $DATA(^LAM(0))#2
SET $PIECE(^LAM(0),U,3)=2225
Begin DoDot:1
+11 DO BMES^XPDUTL($$CJ^XLFSTR("Removing 'Reserve 2 field (#8) in WKLD CODE file (#64).",80))
+12 DO BMES^XPDUTL($$CJ^XLFSTR("The field will be renamed 'PRICE'.",80))
+13 NEW DA,DIK
+14 SET DA=8
SET DIK="^DD(64,"
DO ^DIK
End DoDot:1
+15 DO BMES^XPDUTL($$CJ^XLFSTR("Removing 'Reserve 2 field (#8) in WKLD CODE SUFFIX file (#64.2).",80))
+16 DO BMES^XPDUTL($$CJ^XLFSTR("The field will be renamed 'PRICE'.",80))
Begin DoDot:1
+17 NEW DA,DIK
+18 SET DA=8
SET DIK="^DD(64.2,"
DO ^DIK
End DoDot:1
+19 DO BMES^XPDUTL($$CJ^XLFSTR("Removing existing CPT codes for WKLD CODE file.",80))
+20 WRITE !
SET I=0
FOR
SET I=$ORDER(^LAM(I))
if I<1
QUIT
Begin DoDot:1
+21 IF '$DATA(^LAM(I,0))#2
KILL ^LAM(I)
QUIT
+22 if '$PIECE(^LAM(I,0),U,7)
SET $PIECE(^(0),U,7)=38
if $DATA(^LAM(I,4))
KILL ^LAM(I,4)
if '(I#50)
WRITE "."
End DoDot:1
+23 KILL ^LAM("AD")
+24 DO SPCK
+25 DO BMES^XPDUTL($$CJ^XLFSTR("** Pre Install Step Complete **",80))
+26 QUIT
PURG ;
+1 KILL DIK,DA
SET DIK="^LAB(64.81,"
SET DA=LRIEN
SET DA(1)=64.81
DO ^DIK
KILL DIK
+2 QUIT
SPCK KILL ^XTMP("LR","SPELL ERR")
+1 SET ^XTMP("LR","SPELL ERR")="LR*5.2*163 Spelling errors"
+2 DO BMES^XPDUTL($$CJ^XLFSTR("Correcting Duplicates or Spelling Errors",80))
+3 DO BMES^XPDUTL($$CJ^XLFSTR("Names that begin with 'X*' have codes that are incorrect.",80))
+4 KILL CK
SET CK=""
FOR I=1:1
SET LN=$TEXT(SPELL+I)
if $PIECE(LN,";;",2)="STOP"
QUIT
SET CK(I)=LN
+5 SET I=0
FOR
SET I=$ORDER(CK(I))
if I<1
QUIT
DO BMES^XPDUTL($$CJ^XLFSTR($PIECE(CK(I),";",3)_" "_$PIECE(CK(I),";",4),80))
+6 KILL DIC
SET DIC=64
SET DIC(0)="XNZM"
+7 SET II=0
FOR
SET II=$ORDER(CK(II))
if II<1
QUIT
Begin DoDot:1
+8 SET X=$PIECE(CK(II),";",3)_".0000"
SET NM=$PIECE(CK(II),";",4)
DO ^DIC
+9 IF Y<1
DO BMES^XPDUTL($$CJ^XLFSTR("*** Unable to find WKLD Code [ "_X_" ] in your file #64 ****",80))
QUIT
+10 ;W !,Y W:Y>1 !,Y(0)
+11 SET LNX=$PIECE(Y,U,2)
IF LNX'=NM
SET CK=1
DO FILE
End DoDot:1
+12 DO BMES^XPDUTL($$CJ^XLFSTR("Spelling updates completed.",80))
+13 QUIT
SPELL ;
+1 ;;97485;X*Hepatitis C RNA;
+2 ;;STOP
FILE ;
+1 NEW LRROOT,DA
+2 DO BMES^XPDUTL($$CJ^XLFSTR("Correcting Spelling of entry "_+Y_" from "_LNX_" to "_NM,80))
+3 SET DA=+Y
SET LRROOT(64,DA_",",.01)=NM
+4 DO FILE^DIE("","LRROOT",^XTMP("LR","SPELL ERR"))
+5 QUIT
POST ;LR*5.2*163 POST INSTALL ROUTINE KIDS INSTALL"
ENPOS ;
+1 if $DATA(^LAM(0))#2
SET $PIECE(^(0),U,3)=99999
SET $PIECE(^LAB(69.9,1,"VSIT"),U)=1
+2 DO BMES^XPDUTL($$CJ^XLFSTR("LABORATORY SITE FILE (#69.9) field PCE/VSIT ON (#615)",80))
+3 DO BMES^XPDUTL($$CJ^XLFSTR("is set to transmit CPT codes ONLY - No stop code transmission.",80))
+4 IF '$ORDER(^LAB(64.81,0))
WRITE $CHAR(7)
DO BMES^XPDUTL($$CJ^XLFSTR("No data in file # 64.81 - No linking done.",80))
GOTO MSG
+5 DO BMES^XPDUTL($$CJ^XLFSTR("** Starting CPT to NLT linking - Standby **",80))
CPT ;
+1 SET LRACTDT="MARCH 1, 1997"
WRITE !
+2 KILL DIE
SET LRIEN=0
SET DIE="^LAM("
FOR
SET LRIEN=$ORDER(^LAB(64.81,LRIEN))
if LRIEN<1
QUIT
IF $DATA(^(LRIEN,0))#2
SET DATA=^(0)
Begin DoDot:1
+3 SET LRNLT=$PIECE(DATA,U,2)
SET LRCPT=$PIECE(DATA,U,3)
SET LRRNAME=$PIECE(DATA,U,8)
+4 if 'LRNLT!('LRCPT)
QUIT
+5 if '(LRIEN#50)
WRITE "."
DO LK
End DoDot:1
IF '$PIECE(^LAB(64.81,LRIEN,0),U,9)
DO PURG
+6 IF '$ORDER(^LAB(64.81,0))
DO BMES^XPDUTL($$CJ^XLFSTR("Database Upgrade Completed Successfully",80))
GOTO MSG
+7 DO BMES^XPDUTL($$CJ^XLFSTR(" Database Upgrade is Incomplete - Use FM to print upgrade errors",80))
+8 DO BMES^XPDUTL($$CJ^XLFSTR("stored in the LAB NLT/CPT CODES (#64.81) file.",80))
MSG ;
+1 DO BMES^XPDUTL($$CJ^XLFSTR("Checking File pointer integrity",80))
+2 Begin DoDot:1
+3 SET LRI=0
FOR
SET LRI=$ORDER(^LAB(64.2,LRI))
if LRI<1
QUIT
IF $DATA(^(LRI,0))
IF '$DATA(^LAB(64.3,+$PIECE(^(0),U,14),0))
Begin DoDot:2
+4 NEW DIE,DA,DR
WRITE "."
+5 SET DR="11///1"
SET DA=LRI
SET DIE="^LAB(64.2,"
DO ^DIE
End DoDot:2
End DoDot:1
+6 Begin DoDot:1
+7 SET LRI=0
FOR
SET LRI=$ORDER(^LAM(LRI))
if LRI<1
QUIT
IF $DATA(^(LRI,0))
IF '$DATA(^LAB(64.3,+$PIECE(^(0),U,14),0))
Begin DoDot:2
+8 NEW DIE,DA,DR
WRITE "*"
+9 SET DR="12///1"
SET DA=LRI
SET DIE="^LAM("
DO ^DIE
End DoDot:2
End DoDot:1
+10 DO BMES^XPDUTL($$CJ^XLFSTR("Use 'Workload code list option [LRCAPD] for a full listing of",80))
+11 DO BMES^XPDUTL($$CJ^XLFSTR("ALL NLT Codes used in Laboratory Test File (#60).",80))
+12 DO BMES^XPDUTL($$CJ^XLFSTR("You can also use the [Edit or Print WKLD CODES] option for a listing",80))
+13 DO BMES^XPDUTL($$CJ^XLFSTR("of linked CPT linked NLT codes.",80))
+14 LOCK -^LAB(69,"AA")
+15 DO BMES^XPDUTL($$CJ^XLFSTR("** Post install completed **",80))
+16 QUIT
LK ;
+1 SET LRCODE=0
FOR
SET LRCODE=+$ORDER(^LAM("C",LRNLT_" ",LRCODE))
if LRCODE<1
QUIT
Begin DoDot:1
+2 KILL DA
SET TAG="*"
SET DA=LRCODE
IF '$DATA(^LAM(DA,0))#2
DO ERR
QUIT
+3 SET TAG="|"
IF +$PIECE(^LAM(DA,0),U,2)'[+LRNLT
DO ERR
QUIT
+4 KILL DR
DO ADD
End DoDot:1
+5 QUIT
ADD ;
+1 if $DATA(^LAM(DA,4,"B",LRCPT))
QUIT
+2 if '$PIECE($GET(^LAM(DA,0)),U,2)
QUIT
if $PIECE(^(0),U,2)'[+LRNLT
QUIT
+3 SET DA(1)=4
SET DR="18///"_LRCPT_";"
SET DR(1,64)="18///"_LRCPT
SET DR(2,64.018)=".01///"_LRCPT_";2///"_LRACTDT_";5///"_"CPT"
+4 if $GET(LRDBUG)
WRITE "DA = ",DA_" "
DO ^DIE
IF $DATA(^LAM(DA,4,"B",LRCPT))
if $GET(LRDBUG)
WRITE ". - "
QUIT
+5 SET TAG="/"
DO ERR
+6 QUIT
ERR ;
+1 if '$DATA(TAG)
SET TAG="+"
SET $PIECE(^LAB(64.81,LRIEN,0),U,9)=$PIECE(^(0),U,9)_LRNLT_TAG
+2 WRITE $CHAR(7)
DO BMES^XPDUTL($$CJ^XLFSTR("Error Processing WKLD CODE "_LRNLT_" Logged in "_LRIEN,80))
QUIT
