- 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
