PXRMEXRP ;SLC/AGP - Re-pack protocol. ;Aug 20, 2019@09:57
;;2.0;CLINICAL REMINDERS;**45**;Feb 04, 2005;Build 566
;==========================
Q
;
EN(IEN,FAIL,NOTINLM) ;
N CLOK,FILES,NAME,RESULTS,SELLIST
S NAME=$P($G(^PXD(811.8,IEN,0)),U)
D FULL^VALM1
W !,"Repacking entry: "_NAME
S RESULTS("NAME")=NAME
D FILELIST(.FILES)
I $D(^PXD(811.8,IEN,120)) D PROC120(.RESULTS,.FILES,IEN,.FAIL) I FAIL=1 W !,"Could not repack exchange entry "_NAME H 2 Q
I '$D(^PXD(811.8,IEN,120)) D
.S CLOK=1
.I '$D(^PXD(811.8,PXRMRIEN,120)) D CLIST^PXRMEXCO(IEN,.CLOK)
.I 'CLOK S FAIL=1 Q
.D PROC120(.RESULTS,.FILES,IEN,.FAIL)
I FAIL=1 W !,"Could not repack exchange entry "_NAME H 2 Q
D SELLIST(.RESULTS,.SELLIST)
I '$D(SELLIST) W !,"Could not repack exchange entry "_NAME S FAIL=1 H 2 Q
;I $D(SELLIST) D CRE^PXRMEXPD(.SELLIST)
I $D(SELLIST) D CRE^PXRMEXPD(.SELLIST,NAME,NOTINLM)
Q
;
FILELIST(FILELST) ;
S FILELST(811.4)=""
S FILELST(810.8)=""
S FILELST(811.9)=""
S FILELST(801.41)=""
S FILELST(810.7)=""
S FILELST(810.2)=""
S FILELST(810.4)=""
S FILELST(810.9)=""
S FILELST(811.6)=""
S FILELST(811.2)=""
S FILELST(811.5)=""
S FILELST(801)=""
S FILELST(801.1)=""
Q
;
PROC120(RESULTS,FILES,IEN,FAIL) ;
N ERR,FILE,IDX,ITEM,NAME,NODE,NUM,SEL
S IDX=0 F S IDX=$O(^PXD(811.8,IEN,120,IDX)) Q:IDX'>0!(FAIL=1) D
.S NODE=$G(^PXD(811.8,IEN,120,IDX,0))
.S FILE=+$P(NODE,U,2)
.I '$D(FILES(FILE)) Q
.S NUM=0 F S NUM=$O(^PXD(811.8,IEN,120,IDX,1,NUM)) Q:NUM'>0!(FAIL=1) D
..S NODE=$G(^PXD(811.8,IEN,120,IDX,1,NUM,0))
..S NAME=$P(NODE,U)
..S ITEM=$$FIND1^DIC(FILE,"","X",NAME,,,"ERR")
..I ITEM=0 W !,"Could not find "_$$GET1^DID(FILE,"","","NAME")_" entry: "_NAME S FAIL=1 Q
..I $D(ERR) S FAIL=1 D AWRITE^PXRMUTIL("ERR") Q
..I $P(NODE,U,7)=0 Q
..S RESULTS("FILES",FILE,ITEM)=""
Q
;
SELLIST(RESULTS,SELLIST) ;
N FILE,IEN,NUMF,RANK
D PACKORD^PXRMEXPD(.RANK)
S FILE=0 F S FILE=$O(RESULTS("FILES",FILE)) Q:FILE'>0 D
.S IEN=0,NUMF=0 F S IEN=$O(RESULTS("FILES",FILE,IEN)) Q:IEN'>0 D
..S NUMF=NUMF+1
..S SELLIST(FILE,NUMF)=IEN
..S SELLIST(FILE,"IEN",IEN)=NUMF
Q
;
SELECT ;
N FAIL,IND,LIST,LNUM,PXRMNAT,PXRMRIEN
;Get the list to install.
S LIST=$$GETLIST^PXRMEXLR()
;If there is no list quit.
I LIST="^" S VALMBCK="R" Q
S FAIL=0
F IND=1:1:$L(LIST,",")-1 Q:FAIL=1 D
. S LNUM=$P(LIST,",",IND)
.;Get the repository IEN.
. S PXRMRIEN=$$RIEN^PXRMEXU1(LNUM)
. D EN(PXRMRIEN,.FAIL,0)
S VALMBCK="R"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMEXRP 2513 printed Dec 13, 2024@01:45:13 Page 2
PXRMEXRP ;SLC/AGP - Re-pack protocol. ;Aug 20, 2019@09:57
+1 ;;2.0;CLINICAL REMINDERS;**45**;Feb 04, 2005;Build 566
+2 ;==========================
+3 QUIT
+4 ;
EN(IEN,FAIL,NOTINLM) ;
+1 NEW CLOK,FILES,NAME,RESULTS,SELLIST
+2 SET NAME=$PIECE($GET(^PXD(811.8,IEN,0)),U)
+3 DO FULL^VALM1
+4 WRITE !,"Repacking entry: "_NAME
+5 SET RESULTS("NAME")=NAME
+6 DO FILELIST(.FILES)
+7 IF $DATA(^PXD(811.8,IEN,120))
DO PROC120(.RESULTS,.FILES,IEN,.FAIL)
IF FAIL=1
WRITE !,"Could not repack exchange entry "_NAME
HANG 2
QUIT
+8 IF '$DATA(^PXD(811.8,IEN,120))
Begin DoDot:1
+9 SET CLOK=1
+10 IF '$DATA(^PXD(811.8,PXRMRIEN,120))
DO CLIST^PXRMEXCO(IEN,.CLOK)
+11 IF 'CLOK
SET FAIL=1
QUIT
+12 DO PROC120(.RESULTS,.FILES,IEN,.FAIL)
End DoDot:1
+13 IF FAIL=1
WRITE !,"Could not repack exchange entry "_NAME
HANG 2
QUIT
+14 DO SELLIST(.RESULTS,.SELLIST)
+15 IF '$DATA(SELLIST)
WRITE !,"Could not repack exchange entry "_NAME
SET FAIL=1
HANG 2
QUIT
+16 ;I $D(SELLIST) D CRE^PXRMEXPD(.SELLIST)
+17 IF $DATA(SELLIST)
DO CRE^PXRMEXPD(.SELLIST,NAME,NOTINLM)
+18 QUIT
+19 ;
FILELIST(FILELST) ;
+1 SET FILELST(811.4)=""
+2 SET FILELST(810.8)=""
+3 SET FILELST(811.9)=""
+4 SET FILELST(801.41)=""
+5 SET FILELST(810.7)=""
+6 SET FILELST(810.2)=""
+7 SET FILELST(810.4)=""
+8 SET FILELST(810.9)=""
+9 SET FILELST(811.6)=""
+10 SET FILELST(811.2)=""
+11 SET FILELST(811.5)=""
+12 SET FILELST(801)=""
+13 SET FILELST(801.1)=""
+14 QUIT
+15 ;
PROC120(RESULTS,FILES,IEN,FAIL) ;
+1 NEW ERR,FILE,IDX,ITEM,NAME,NODE,NUM,SEL
+2 SET IDX=0
FOR
SET IDX=$ORDER(^PXD(811.8,IEN,120,IDX))
if IDX'>0!(FAIL=1)
QUIT
Begin DoDot:1
+3 SET NODE=$GET(^PXD(811.8,IEN,120,IDX,0))
+4 SET FILE=+$PIECE(NODE,U,2)
+5 IF '$DATA(FILES(FILE))
QUIT
+6 SET NUM=0
FOR
SET NUM=$ORDER(^PXD(811.8,IEN,120,IDX,1,NUM))
if NUM'>0!(FAIL=1)
QUIT
Begin DoDot:2
+7 SET NODE=$GET(^PXD(811.8,IEN,120,IDX,1,NUM,0))
+8 SET NAME=$PIECE(NODE,U)
+9 SET ITEM=$$FIND1^DIC(FILE,"","X",NAME,,,"ERR")
+10 IF ITEM=0
WRITE !,"Could not find "_$$GET1^DID(FILE,"","","NAME")_" entry: "_NAME
SET FAIL=1
QUIT
+11 IF $DATA(ERR)
SET FAIL=1
DO AWRITE^PXRMUTIL("ERR")
QUIT
+12 IF $PIECE(NODE,U,7)=0
QUIT
+13 SET RESULTS("FILES",FILE,ITEM)=""
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
SELLIST(RESULTS,SELLIST) ;
+1 NEW FILE,IEN,NUMF,RANK
+2 DO PACKORD^PXRMEXPD(.RANK)
+3 SET FILE=0
FOR
SET FILE=$ORDER(RESULTS("FILES",FILE))
if FILE'>0
QUIT
Begin DoDot:1
+4 SET IEN=0
SET NUMF=0
FOR
SET IEN=$ORDER(RESULTS("FILES",FILE,IEN))
if IEN'>0
QUIT
Begin DoDot:2
+5 SET NUMF=NUMF+1
+6 SET SELLIST(FILE,NUMF)=IEN
+7 SET SELLIST(FILE,"IEN",IEN)=NUMF
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
SELECT ;
+1 NEW FAIL,IND,LIST,LNUM,PXRMNAT,PXRMRIEN
+2 ;Get the list to install.
+3 SET LIST=$$GETLIST^PXRMEXLR()
+4 ;If there is no list quit.
+5 IF LIST="^"
SET VALMBCK="R"
QUIT
+6 SET FAIL=0
+7 FOR IND=1:1:$LENGTH(LIST,",")-1
if FAIL=1
QUIT
Begin DoDot:1
+8 SET LNUM=$PIECE(LIST,",",IND)
+9 ;Get the repository IEN.
+10 SET PXRMRIEN=$$RIEN^PXRMEXU1(LNUM)
+11 DO EN(PXRMRIEN,.FAIL,0)
End DoDot:1
+12 SET VALMBCK="R"
+13 QUIT
+14 ;
