LR232 ;DALOI/CKA - LR*5.2*232 PATCH ENVIRONMENT CHECK ROUTINE;31 -AUG-2001
;;5.2;LAB SERVICE;**232**;Sep 27,1994
EN ; Does not prevent loading of the transport global.
;Environment check is done only during the install.
Q:'$D(XPDENV)
D BMES^XPDUTL($$CJ^XLFSTR("*** Environment check started ***",80))
D CHECK
EXIT I $G(XPDQUIT) D BMES^XPDUTL($$CJ^XLFSTR("Install Environment Check FAILED",IOM))
I '$G(XPDQUIT) D BMES^XPDUTL($$CJ^XLFSTR("Environment Check is Ok ---",IOM))
K VER,RN,LN2
Q
CHECK I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D BMES^XPDUTL($$CJ^XLFSTR("Terminal Device is not defined",IOM)) 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 '$$ACTIVE^XUSER($G(DUZ)) D BMES^XPDUTL($$CJ^XLFSTR("You are not a valid user on this system",80)) S XPDQUIT=2
S VER=$$VERSION^XPDUTL("LR")
I VER'>5.1 D BMES^XPDUTL($$CJ^XLFSTR("You must have LAB V5.2 Installed",IOM)) S XPDQUIT=2
S VER=$$VERSION^XPDUTL("NLT")
I VER'=5.254 D BMES^XPDUTL($$CJ^XLFSTR("You must have NLT V5.254 Installed",IOM)) S XPDQUIT=2
Q
PRE ;Pre-install entry point
Q:'$D(XPDNM)
D PTRSAV ;Save pointer information
N DIU,DIK,DA
S DIU="^LAB(95.3,",DIU(0)="DST" D EN^DIU2
K DIU
S DIU="^LAB(95.31,",DIU(0)="DST" D EN^DIU2
K DIU
S DIU="^LAB(64.061,",DIU(0)="DST" D EN^DIU2
K DIU
S DIU="^LAB(64.2,",DIU(0)="DST" D EN^DIU2
K DIU
S DIU="^LAB(64.3,",DIU(0)="DST" D EN^DIU2
K DIU
S DIK="^DD(60,",DA=64.1,DA(1)=60 D ^DIK
K DIK,DA,DIU
K ^LAB(95.3),^LAB(95.31),^LAB(64.061),^LAB(64.2),^LAB(64.3)
D BMES^XPDUTL($$CJ^XLFSTR("*** Preinstall completed ***",80))
Q
POST ;
Q
PTRSAV ;Save pointer values into XTMP("LR232" to repointed after install
Q:$G(^XTMP("LR232",1)) ;indicates pointers already saved.
D BMES^XPDUTL($$CJ^XLFSTR("** Saving Pointer Values **",80))
N LRIEN,LRIENSUB,LRPTR,LRDTLB,LRNODE
S ^XTMP("LR232",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"LR232 pointer save data"
61 ;Save data from LAB(61
D BMES^XPDUTL($$CJ^XLFSTR(" Processing ^LAB(61, ",IOM))
S LRIEN=0 F S LRIEN=+$O(^LAB(61,LRIEN)) Q:LRIEN<1 I $P($G(^(LRIEN,0)),U,9) D
. S LRPTR=$P($G(^LAB(61,LRIEN,0)),U,9) Q:'LRPTR
. S ^XTMP("LR232",61,LRIEN,LRPTR)=$G(^LAB(64.061,LRPTR,0))
6205 ;Save data from LAB(62.05
D BMES^XPDUTL($$CJ^XLFSTR(" Processing ^LAB(62.05, ",IOM))
S LRIEN=0 F S LRIEN=+$O(^LAB(62.05,LRIEN)) Q:LRIEN<.01 I $P($G(^(LRIEN,0)),U,5) D
. S LRPTR=$P($G(^LAB(62.05,LRIEN,0)),U,5) Q:'LRPTR
. S ^XTMP("LR232",62.05,LRIEN,LRPTR)=$G(^LAB(64.061,LRPTR,0))
6285 ;Save date from LAHM(62.85
D BMES^XPDUTL($$CJ^XLFSTR(" Processing ^LAHM(62.85, ",IOM)) W !
S LRDTLB=$$FMADD^XLFDT(DT,-120)
S LRIEN=0 F S LRIEN=+$O(^LAHM(62.85,LRIEN)) Q:LRIEN<1 I $P($G(^(LRIEN,0)),U,5) S LRNODE=^(0) D
. I '(LRIEN#1000) W "*"
. I $P(LRNODE,U,3)<LRDTLB Q
. S LRPTR=$P($G(^LAHM(62.85,LRIEN,0)),U,5) Q:'LRPTR
. S ^XTMP("LR232",62.85,LRIEN)=$G(^LAB(64.061,LRPTR,0))
696 ;Save data from LRO(69.6
S LRDTLB=$$FMTHL7^XLFDT($$FMADD^XLFDT(DT,-120)) ;Only save the last three 3 months
D BMES^XPDUTL($$CJ^XLFSTR(" Processing ^LRO(69.6, ",IOM)) W !
S LRIEN=0 F S LRIEN=+$O(^LRO(69.6,LRIEN)) Q:LRIEN<1 S LRNODE=$G(^(LRIEN,0)) D
. I '(LRIEN#1000) W "*"
. I +$P($P(LRNODE,U,14),"-",2)<LRDTLB Q
. D
. . S LRIENSUB=0
. . F S LRIENSUB=+$O(^LRO(69.6,LRIEN,2,LRIENSUB)) Q:LRIENSUB<1 D
. . . Q:'$P($G(^LRO(69.6,LRIEN,2,LRIENSUB,0)),U,6) S LRPTR=$P(^(0),U,6)
. . . S ^XTMP("LR232",69.64,LRIEN,LRIENSUB,LRPTR)=$G(^LAB(64.061,LRPTR,0))
. S LRPTR=$P($G(^LRO(69.6,LRIEN,0)),U,10) Q:'LRPTR
. S ^XTMP("LR232",69.6,LRIEN,LRPTR)=$G(^LAB(64.061,LRPTR,0))
682 ;Save data from LRO(68.2,LRIEN,"SUF"
;Will repoint using SUF piece 3 (WKLD CODE SUFFIX) number .xxxx
D BMES^XPDUTL($$CJ^XLFSTR(" Processing ^LRO(68.2 ",IOM))
S LRIEN=0
F S LRIEN=+$O(^LRO(68.2,LRIEN)) Q:LRIEN<1 I $G(^(LRIEN,"SUF")) D
. S LRPTR=$G(^LRO(68.2,LRIEN,"SUF"))
. S ^XTMP("LR232",68.2,LRIEN,+LRPTR)=LRPTR
62801 ;Save data from LAB SHIPPING MANIFEST specimen multiple
D BMES^XPDUTL($$CJ^XLFSTR(" Processing ^LAHM(62.8 ",IOM)) W !
S LRIEN=0
F S LRIEN=+$O(^LAHM(62.8,LRIEN)) Q:LRIEN<1 D
. I '(LRIEN#500) W "*"
. S LRIENSUB=0
. F S LRIENSUB=+$O(^LAHM(62.8,LRIEN,10,LRIENSUB)) Q:LRIENSUB<1 D
. . I $D(^LAHM(62.8,LRIEN,10,LRIENSUB,1))#2 S LRSTR=^(1) D S62801(1)
. . I $D(^LAHM(62.8,LRIEN,10,LRIENSUB,2))#2 S LRSTR=^(2) D S62801(2)
S ^XTMP("LR232",1)=DT
Q
S62801(NODE) ; Resolve pointer to external
K OUT,LRS
S LRSTRP=$P(LRSTR,U,3) I LRSTRP D
. S LRSTRP=LRSTRP_","
. D GETS^DIQ(64.061,LRSTRP,.01,"E","OUT")
. I $D(OUT(64.061,LRSTRP,.01,"E")) S $P(LRSTR,U,3)=+LRSTRP_"|"_OUT(64.061,LRSTRP,.01,"E"),LRS=1
K OUT
S LRSTRP=$S(NODE=2:$P(LRSTR,U,7),NODE=2:$P(LRSTR,U,12),1:$P(LRSTR,U,6)) I LRSTRP D
. S LRSTRP=LRSTRP_","
. D GETS^DIQ(64.061,LRSTRP,.01,"E","OUT")
. I $D(OUT(64.061,LRSTRP,.01,"E")) D
. . I NODE=1 S $P(LRSTR,U,6)=+LRSTRP_"|"_OUT(64.061,LRSTRP,.01,"E"),LRS=1
. . I NODE=2 S $P(LRSTR,U,7)=+LRSTRP_"|"_OUT(64.061,LRSTRP,.01,"E"),LRS=1
. . I NODE=2 S $P(LRSTR,U,12)=+LRSTRP_"|"_OUT(64.061,LRSTRP,.01,"E"),LRS=1
I $G(LRS) S ^XTMP("LR232",62.8,LRIEN,LRIENSUB,NODE)=LRSTR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR232 5233 printed Dec 13, 2024@02:03:26 Page 2
LR232 ;DALOI/CKA - LR*5.2*232 PATCH ENVIRONMENT CHECK ROUTINE;31 -AUG-2001
+1 ;;5.2;LAB SERVICE;**232**;Sep 27,1994
EN ; Does not prevent loading of the transport global.
+1 ;Environment check is done only during the install.
+2 if '$DATA(XPDENV)
QUIT
+3 DO BMES^XPDUTL($$CJ^XLFSTR("*** Environment check started ***",80))
+4 DO CHECK
EXIT IF $GET(XPDQUIT)
DO BMES^XPDUTL($$CJ^XLFSTR("Install Environment Check FAILED",IOM))
+1 IF '$GET(XPDQUIT)
DO BMES^XPDUTL($$CJ^XLFSTR("Environment Check is Ok ---",IOM))
+2 KILL VER,RN,LN2
+3 QUIT
CHECK IF $SELECT('$GET(IOM):1,'$GET(IOSL):1,$GET(U)'="^":1,1:0)
DO BMES^XPDUTL($$CJ^XLFSTR("Terminal Device is not defined",IOM))
SET XPDQUIT=2
+1 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
+2 IF '$$ACTIVE^XUSER($GET(DUZ))
DO BMES^XPDUTL($$CJ^XLFSTR("You are not a valid user on this system",80))
SET XPDQUIT=2
+3 SET VER=$$VERSION^XPDUTL("LR")
+4 IF VER'>5.1
DO BMES^XPDUTL($$CJ^XLFSTR("You must have LAB V5.2 Installed",IOM))
SET XPDQUIT=2
+5 SET VER=$$VERSION^XPDUTL("NLT")
+6 IF VER'=5.254
DO BMES^XPDUTL($$CJ^XLFSTR("You must have NLT V5.254 Installed",IOM))
SET XPDQUIT=2
+7 QUIT
PRE ;Pre-install entry point
+1 if '$DATA(XPDNM)
QUIT
+2 ;Save pointer information
DO PTRSAV
+3 NEW DIU,DIK,DA
+4 SET DIU="^LAB(95.3,"
SET DIU(0)="DST"
DO EN^DIU2
+5 KILL DIU
+6 SET DIU="^LAB(95.31,"
SET DIU(0)="DST"
DO EN^DIU2
+7 KILL DIU
+8 SET DIU="^LAB(64.061,"
SET DIU(0)="DST"
DO EN^DIU2
+9 KILL DIU
+10 SET DIU="^LAB(64.2,"
SET DIU(0)="DST"
DO EN^DIU2
+11 KILL DIU
+12 SET DIU="^LAB(64.3,"
SET DIU(0)="DST"
DO EN^DIU2
+13 KILL DIU
+14 SET DIK="^DD(60,"
SET DA=64.1
SET DA(1)=60
DO ^DIK
+15 KILL DIK,DA,DIU
+16 KILL ^LAB(95.3),^LAB(95.31),^LAB(64.061),^LAB(64.2),^LAB(64.3)
+17 DO BMES^XPDUTL($$CJ^XLFSTR("*** Preinstall completed ***",80))
+18 QUIT
POST ;
+1 QUIT
PTRSAV ;Save pointer values into XTMP("LR232" to repointed after install
+1 ;indicates pointers already saved.
if $GET(^XTMP("LR232",1))
QUIT
+2 DO BMES^XPDUTL($$CJ^XLFSTR("** Saving Pointer Values **",80))
+3 NEW LRIEN,LRIENSUB,LRPTR,LRDTLB,LRNODE
+4 SET ^XTMP("LR232",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"LR232 pointer save data"
61 ;Save data from LAB(61
+1 DO BMES^XPDUTL($$CJ^XLFSTR(" Processing ^LAB(61, ",IOM))
+2 SET LRIEN=0
FOR
SET LRIEN=+$ORDER(^LAB(61,LRIEN))
if LRIEN<1
QUIT
IF $PIECE($GET(^(LRIEN,0)),U,9)
Begin DoDot:1
+3 SET LRPTR=$PIECE($GET(^LAB(61,LRIEN,0)),U,9)
if 'LRPTR
QUIT
+4 SET ^XTMP("LR232",61,LRIEN,LRPTR)=$GET(^LAB(64.061,LRPTR,0))
End DoDot:1
6205 ;Save data from LAB(62.05
+1 DO BMES^XPDUTL($$CJ^XLFSTR(" Processing ^LAB(62.05, ",IOM))
+2 SET LRIEN=0
FOR
SET LRIEN=+$ORDER(^LAB(62.05,LRIEN))
if LRIEN<.01
QUIT
IF $PIECE($GET(^(LRIEN,0)),U,5)
Begin DoDot:1
+3 SET LRPTR=$PIECE($GET(^LAB(62.05,LRIEN,0)),U,5)
if 'LRPTR
QUIT
+4 SET ^XTMP("LR232",62.05,LRIEN,LRPTR)=$GET(^LAB(64.061,LRPTR,0))
End DoDot:1
6285 ;Save date from LAHM(62.85
+1 DO BMES^XPDUTL($$CJ^XLFSTR(" Processing ^LAHM(62.85, ",IOM))
WRITE !
+2 SET LRDTLB=$$FMADD^XLFDT(DT,-120)
+3 SET LRIEN=0
FOR
SET LRIEN=+$ORDER(^LAHM(62.85,LRIEN))
if LRIEN<1
QUIT
IF $PIECE($GET(^(LRIEN,0)),U,5)
SET LRNODE=^(0)
Begin DoDot:1
+4 IF '(LRIEN#1000)
WRITE "*"
+5 IF $PIECE(LRNODE,U,3)<LRDTLB
QUIT
+6 SET LRPTR=$PIECE($GET(^LAHM(62.85,LRIEN,0)),U,5)
if 'LRPTR
QUIT
+7 SET ^XTMP("LR232",62.85,LRIEN)=$GET(^LAB(64.061,LRPTR,0))
End DoDot:1
696 ;Save data from LRO(69.6
+1 ;Only save the last three 3 months
SET LRDTLB=$$FMTHL7^XLFDT($$FMADD^XLFDT(DT,-120))
+2 DO BMES^XPDUTL($$CJ^XLFSTR(" Processing ^LRO(69.6, ",IOM))
WRITE !
+3 SET LRIEN=0
FOR
SET LRIEN=+$ORDER(^LRO(69.6,LRIEN))
if LRIEN<1
QUIT
SET LRNODE=$GET(^(LRIEN,0))
Begin DoDot:1
+4 IF '(LRIEN#1000)
WRITE "*"
+5 IF +$PIECE($PIECE(LRNODE,U,14),"-",2)<LRDTLB
QUIT
+6 Begin DoDot:2
+7 SET LRIENSUB=0
+8 FOR
SET LRIENSUB=+$ORDER(^LRO(69.6,LRIEN,2,LRIENSUB))
if LRIENSUB<1
QUIT
Begin DoDot:3
+9 if '$PIECE($GET(^LRO(69.6,LRIEN,2,LRIENSUB,0)),U,6)
QUIT
SET LRPTR=$PIECE(^(0),U,6)
+10 SET ^XTMP("LR232",69.64,LRIEN,LRIENSUB,LRPTR)=$GET(^LAB(64.061,LRPTR,0))
End DoDot:3
End DoDot:2
+11 SET LRPTR=$PIECE($GET(^LRO(69.6,LRIEN,0)),U,10)
if 'LRPTR
QUIT
+12 SET ^XTMP("LR232",69.6,LRIEN,LRPTR)=$GET(^LAB(64.061,LRPTR,0))
End DoDot:1
682 ;Save data from LRO(68.2,LRIEN,"SUF"
+1 ;Will repoint using SUF piece 3 (WKLD CODE SUFFIX) number .xxxx
+2 DO BMES^XPDUTL($$CJ^XLFSTR(" Processing ^LRO(68.2 ",IOM))
+3 SET LRIEN=0
+4 FOR
SET LRIEN=+$ORDER(^LRO(68.2,LRIEN))
if LRIEN<1
QUIT
IF $GET(^(LRIEN,"SUF"))
Begin DoDot:1
+5 SET LRPTR=$GET(^LRO(68.2,LRIEN,"SUF"))
+6 SET ^XTMP("LR232",68.2,LRIEN,+LRPTR)=LRPTR
End DoDot:1
62801 ;Save data from LAB SHIPPING MANIFEST specimen multiple
+1 DO BMES^XPDUTL($$CJ^XLFSTR(" Processing ^LAHM(62.8 ",IOM))
WRITE !
+2 SET LRIEN=0
+3 FOR
SET LRIEN=+$ORDER(^LAHM(62.8,LRIEN))
if LRIEN<1
QUIT
Begin DoDot:1
+4 IF '(LRIEN#500)
WRITE "*"
+5 SET LRIENSUB=0
+6 FOR
SET LRIENSUB=+$ORDER(^LAHM(62.8,LRIEN,10,LRIENSUB))
if LRIENSUB<1
QUIT
Begin DoDot:2
+7 IF $DATA(^LAHM(62.8,LRIEN,10,LRIENSUB,1))#2
SET LRSTR=^(1)
DO S62801(1)
+8 IF $DATA(^LAHM(62.8,LRIEN,10,LRIENSUB,2))#2
SET LRSTR=^(2)
DO S62801(2)
End DoDot:2
End DoDot:1
+9 SET ^XTMP("LR232",1)=DT
+10 QUIT
S62801(NODE) ; Resolve pointer to external
+1 KILL OUT,LRS
+2 SET LRSTRP=$PIECE(LRSTR,U,3)
IF LRSTRP
Begin DoDot:1
+3 SET LRSTRP=LRSTRP_","
+4 DO GETS^DIQ(64.061,LRSTRP,.01,"E","OUT")
+5 IF $DATA(OUT(64.061,LRSTRP,.01,"E"))
SET $PIECE(LRSTR,U,3)=+LRSTRP_"|"_OUT(64.061,LRSTRP,.01,"E")
SET LRS=1
End DoDot:1
+6 KILL OUT
+7 SET LRSTRP=$SELECT(NODE=2:$PIECE(LRSTR,U,7),NODE=2:$PIECE(LRSTR,U,12),1:$PIECE(LRSTR,U,6))
IF LRSTRP
Begin DoDot:1
+8 SET LRSTRP=LRSTRP_","
+9 DO GETS^DIQ(64.061,LRSTRP,.01,"E","OUT")
+10 IF $DATA(OUT(64.061,LRSTRP,.01,"E"))
Begin DoDot:2
+11 IF NODE=1
SET $PIECE(LRSTR,U,6)=+LRSTRP_"|"_OUT(64.061,LRSTRP,.01,"E")
SET LRS=1
+12 IF NODE=2
SET $PIECE(LRSTR,U,7)=+LRSTRP_"|"_OUT(64.061,LRSTRP,.01,"E")
SET LRS=1
+13 IF NODE=2
SET $PIECE(LRSTR,U,12)=+LRSTRP_"|"_OUT(64.061,LRSTRP,.01,"E")
SET LRS=1
End DoDot:2
End DoDot:1
+14 IF $GET(LRS)
SET ^XTMP("LR232",62.8,LRIEN,LRIENSUB,NODE)=LRSTR
+15 QUIT
