LR232P ;DALOI/FHS - LR*5.2*232 POST INSTALL ROUTINE;31 -AUG-2001
;;5.2;LAB SERVICE'**232**;Sep 27, 1994
ENP ;Resolve pointers saved in XTMP("LR232",FILE#)
Q:'$D(XPDNM)
N D0,DA,DC,IEN,LR642,LRDA,LRDATA,LRENTRY,LRERR,LRFDA,LRFIELD,LRFILE
N LRGN,LRIEN,LRLKUP,LRLVL,LRMSG,LRNAME,LRNODE,LRNOP,LROUT,LRP,LRPTR,LRSUB
Q:'$G(^XTMP("LR232",1)) ; The save pointer did not go to completion
D SING(61,.09)
D SING(62.05,4)
D O628
D SING(62.85,.05)
D O682
D SING(69.6,6)
D O6964
D BMES^XPDUTL($$CJ^XLFSTR("Pointer Resolution Completed",IOM))
Q
HDR(LRFILE) ;Print file being resolved
K LRNAME,LRERR
D FILE^DID(LRFILE,"","NAME","LRNAME","LRERR")
Q:$D(LRERR)
S LRHDR="Resolving "_$S('$D(LRERR):LRNAME("NAME"),1:LRFILE)_" Pointers"
D BMES^XPDUTL($$CJ^XLFSTR(LRHDR,IOM))
D FILE^DID(LRFILE,"","GLOBAL NAME","LRGN","LRERR")
Q
SING(LRFILE,LRFIELD) ;Resolve Pointer in LRFILE (file number) by LRFIELD (field to edit)
Q:'LRFILE!'LRFIELD
D HDR(LRFILE)
I $D(LRERR) K ^XTMP("LR232",LRFILE) Q
K LRDA,LRIEN,LRNODE,LRPTR,LROUT
S LRDA=0 F S LRDA=$O(^XTMP("LR232",LRFILE,LRDA)) Q:LRDA<1 D
. I '(LRDA#500) W "*"
. K LROUT,LRMSG
. S LRPTR=$O(^XTMP("LR232",LRFILE,LRDA,0)) I 'LRPTR K ^XTMP("LR232",LRFILE,LRDA) Q
. I '$D(@(LRGN("GLOBAL NAME")_LRDA_",0)")) K ^XTMP("LR232",LRFILE,LRDA) Q
. S LRNODE=^XTMP("LR232",LRFILE,LRDA,LRPTR),LRPTR=LRPTR_","
. D GETS^DIQ(64.061,LRPTR,.01,"E","LROUT")
. I $G(LROUT(64.061,LRPTR,.01,"E"))=$P(LRNODE,U) W:$G(LRDBUG) LRPTR_" OK",! K ^XTMP("LR232",LRFILE,LRDA,+LRPTR) Q
. S LRIEN=$$IENS^DILF(.LRDA)
. K LRFDA,LRMSG,LRLKUP
. D GETNAM(LRPTR,64.061)
. D LK($P(LRNODE,U))
. I $D(LRMSG) K ^XTMP("LR232",LRFILE,+LRDA,+LRPTR) Q
. I '$G(LRLKUP("DILIST",2,1)) K ^XTMP("LR232",LRFILE,+LRDA,+LRPTR) Q
. S LRFDA(LRFILE,LRIEN,LRFIELD)=LRLKUP("DILIST",2,1)
. D BMES^XPDUTL($$LJ^XLFSTR(" Updating "_LROUT(64.061,LRPTR,.01,"E")_" to "_$P(LRNODE,U),IOM))
. D FILE^DIE("KS","LRFDA","LRMSG")
. I '$D(LRMSG) K ^XTMP("LR232",LRFILE,LRDA,+LRPTR)
Q
LK(VAL) ;Lookup specimens
D FIND^DIC(64.061,"",".01","X",VAL,"","B","","","LRLKUP","LRMSG")
Q
O628 ; Resolve pointers for LAB SHIPPING MANIFEST 62.8
K LRIEN,LRFILE S LRIEN=0,LRFILE=62.8
D HDR(LRFILE)
F S LRIEN=$O(^XTMP("LR232",LRFILE,LRIEN)) Q:LRIEN<1 D
. I '(LRIEN#500) W "*"
. K LRSUB S LRSUB=0
. F S LRSUB=$O(^XTMP("LR232",LRFILE,LRIEN,LRSUB)) Q:LRSUB<1 D
. . K LRLVL S LRLVL=0
. . S LRLVL=$O(^XTMP("LR232",LRFILE,LRIEN,LRSUB,LRLVL)) Q:LRLVL<1 D
. . K LRNODE,LRP,LRFDA,LRMSG S LRNOP=0
. . D LVL(LRLVL)
. . I $D(LRFDA) D FILE^DIE("KS","LRFDA","LRMSG")
. . I '$D(LRMSG) K ^XTMP("LR232",LRFILE,LRIEN,LRSUB)
Q
LVL(LRLVL) ;
S LRNODE=$G(^XTMP("LR232",LRFILE,LRIEN,LRSUB,LRLVL)) D
. I LRLVL=1 F LRP=3,6 S LRP(LRP)=$P(LRNODE,U,LRP) D CHK
. I LRLVL=2 F LRP=3,7,12 S LRP(LRP)=$P(LRNODE,U,LRP) D CHK
I $G(LRNOP)>1 K ^XTMP("LR232",LRFILE,LRIEN,LRSUB,LRLVL)
Q
CHK ;
N LRCHKIEN
Q:'LRP(LRP)
S LRDATA=$P(LRP(LRP),"|",2)
I '$L(LRDATA) S LRNOP=$G(LRNOP)+1 Q
S LRPTR=+LRP(LRP)_","
D GETNAM(LRPTR,64.061)
I $G(LROUT(64.061,LRPTR,.01,"E"))=$P(LRP(LRP),"|",2) W:$G(LRDBUG) LRPTR_" Ok",! S LRNOP=$G(LRNOP)+1 Q
D I 'LRDATA S LRNOP=$G(LRNOP)+1 Q
. D LK(LRDATA)
. S LRDATA=+$G(LRLKUP("DILIST",2,1))
S LRCHKIEN=LRSUB_","_LRIEN_","
I $G(LRLVL)=1,$G(LRP)=3 S LRFDA(62.801,LRCHKIEN,1.13)=LRDATA
I $G(LRLVL)=1,$G(LRP)=6 S LRFDA(62.801,LRCHKIEN,1.23)=LRDATA
I $G(LRLVL)=2,$G(LRP)=3 S LRFDA(62.801,LRCHKIEN,2.13)=LRDATA
I $G(LRLVL)=2,$G(LRP)=7 S LRFDA(62.801,LRCHKIEN,2.23)=LRDATA
I $G(LRLVL)=2,$G(LRP)=12 S LRFDA(62.801,LRCHKIEN,2.24)=LRDATA
Q
GETNAM(LRPTR,LRFILE) ;Return the external name for the code
K LROUT
D GETS^DIQ(LRFILE,LRPTR,.01,"E","LROUT")
Q
O682 ;Resolve pointer for LOAD/WORK LIST LRO(68.2
S LRFILE=68.2 D HDR(LRFILE)
S LRIEN=0
F S LRIEN=$O(^XTMP("LR232",LRFILE,LRIEN)) Q:LRIEN<1 D
. K D0,DA,DC
. S LRPTR=$O(^XTMP("LR232",LRFILE,LRIEN,0)),LRPTR=LRPTR_","
. W "*" W:$G(LRDBUG) LRPTR
. S LRNODE=$G(^XTMP("LR232",LRFILE,LRIEN,+LRPTR))
. I 'LRNODE K ^XTMP("LR232",LRFILE,LRIEN,+LRPTR) Q
. K LRFDA,LRMSG,LROUT
. S LR642=$P(LRNODE,U,3) S:LR642=".000" LR642=".0000"
. D FIND^DIC(64.2,"",".01;1","X",LR642,"","F","","","LROUT","LRMSG")
. I $O(LROUT("DILIST",1,1)) K ^XTMP("LR232",LRFILE,LRIEN,+LRPTR) Q
. I '$D(LROUT("DILIST",1,1)) K ^XTMP("LR232",LRFILE,LRIEN,+LRPTR) Q
. I $D(LRMSG) K ^XTMP("LR232",LRFILE,LRIEN,+LRPTR) Q
. I '$G(LROUT("DILIST",2,1)) K ^XTMP("LR232",LRFILE,LRIEN,+LRPTR) Q
. S (D0,DC,DA,LRFDA(68.2,LRIEN_",",.14))=LROUT("DILIST",2,1)
. D FILE^DIE("KS","LRFDA","LRMSG")
. K D0,DC,DA
. I '$D(LRMSG) K ^XTMP("LR232",LRFILE,LRIEN,+LRPTR)
Q
O6964 ;Repoint the LAB PENDING ORDER - ORDERED TEST multiple
K LRFILE,LRIEN
S LRFILE=69.6 D HDR(LRFILE) D BMES^XPDUTL($$CJ^XLFSTR("Subfile entries",IOM))
S LRIEN=0 F S LRIEN=$O(^XTMP("LR232",69.64,LRIEN)) Q:LRIEN<1 D
. I '(LRIEN#500) W "*"
. S LRSUB=0 F S LRSUB=$O(^XTMP("LR232",69.64,LRIEN,LRSUB)) Q:LRSUB<1 D
. . S LRPTR=0 F S LRPTR=$O(^XTMP("LR232",69.64,LRIEN,LRSUB,LRPTR)) Q:LRPTR<1 D
. . . I 'LRPTR K ^XTMP("LR232",69.64,LRIEN,LRSUB) Q
. . . S LRNODE=$G(^XTMP("LR232",69.64,LRIEN,LRSUB,LRPTR))
. . . D GETNAM(LRPTR_",",64.061)
. . . I $G(LROUT(64.061,LRPTR_",",.01,"E"))=$P(LRNODE,U) W:$G(LRDBUG) " OK "_LRIEN K ^XTMP("LR232",69.64,LRIEN,LRSUB,+LRPTR) Q
. . . S IEN=LRSUB_","_LRIEN_","
. . . K LRFDA,LRMSG
. . . S LRFDA(69.6,IEN,5)=$P(LRNODE,U)
. . . D FILE^DIE("EKS","LRFDA","LRMSG")
. . . I '$D(LRMSG) K ^XTMP("LR232",69.64,LRIEN,LRSUB,+LRPTR)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR232P 5582 printed Dec 13, 2024@02:03:27 Page 2
LR232P ;DALOI/FHS - LR*5.2*232 POST INSTALL ROUTINE;31 -AUG-2001
+1 ;;5.2;LAB SERVICE'**232**;Sep 27, 1994
ENP ;Resolve pointers saved in XTMP("LR232",FILE#)
+1 if '$DATA(XPDNM)
QUIT
+2 NEW D0,DA,DC,IEN,LR642,LRDA,LRDATA,LRENTRY,LRERR,LRFDA,LRFIELD,LRFILE
+3 NEW LRGN,LRIEN,LRLKUP,LRLVL,LRMSG,LRNAME,LRNODE,LRNOP,LROUT,LRP,LRPTR,LRSUB
+4 ; The save pointer did not go to completion
if '$GET(^XTMP("LR232",1))
QUIT
+5 DO SING(61,.09)
+6 DO SING(62.05,4)
+7 DO O628
+8 DO SING(62.85,.05)
+9 DO O682
+10 DO SING(69.6,6)
+11 DO O6964
+12 DO BMES^XPDUTL($$CJ^XLFSTR("Pointer Resolution Completed",IOM))
+13 QUIT
HDR(LRFILE) ;Print file being resolved
+1 KILL LRNAME,LRERR
+2 DO FILE^DID(LRFILE,"","NAME","LRNAME","LRERR")
+3 if $DATA(LRERR)
QUIT
+4 SET LRHDR="Resolving "_$SELECT('$DATA(LRERR):LRNAME("NAME"),1:LRFILE)_" Pointers"
+5 DO BMES^XPDUTL($$CJ^XLFSTR(LRHDR,IOM))
+6 DO FILE^DID(LRFILE,"","GLOBAL NAME","LRGN","LRERR")
+7 QUIT
SING(LRFILE,LRFIELD) ;Resolve Pointer in LRFILE (file number) by LRFIELD (field to edit)
+1 if 'LRFILE!'LRFIELD
QUIT
+2 DO HDR(LRFILE)
+3 IF $DATA(LRERR)
KILL ^XTMP("LR232",LRFILE)
QUIT
+4 KILL LRDA,LRIEN,LRNODE,LRPTR,LROUT
+5 SET LRDA=0
FOR
SET LRDA=$ORDER(^XTMP("LR232",LRFILE,LRDA))
if LRDA<1
QUIT
Begin DoDot:1
+6 IF '(LRDA#500)
WRITE "*"
+7 KILL LROUT,LRMSG
+8 SET LRPTR=$ORDER(^XTMP("LR232",LRFILE,LRDA,0))
IF 'LRPTR
KILL ^XTMP("LR232",LRFILE,LRDA)
QUIT
+9 IF '$DATA(@(LRGN("GLOBAL NAME")_LRDA_",0)"))
KILL ^XTMP("LR232",LRFILE,LRDA)
QUIT
+10 SET LRNODE=^XTMP("LR232",LRFILE,LRDA,LRPTR)
SET LRPTR=LRPTR_","
+11 DO GETS^DIQ(64.061,LRPTR,.01,"E","LROUT")
+12 IF $GET(LROUT(64.061,LRPTR,.01,"E"))=$PIECE(LRNODE,U)
if $GET(LRDBUG)
WRITE LRPTR_" OK",!
KILL ^XTMP("LR232",LRFILE,LRDA,+LRPTR)
QUIT
+13 SET LRIEN=$$IENS^DILF(.LRDA)
+14 KILL LRFDA,LRMSG,LRLKUP
+15 DO GETNAM(LRPTR,64.061)
+16 DO LK($PIECE(LRNODE,U))
+17 IF $DATA(LRMSG)
KILL ^XTMP("LR232",LRFILE,+LRDA,+LRPTR)
QUIT
+18 IF '$GET(LRLKUP("DILIST",2,1))
KILL ^XTMP("LR232",LRFILE,+LRDA,+LRPTR)
QUIT
+19 SET LRFDA(LRFILE,LRIEN,LRFIELD)=LRLKUP("DILIST",2,1)
+20 DO BMES^XPDUTL($$LJ^XLFSTR(" Updating "_LROUT(64.061,LRPTR,.01,"E")_" to "_$PIECE(LRNODE,U),IOM))
+21 DO FILE^DIE("KS","LRFDA","LRMSG")
+22 IF '$DATA(LRMSG)
KILL ^XTMP("LR232",LRFILE,LRDA,+LRPTR)
End DoDot:1
+23 QUIT
LK(VAL) ;Lookup specimens
+1 DO FIND^DIC(64.061,"",".01","X",VAL,"","B","","","LRLKUP","LRMSG")
+2 QUIT
O628 ; Resolve pointers for LAB SHIPPING MANIFEST 62.8
+1 KILL LRIEN,LRFILE
SET LRIEN=0
SET LRFILE=62.8
+2 DO HDR(LRFILE)
+3 FOR
SET LRIEN=$ORDER(^XTMP("LR232",LRFILE,LRIEN))
if LRIEN<1
QUIT
Begin DoDot:1
+4 IF '(LRIEN#500)
WRITE "*"
+5 KILL LRSUB
SET LRSUB=0
+6 FOR
SET LRSUB=$ORDER(^XTMP("LR232",LRFILE,LRIEN,LRSUB))
if LRSUB<1
QUIT
Begin DoDot:2
+7 KILL LRLVL
SET LRLVL=0
+8 SET LRLVL=$ORDER(^XTMP("LR232",LRFILE,LRIEN,LRSUB,LRLVL))
if LRLVL<1
QUIT
Begin DoDot:3
End DoDot:3
+9 KILL LRNODE,LRP,LRFDA,LRMSG
SET LRNOP=0
+10 DO LVL(LRLVL)
+11 IF $DATA(LRFDA)
DO FILE^DIE("KS","LRFDA","LRMSG")
+12 IF '$DATA(LRMSG)
KILL ^XTMP("LR232",LRFILE,LRIEN,LRSUB)
End DoDot:2
End DoDot:1
+13 QUIT
LVL(LRLVL) ;
+1 SET LRNODE=$GET(^XTMP("LR232",LRFILE,LRIEN,LRSUB,LRLVL))
Begin DoDot:1
+2 IF LRLVL=1
FOR LRP=3,6
SET LRP(LRP)=$PIECE(LRNODE,U,LRP)
DO CHK
+3 IF LRLVL=2
FOR LRP=3,7,12
SET LRP(LRP)=$PIECE(LRNODE,U,LRP)
DO CHK
End DoDot:1
+4 IF $GET(LRNOP)>1
KILL ^XTMP("LR232",LRFILE,LRIEN,LRSUB,LRLVL)
+5 QUIT
CHK ;
+1 NEW LRCHKIEN
+2 if 'LRP(LRP)
QUIT
+3 SET LRDATA=$PIECE(LRP(LRP),"|",2)
+4 IF '$LENGTH(LRDATA)
SET LRNOP=$GET(LRNOP)+1
QUIT
+5 SET LRPTR=+LRP(LRP)_","
+6 DO GETNAM(LRPTR,64.061)
+7 IF $GET(LROUT(64.061,LRPTR,.01,"E"))=$PIECE(LRP(LRP),"|",2)
if $GET(LRDBUG)
WRITE LRPTR_" Ok",!
SET LRNOP=$GET(LRNOP)+1
QUIT
+8 Begin DoDot:1
+9 DO LK(LRDATA)
+10 SET LRDATA=+$GET(LRLKUP("DILIST",2,1))
End DoDot:1
IF 'LRDATA
SET LRNOP=$GET(LRNOP)+1
QUIT
+11 SET LRCHKIEN=LRSUB_","_LRIEN_","
+12 IF $GET(LRLVL)=1
IF $GET(LRP)=3
SET LRFDA(62.801,LRCHKIEN,1.13)=LRDATA
+13 IF $GET(LRLVL)=1
IF $GET(LRP)=6
SET LRFDA(62.801,LRCHKIEN,1.23)=LRDATA
+14 IF $GET(LRLVL)=2
IF $GET(LRP)=3
SET LRFDA(62.801,LRCHKIEN,2.13)=LRDATA
+15 IF $GET(LRLVL)=2
IF $GET(LRP)=7
SET LRFDA(62.801,LRCHKIEN,2.23)=LRDATA
+16 IF $GET(LRLVL)=2
IF $GET(LRP)=12
SET LRFDA(62.801,LRCHKIEN,2.24)=LRDATA
+17 QUIT
GETNAM(LRPTR,LRFILE) ;Return the external name for the code
+1 KILL LROUT
+2 DO GETS^DIQ(LRFILE,LRPTR,.01,"E","LROUT")
+3 QUIT
O682 ;Resolve pointer for LOAD/WORK LIST LRO(68.2
+1 SET LRFILE=68.2
DO HDR(LRFILE)
+2 SET LRIEN=0
+3 FOR
SET LRIEN=$ORDER(^XTMP("LR232",LRFILE,LRIEN))
if LRIEN<1
QUIT
Begin DoDot:1
+4 KILL D0,DA,DC
+5 SET LRPTR=$ORDER(^XTMP("LR232",LRFILE,LRIEN,0))
SET LRPTR=LRPTR_","
+6 WRITE "*"
if $GET(LRDBUG)
WRITE LRPTR
+7 SET LRNODE=$GET(^XTMP("LR232",LRFILE,LRIEN,+LRPTR))
+8 IF 'LRNODE
KILL ^XTMP("LR232",LRFILE,LRIEN,+LRPTR)
QUIT
+9 KILL LRFDA,LRMSG,LROUT
+10 SET LR642=$PIECE(LRNODE,U,3)
if LR642=".000"
SET LR642=".0000"
+11 DO FIND^DIC(64.2,"",".01;1","X",LR642,"","F","","","LROUT","LRMSG")
+12 IF $ORDER(LROUT("DILIST",1,1))
KILL ^XTMP("LR232",LRFILE,LRIEN,+LRPTR)
QUIT
+13 IF '$DATA(LROUT("DILIST",1,1))
KILL ^XTMP("LR232",LRFILE,LRIEN,+LRPTR)
QUIT
+14 IF $DATA(LRMSG)
KILL ^XTMP("LR232",LRFILE,LRIEN,+LRPTR)
QUIT
+15 IF '$GET(LROUT("DILIST",2,1))
KILL ^XTMP("LR232",LRFILE,LRIEN,+LRPTR)
QUIT
+16 SET (D0,DC,DA,LRFDA(68.2,LRIEN_",",.14))=LROUT("DILIST",2,1)
+17 DO FILE^DIE("KS","LRFDA","LRMSG")
+18 KILL D0,DC,DA
+19 IF '$DATA(LRMSG)
KILL ^XTMP("LR232",LRFILE,LRIEN,+LRPTR)
End DoDot:1
+20 QUIT
O6964 ;Repoint the LAB PENDING ORDER - ORDERED TEST multiple
+1 KILL LRFILE,LRIEN
+2 SET LRFILE=69.6
DO HDR(LRFILE)
DO BMES^XPDUTL($$CJ^XLFSTR("Subfile entries",IOM))
+3 SET LRIEN=0
FOR
SET LRIEN=$ORDER(^XTMP("LR232",69.64,LRIEN))
if LRIEN<1
QUIT
Begin DoDot:1
+4 IF '(LRIEN#500)
WRITE "*"
+5 SET LRSUB=0
FOR
SET LRSUB=$ORDER(^XTMP("LR232",69.64,LRIEN,LRSUB))
if LRSUB<1
QUIT
Begin DoDot:2
+6 SET LRPTR=0
FOR
SET LRPTR=$ORDER(^XTMP("LR232",69.64,LRIEN,LRSUB,LRPTR))
if LRPTR<1
QUIT
Begin DoDot:3
+7 IF 'LRPTR
KILL ^XTMP("LR232",69.64,LRIEN,LRSUB)
QUIT
+8 SET LRNODE=$GET(^XTMP("LR232",69.64,LRIEN,LRSUB,LRPTR))
+9 DO GETNAM(LRPTR_",",64.061)
+10 IF $GET(LROUT(64.061,LRPTR_",",.01,"E"))=$PIECE(LRNODE,U)
if $GET(LRDBUG)
WRITE " OK "_LRIEN
KILL ^XTMP("LR232",69.64,LRIEN,LRSUB,+LRPTR)
QUIT
+11 SET IEN=LRSUB_","_LRIEN_","
+12 KILL LRFDA,LRMSG
+13 SET LRFDA(69.6,IEN,5)=$PIECE(LRNODE,U)
+14 DO FILE^DIE("EKS","LRFDA","LRMSG")
+15 IF '$DATA(LRMSG)
KILL ^XTMP("LR232",69.64,LRIEN,LRSUB,+LRPTR)
End DoDot:3
End DoDot:2
End DoDot:1
+16 QUIT
