LR210 ;DALISC/FHS - LR*5.2*210 PATCH ENVIRONMENT CHECK ROUTINE
;;5.2T8;LR;**1018**;Oct 27, 2004
;;5.2;LAB SERVICE;**210**;Sep 27, 1994
EN ;
Q:'$G(XPDENV)
L +^LAM:15 I '$T D BMES^XPDUTL($$CJ^XLFSTR(" Unable to successfully lock the ^LAM global. ",80)) S XPDQUIT=2
L +^LRO(69,"AA"):15 I '$T D BMES^XPDUTL($$CJ^XLFSTR(" Unable to successfully lock the ^LRO(69,AA) global. ",80)) S XPDQUIT=2
I '$D(^LAM(0))#2 D BMES^XPDUTL($$CJ^XLFSTR("There is no WKLD CODE file.",80)) S XPDQUIT=2
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018 ALPHA ONLY??
;I $$VERSION^XPDUTL("ICPT")'="6.0" D BMES^XPDUTL($$CJ^XLFSTR("You must install ICPT V6.0 Package first.",80)) S XPDQUIT=2
;----- END IHS MODIFICATIONS
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"),-^LAM
I '$G(XPDQUIT) D BMES^XPDUTL($$CJ^XLFSTR("Environment Check is Ok ---",80))
Q
PRE ;AFTER USER COMMITS ROUTINE KIDS INSTALL"
Q:'$D(XPDNM)
S:$D(^LAM(0))#2 $P(^LAM(0),U,3)=2225
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 X="TRAP^LR210",@^%ZOSF("TRAP")
D BMES^XPDUTL($$CJ^XLFSTR("** Pre Install Step Complete **",80))
Q
POST ;Post cleanup
N $ESTACK,$ETRAP
S $ETRAP="D ERROR^LR210"
K ^XTMP("LR","NLT")
S ^XTMP("LR","NLT")="LR*5.2*210 Spelling errors"
S ^XTMP("LR","NLT",0)=$$FMADD^XLFDT(DT,7)_U_$$NOW^XLFDT_U_DUZ
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))
;
N DIC,DA
S LR81=0,LRFILE=64,LRERFILE="^XTMP(""LR"",""NLT"")"
F S LR81=$O(^LAB(64.81,LR81)) Q:LR81<1 D
. S LRNODE=$G(^LAB(64.81,LR81,0)) Q:LRNODE=""
. S LRLKNM=$P(LRNODE,U),LRNAME=$S($L($P(LRNODE,U,8)):$P(LRNODE,U,8),1:LRLKNM)
. S LRLKCODE=$P(LRNODE,U,2),LRCODE=$P(LRNODE,U,3)
. S LRCK=$S(LRLKCODE:1,LRCODE:1,$L(LRLKNM):1,1:0) Q:'LRCK
. W:$G(LRDBUG) !,LRLKNM,?30,LRNAME,!,LRLKCODE,?30,LRCODE
. K DIC,DA S DIC="^LAM(",DIC(0)="ZOXMN"
. S LRCK=0,X=LRLKCODE,DIC("S")="I $P(^(0),U)="""_LRLKNM_"""" D ^DIC
. I Y<1 D PURG Q
. I Y>0 S LRDA=+Y W ! D
. . I LRLKNM'=LRNAME D
. . . D BMES^XPDUTL($$CJ^XLFSTR("Correcting Spelling of entry ^(LAM,"_LRDA_") from ",80))
. . . D BMES^XPDUTL($$CJ^XLFSTR(LRLKNM_" to "_LRNAME,80))
. . . S LRFD=.01,LRDATA=$E(LRNAME,1,60),DA=LRDA
. . . S LRCK=$$FILE(LRDA,LRFILE,LRFD,LRDATA,LRERFILE)
. . . I LRCK D BMES^XPDUTL($$CJ^XLFSTR("*** An "_$P(LRCK,U,2)_" error has occured ***",80)) D Q
. . . . S $P(^LAB(64.81,LR81,0),U,9)=$E(LRCK,1,19)
. . . D BMES^XPDUTL($$CJ^XLFSTR("Name change successful",80))
. . I LRLKCODE'=LRCODE D
. . . D BMES^XPDUTL($$CJ^XLFSTR("Correcting NLT Code of entry ^LAM("_LRDA_") from ",80))
. . . D BMES^XPDUTL($$CJ^XLFSTR(LRLKCODE_" to "_LRCODE,80))
. . . S LRFD=1,LRDATA=LRCODE,DA=LRDA
. . . S LRCK=$$FILE(LRDA,LRFILE,LRFD,LRDATA,LRERFILE)
. . . I LRCK D BMES^XPDUTL($$CJ^XLFSTR("*** An "_$P(LRCK,U,2)_" error has occured ***",80)) D Q
. . . . S $P(^LAB(64.81,LR81,0),U,9)=$E(LRCK,1,19)
. . . D BMES^XPDUTL($$CJ^XLFSTR("NLT Code change successful",80))
. . I '$G(LRCK),$G(LR81) D PURG
D BMES^XPDUTL($$CJ^XLFSTR("Spelling/Code Numbers update is complete.",80))
ENPOS ;NLT CODE UPGRADE POST INSTALL ROUTINE KIDS INSTALL"
;
I '$O(^LAB(64.81,0)) D BMES^XPDUTL($$CJ^XLFSTR("Database Upgrade Completed Successfully",80)) K ^XTMP("LR","NLT") G MSG
W ! D BMES^XPDUTL($$CJ^XLFSTR(" ****************************** ",80))
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))
D BMES^XPDUTL($$CJ^XLFSTR(" ****************************** ",80)) W !
MSG 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))
S I=0 F S I=$O(^LAM(I)) Q:I<1 I $O(^LAM(I,4,0)) D
. S II=0 F S II=$O(^LAM(I,4,II)) Q:II<1 D
. . I $P($G(^LAM(I,4,II,0)),U,2)="CPT",'$P(^(0),U,3) S $P(^(0),U,3)=2980301
D BMES^XPDUTL($$CJ^XLFSTR("** Post install completed **",80))
END S:$D(^LAM(0))#2 $P(^(0),U,3)=99999 S $P(^LAB(69.9,1,"VSIT"),U)=1
L -^LAB(69,"AA"),-^LAM Q
ERROR D END,UNWIND^%ZTER
Q
PURG ;
N DIK,DA
S DIK="^LAB(64.81,",DA=LR81 D ^DIK K DIK
Q
FILE(DA,FILE,FIELD,DATA,ERR) ;
; Utility call to FILE^DIE database call. Can be used to update uneditable fields.
;DA= to the IEN of the node to update
;FILE = The file number containing the DA
;FIELD = Set to the field number of the file
;DATA = Is equal to the new value of the FIELD
;ERR (Optional) = The global to store any errors from the FILE^DIE
;ERROR is returned - I successful = 0 Failure = 1~_error text
; there maybe more that one error but only the first is reported
N LRROOT
I '+DA!('$L(FILE))!('FIELD)!(DATA="") Q "1~Calling error"
S LRROOT(FILE,+DA_",",FIELD)=DATA
D FILE^DIE("","LRROOT",ERR)
S ERROR=0 I $D(DIERR),ERR]"" S ERROR="1~"_$TR(@ERR@("DIERR",1,"TEXT",1),"^","~")
Q ERROR
LR210 ;DALISC/FHS - LR*5.2*210 PATCH ENVIRONMENT CHECK ROUTINE
+1 ;;5.2T8;LR;**1018**;Oct 27, 2004
+2 ;;5.2;LAB SERVICE;**210**;Sep 27, 1994
EN ;
+1 IF '$GET(XPDENV)
QUIT
+2 LOCK +^LAM:15
IF '$TEST
DO BMES^XPDUTL($$CJ^XLFSTR(" Unable to successfully lock the ^LAM global. ",80))
SET XPDQUIT=2
+3 LOCK +^LRO(69,"AA"):15
IF '$TEST
DO BMES^XPDUTL($$CJ^XLFSTR(" Unable to successfully lock the ^LRO(69,AA) global. ",80))
SET XPDQUIT=2
+4 IF '$DATA(^LAM(0))#2
DO BMES^XPDUTL($$CJ^XLFSTR("There is no WKLD CODE file.",80))
SET XPDQUIT=2
+5 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018 ALPHA ONLY??
+6 ;I $$VERSION^XPDUTL("ICPT")'="6.0" D BMES^XPDUTL($$CJ^XLFSTR("You must install ICPT V6.0 Package first.",80)) S XPDQUIT=2
+7 ;----- END IHS MODIFICATIONS
+8 IF '$ORDER(^LAM(0))
DO BMES^XPDUTL($$CJ^XLFSTR("There is no data in your WKLD CODE file.",80))
SET XPDQUIT=2
+9 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
+10 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
+11 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
+12 IF +$GET(^LAM("VR"))'>5.1
DO BMES^XPDUTL($$CJ^XLFSTR("You must have LAB V5.2 or greater Installed.",80))
SET XPDQUIT=2
+13 IF $GET(XPDQUIT)
DO BMES^XPDUTL($$CJ^XLFSTR("Install environment check FAILED.",80))
LOCK -^LRO(69,"AA"),-^LAM
+14 IF '$GET(XPDQUIT)
DO BMES^XPDUTL($$CJ^XLFSTR("Environment Check is Ok ---",80))
+15 QUIT
PRE ;AFTER USER COMMITS ROUTINE KIDS INSTALL"
+1 IF '$DATA(XPDNM)
QUIT
+2 IF $DATA(^LAM(0))#2
SET $PIECE(^LAM(0),U,3)=2225
+3 IF $DATA(^LAB(64.81,0))#2
SET X=$PIECE(^(0),U,1,2)
KILL ^LAB(64.81)
SET ^LAB(64.81,0)=X
+4 SET X="TRAP^LR210"
SET @^%ZOSF("TRAP")
+5 DO BMES^XPDUTL($$CJ^XLFSTR("** Pre Install Step Complete **",80))
+6 QUIT
POST ;Post cleanup
+1 NEW $ESTACK,$ETRAP
+2 SET $ETRAP="D ERROR^LR210"
+3 KILL ^XTMP("LR","NLT")
+4 SET ^XTMP("LR","NLT")="LR*5.2*210 Spelling errors"
+5 SET ^XTMP("LR","NLT",0)=$$FMADD^XLFDT(DT,7)_U_$$NOW^XLFDT_U_DUZ
+6 DO BMES^XPDUTL($$CJ^XLFSTR("Correcting Duplicates or Spelling Errors",80))
+7 DO BMES^XPDUTL($$CJ^XLFSTR("Names that begin with 'X*' have codes that are incorrect.",80))
+8 ;
+9 NEW DIC,DA
+10 SET LR81=0
SET LRFILE=64
SET LRERFILE="^XTMP(""LR"",""NLT"")"
+11 FOR
SET LR81=$ORDER(^LAB(64.81,LR81))
IF LR81<1
QUIT
Begin DoDot:1
+12 SET LRNODE=$GET(^LAB(64.81,LR81,0))
IF LRNODE=""
QUIT
+13 SET LRLKNM=$PIECE(LRNODE,U)
SET LRNAME=$SELECT($LENGTH($PIECE(LRNODE,U,8)):$PIECE(LRNODE,U,8),1:LRLKNM)
+14 SET LRLKCODE=$PIECE(LRNODE,U,2)
SET LRCODE=$PIECE(LRNODE,U,3)
+15 SET LRCK=$SELECT(LRLKCODE:1,LRCODE:1,$LENGTH(LRLKNM):1,1:0)
IF 'LRCK
QUIT
+16 IF $GET(LRDBUG)
WRITE !,LRLKNM,?30,LRNAME,!,LRLKCODE,?30,LRCODE
+17 KILL DIC,DA
SET DIC="^LAM("
SET DIC(0)="ZOXMN"
+18 SET LRCK=0
SET X=LRLKCODE
SET DIC("S")="I $P(^(0),U)="""_LRLKNM_""""
DO ^DIC
+19 IF Y<1
DO PURG
QUIT
+20 IF Y>0
SET LRDA=+Y
WRITE !
Begin DoDot:2
+21 IF LRLKNM'=LRNAME
Begin DoDot:3
+22 DO BMES^XPDUTL($$CJ^XLFSTR("Correcting Spelling of entry ^(LAM,"_LRDA_") from ",80))
+23 DO BMES^XPDUTL($$CJ^XLFSTR(LRLKNM_" to "_LRNAME,80))
+24 SET LRFD=.01
SET LRDATA=$EXTRACT(LRNAME,1,60)
SET DA=LRDA
+25 SET LRCK=$$FILE(LRDA,LRFILE,LRFD,LRDATA,LRERFILE)
+26 IF LRCK
DO BMES^XPDUTL($$CJ^XLFSTR("*** An "_$PIECE(LRCK,U,2)_" error has occured ***",80))
Begin DoDot:4
+27 SET $PIECE(^LAB(64.81,LR81,0),U,9)=$EXTRACT(LRCK,1,19)
End DoDot:4
QUIT
+28 DO BMES^XPDUTL($$CJ^XLFSTR("Name change successful",80))
End DoDot:3
+29 IF LRLKCODE'=LRCODE
Begin DoDot:3
+30 DO BMES^XPDUTL($$CJ^XLFSTR("Correcting NLT Code of entry ^LAM("_LRDA_") from ",80))
+31 DO BMES^XPDUTL($$CJ^XLFSTR(LRLKCODE_" to "_LRCODE,80))
+32 SET LRFD=1
SET LRDATA=LRCODE
SET DA=LRDA
+33 SET LRCK=$$FILE(LRDA,LRFILE,LRFD,LRDATA,LRERFILE)
+34 IF LRCK
DO BMES^XPDUTL($$CJ^XLFSTR("*** An "_$PIECE(LRCK,U,2)_" error has occured ***",80))
Begin DoDot:4
+35 SET $PIECE(^LAB(64.81,LR81,0),U,9)=$EXTRACT(LRCK,1,19)
End DoDot:4
QUIT
+36 DO BMES^XPDUTL($$CJ^XLFSTR("NLT Code change successful",80))
End DoDot:3
+37 IF '$GET(LRCK)
IF $GET(LR81)
DO PURG
End DoDot:2
End DoDot:1
+38 DO BMES^XPDUTL($$CJ^XLFSTR("Spelling/Code Numbers update is complete.",80))
ENPOS ;NLT CODE UPGRADE POST INSTALL ROUTINE KIDS INSTALL"
+1 ;
+2 IF '$ORDER(^LAB(64.81,0))
DO BMES^XPDUTL($$CJ^XLFSTR("Database Upgrade Completed Successfully",80))
KILL ^XTMP("LR","NLT")
GOTO MSG
+3 WRITE !
DO BMES^XPDUTL($$CJ^XLFSTR(" ****************************** ",80))
+4 DO BMES^XPDUTL($$CJ^XLFSTR(" Database Upgrade is Incomplete - Use FM to print upgrade errors",80))
+5 DO BMES^XPDUTL($$CJ^XLFSTR("stored in the LAB NLT/CPT CODES (#64.81) file.",80))
+6 DO BMES^XPDUTL($$CJ^XLFSTR(" ****************************** ",80))
WRITE !
MSG DO BMES^XPDUTL($$CJ^XLFSTR("Use 'Workload code list option [LRCAPD] for a full listing of",80))
+1 DO BMES^XPDUTL($$CJ^XLFSTR("ALL NLT Codes used in Laboratory Test File (#60).",80))
+2 DO BMES^XPDUTL($$CJ^XLFSTR("You can also use the [Edit or Print WKLD CODES] option for a listing",80))
+3 DO BMES^XPDUTL($$CJ^XLFSTR("of linked CPT linked NLT codes.",80))
+4 SET I=0
FOR
SET I=$ORDER(^LAM(I))
IF I<1
QUIT
IF $ORDER(^LAM(I,4,0))
Begin DoDot:1
+5 SET II=0
FOR
SET II=$ORDER(^LAM(I,4,II))
IF II<1
QUIT
Begin DoDot:2
+6 IF $PIECE($GET(^LAM(I,4,II,0)),U,2)="CPT"
IF '$PIECE(^(0),U,3)
SET $PIECE(^(0),U,3)=2980301
End DoDot:2
End DoDot:1
+7 DO BMES^XPDUTL($$CJ^XLFSTR("** Post install completed **",80))
END IF $DATA(^LAM(0))#2
SET $PIECE(^(0),U,3)=99999
SET $PIECE(^LAB(69.9,1,"VSIT"),U)=1
+1 LOCK -^LAB(69,"AA"),-^LAM
QUIT
ERROR DO END
DO UNWIND^%ZTER
+1 QUIT
PURG ;
+1 NEW DIK,DA
+2 SET DIK="^LAB(64.81,"
SET DA=LR81
DO ^DIK
KILL DIK
+3 QUIT
FILE(DA,FILE,FIELD,DATA,ERR) ;
+1 ; Utility call to FILE^DIE database call. Can be used to update uneditable fields.
+2 ;DA= to the IEN of the node to update
+3 ;FILE = The file number containing the DA
+4 ;FIELD = Set to the field number of the file
+5 ;DATA = Is equal to the new value of the FIELD
+6 ;ERR (Optional) = The global to store any errors from the FILE^DIE
+7 ;ERROR is returned - I successful = 0 Failure = 1~_error text
+8 ; there maybe more that one error but only the first is reported
+9 NEW LRROOT
+10 IF '+DA!('$LENGTH(FILE))!('FIELD)!(DATA="")
QUIT "1~Calling error"
+11 SET LRROOT(FILE,+DA_",",FIELD)=DATA
+12 DO FILE^DIE("","LRROOT",ERR)
+13 SET ERROR=0
IF $DATA(DIERR)
IF ERR]""
SET ERROR="1~"_$TRANSLATE(@ERR@("DIERR",1,"TEXT",1),"^","~")
+14 QUIT ERROR
