LBRVPOST ;SSI/ALA-Post Library Patch Clean-Up ;[ 04/15/98 3:45 PM ]
;;2.5;Library;**2**;Mar 11, 1996
S %=$$PARCP^XPDUTL("PRE1","PRE")
I %=0 K % D RC G EXIT
K X,DIK,DA
STA N %
S %=$$NEWCP^XPDUTL("MOVE","MOV^LBRVPOST")
INDX ;reindex cross-references for File#680.6
F LBRDI="B","C" K ^LBRY(680.6,LBRDI)
S DIK="^LBRY(680.6," D IXALL^DIK
FIL ; File the site into the data files
S %=$$PARCP^XPDUTL("FILE","PRE"),LBRVY=%
F LBRDI=680,681,682 D D MES^XPDUTL("File "_LBRDI_" done.") K DA,DR,DIC,DIE
. S DIC="^LBRY("_LBRDI_",",DA=0
. S DR=".04////^S X=LBRVY"
. F S DA=$O(^LBRY(LBRDI,DA)) Q:'DA S DIE=DIC D ^DIE W:DA#100=0 "."
K DA,DR,DIC,DIE,LBRDI
S DR=".02////^S X=LBRVY",DIC="^LBRY(680.7,",DIE=DIC,DA=0
F S DA=$O(^LBRY(680.7,DA)) Q:'DA D ^DIE W:DA#10=0 "."
K DA,DR,DIC,DIE
S DR="1////^S X=LBRVY",DIC="^LBRY(680.4,",DIE=DIC,DA=0
F S DA=$O(^LBRY(680.4,DA)) Q:'DA D ^DIE W:DA#10=0 "."
K DA,DR,DIC,DIE
Q
MOV ; Move data into scratch file if appropriate
S %=$$PARCP^XPDUTL("PRE1","PRE"),LBRFL=%
S LBRWSTA=$$PARCP^XPDUTL("STNCD","PRE")
CV I LBRFL="LEG" D
. S LBRVDT=$$FMADD^XLFDT(DT,7)
. S ^XTMP("LBRY",0)=LBRVDT_"^"_DT
. S ^XTMP("LBRY",LBRWSTA)=LBRWSTA
. D ^LBRVCONV
. D RC
. D MES^XPDUTL("You are now ready to move your data to the primary system.")
. D MES^XPDUTL("Please move temporary global, ^XTMP(""LBRY"" to correct directory and install LBR*2.5*3.")
I LBRFL="PRI" D RC
G EXIT
RC ; Find bad records
S DIK="^LBRY(681,",DA=0 W "."
F S DA=$O(^LBRY(681,DA)) Q:'DA D
. S TAF=$P(^LBRY(681,DA,0),U,2)
. I TAF="" D ^DIK Q
. I '$D(^LBRY(680,TAF)) D ^DIK
S DIK="^LBRY(682,",DA=0 W "."
F S DA=$O(^LBRY(682,DA)) Q:'DA D
. S TAF=$P(^LBRY(682,DA,0),U,2)
. I TAF="" D ^DIK Q
. I '$D(^LBRY(680,TAF)) D ^DIK
S DIK="^LBRY(682.1,",DA="" W "."
F S DA=$O(^LBRY(682.1,DA)) Q:DA=0 D
. K ^LBRY(682.1,DA)
F IND="AA","AC","AD","B","C" K ^LBRY(682.1,IND)
D IXALL^DIK
W "."
REINDX ; re-indexing of all cross-references
D MES^XPDUTL("I am now re-indexing all cross-references")
W !
F J=680,681,682,680.4,680.7,680.3,680.5 S LX="A" F S LX=$O(^LBRY(J,LX)) Q:LX="" K ^LBRY(J,LX)
F DIK="^LBRY(680,","^LBRY(681,","^LBRY(682,","^LBRY(680.4,","^LBRY(680.7,","^LBRY(680.3,","^LBRY(680.5," D
. W DIK,! D IXALL^DIK
Q
EXIT K DA,DIC,LBRVY,LBRDI,DIE,DR,LFLG,LBRWSTA,LSTN,GSTN,LBRWSTN,LBRFL,CKDA
K LBRVDT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLBRVPOST 2397 printed Dec 13, 2024@02:09:49 Page 2
LBRVPOST ;SSI/ALA-Post Library Patch Clean-Up ;[ 04/15/98 3:45 PM ]
+1 ;;2.5;Library;**2**;Mar 11, 1996
+2 SET %=$$PARCP^XPDUTL("PRE1","PRE")
+3 IF %=0
KILL %
DO RC
GOTO EXIT
+4 KILL X,DIK,DA
STA NEW %
+1 SET %=$$NEWCP^XPDUTL("MOVE","MOV^LBRVPOST")
INDX ;reindex cross-references for File#680.6
+1 FOR LBRDI="B","C"
KILL ^LBRY(680.6,LBRDI)
+2 SET DIK="^LBRY(680.6,"
DO IXALL^DIK
FIL ; File the site into the data files
+1 SET %=$$PARCP^XPDUTL("FILE","PRE")
SET LBRVY=%
+2 FOR LBRDI=680,681,682
Begin DoDot:1
+3 SET DIC="^LBRY("_LBRDI_","
SET DA=0
+4 SET DR=".04////^S X=LBRVY"
+5 FOR
SET DA=$ORDER(^LBRY(LBRDI,DA))
if 'DA
QUIT
SET DIE=DIC
DO ^DIE
if DA#100=0
WRITE "."
End DoDot:1
DO MES^XPDUTL("File "_LBRDI_" done.")
KILL DA,DR,DIC,DIE
+6 KILL DA,DR,DIC,DIE,LBRDI
+7 SET DR=".02////^S X=LBRVY"
SET DIC="^LBRY(680.7,"
SET DIE=DIC
SET DA=0
+8 FOR
SET DA=$ORDER(^LBRY(680.7,DA))
if 'DA
QUIT
DO ^DIE
if DA#10=0
WRITE "."
+9 KILL DA,DR,DIC,DIE
+10 SET DR="1////^S X=LBRVY"
SET DIC="^LBRY(680.4,"
SET DIE=DIC
SET DA=0
+11 FOR
SET DA=$ORDER(^LBRY(680.4,DA))
if 'DA
QUIT
DO ^DIE
if DA#10=0
WRITE "."
+12 KILL DA,DR,DIC,DIE
+13 QUIT
MOV ; Move data into scratch file if appropriate
+1 SET %=$$PARCP^XPDUTL("PRE1","PRE")
SET LBRFL=%
+2 SET LBRWSTA=$$PARCP^XPDUTL("STNCD","PRE")
CV IF LBRFL="LEG"
Begin DoDot:1
+1 SET LBRVDT=$$FMADD^XLFDT(DT,7)
+2 SET ^XTMP("LBRY",0)=LBRVDT_"^"_DT
+3 SET ^XTMP("LBRY",LBRWSTA)=LBRWSTA
+4 DO ^LBRVCONV
+5 DO RC
+6 DO MES^XPDUTL("You are now ready to move your data to the primary system.")
+7 DO MES^XPDUTL("Please move temporary global, ^XTMP(""LBRY"" to correct directory and install LBR*2.5*3.")
End DoDot:1
+8 IF LBRFL="PRI"
DO RC
+9 GOTO EXIT
RC ; Find bad records
+1 SET DIK="^LBRY(681,"
SET DA=0
WRITE "."
+2 FOR
SET DA=$ORDER(^LBRY(681,DA))
if 'DA
QUIT
Begin DoDot:1
+3 SET TAF=$PIECE(^LBRY(681,DA,0),U,2)
+4 IF TAF=""
DO ^DIK
QUIT
+5 IF '$DATA(^LBRY(680,TAF))
DO ^DIK
End DoDot:1
+6 SET DIK="^LBRY(682,"
SET DA=0
WRITE "."
+7 FOR
SET DA=$ORDER(^LBRY(682,DA))
if 'DA
QUIT
Begin DoDot:1
+8 SET TAF=$PIECE(^LBRY(682,DA,0),U,2)
+9 IF TAF=""
DO ^DIK
QUIT
+10 IF '$DATA(^LBRY(680,TAF))
DO ^DIK
End DoDot:1
+11 SET DIK="^LBRY(682.1,"
SET DA=""
WRITE "."
+12 FOR
SET DA=$ORDER(^LBRY(682.1,DA))
if DA=0
QUIT
Begin DoDot:1
+13 KILL ^LBRY(682.1,DA)
End DoDot:1
+14 FOR IND="AA","AC","AD","B","C"
KILL ^LBRY(682.1,IND)
+15 DO IXALL^DIK
+16 WRITE "."
REINDX ; re-indexing of all cross-references
+1 DO MES^XPDUTL("I am now re-indexing all cross-references")
+2 WRITE !
+3 FOR J=680,681,682,680.4,680.7,680.3,680.5
SET LX="A"
FOR
SET LX=$ORDER(^LBRY(J,LX))
if LX=""
QUIT
KILL ^LBRY(J,LX)
+4 FOR DIK="^LBRY(680,","^LBRY(681,","^LBRY(682,","^LBRY(680.4,","^LBRY(680.7,","^LBRY(680.3,","^LBRY(680.5,"
Begin DoDot:1
+5 WRITE DIK,!
DO IXALL^DIK
End DoDot:1
+6 QUIT
EXIT KILL DA,DIC,LBRVY,LBRDI,DIE,DR,LFLG,LBRWSTA,LSTN,GSTN,LBRWSTN,LBRFL,CKDA
+1 KILL LBRVDT
+2 QUIT
