LBRVPRE ;SSI/ALA-PreInit for patch ;[ 04/15/98 3:22 PM ]
;;2.5;Library;**2**;Mar 11, 1996
;
DD ;Remove fields from data dictionary
S DIK="^DD(680,",DA=10.7,DA(1)=680 D ^DIK
S DIK="^DD(681,",DA=1.7,DA(1)=681 D ^DIK
S DIK="^DD(681.02,",DA=.01,DA(1)=681.02 D ^DIK
S DIK="^DD(680.01,",DA(1)=680.01,DA=1 D ^DIK
S DIK="^DD(680.5,",DA=.01,DA(1)=680.5 D ^DIK
K DIK,DA
; remove FORUM data dictionaries
S DIU="^LBRL(688,",DIU(0)="D" D EN^DIU2
S DIU="^LBRL(689,",DIU(0)="D" D EN^DIU2
S DIU="^LBRL(689.1,",DIU(0)="D" D EN^DIU2
S DIU="^LBRY(687,",DIU(0)="D" D EN^DIU2
S DIU="^LBRY(687.1,",DIU(0)="D" D EN^DIU2
S DIU="^LBRY(689.2,",DIU(0)="D" D EN^DIU2
K DIU
W "."
DT ; remove data from file 680 from deleted field
S LBRD0=0
LP1 S LBRD0=$O(^LBRY(680,LBRD0)) G ON:'LBRD0
S LBRD1=0
LP2 S LBRD1=$O(^LBRY(680,LBRD0,4,LBRD1)) G LP1:'LBRD1
S ^LBRY(680,LBRD0,4,LBRD1,0)=$P(^LBRY(680,LBRD0,4,LBRD1,0),U)
G LP2
ON K TAF,DA,DIK,IND,LBRD0,LBRD1
I $$PATCH^XPDUTL("LBR*2.5*2")=1 D EN Q
STA N %
S %=$$NEWCP^XPDUTL("STNCD","STA1^LBRVPRE")
S %=$$NEWCP^XPDUTL("PRE1","EN^LBRVPRE")
S %=$$NEWCP^XPDUTL("PRE3","MUL^LBRVPRE")
S %=$$NEWCP^XPDUTL("FILE")
Q
STA1 ; Get station number
S LBRWSTA=$P($G(^XTMP("LBRV",0)),"^",3)
S %=$$UPCP^XPDUTL("STNCD",LBRWSTA)
Q
EN ; Check for type of site
; PRI = Station (also applicable for single stations)
; LEG = Legacy (applicable for stations who may move data)
N %
Q:($G(XPDQUES("PRE1"))="")
S $P(^XTMP("LBRV",0),";",2)=$G(XPDQUES("PRE1"))
S %=$$UPCP^XPDUTL("PRE1",$G(XPDQUES("PRE1")))
Q
MUL ; Multiple site set
N %
Q:'XPDQUES("PRE3")
S %=$$UPCP^XPDUTL("PRE3",$G(XPDQUES("PRE3")))
S LBRVY=XPDQUES("PRE3")
S DA=+LBRVY I $G(LBRWSTA)="" S LBRPRT=$P($G(^XTMP("LBRV",0)),"^",3),LBRWSTA=$P(LBRPRT,";",1)
S DIC="^LBRY(680.6,",DIE=DIC
S DR=".07////^S X=LBRWSTA" D ^DIE K DA,DR,DIC,DIE,LBRPRT
S %=$$UPCP^XPDUTL("FILE",LBRVY)
Q
EXIT ;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLBRVPRE 1942 printed Nov 22, 2024@17:19:54 Page 2
LBRVPRE ;SSI/ALA-PreInit for patch ;[ 04/15/98 3:22 PM ]
+1 ;;2.5;Library;**2**;Mar 11, 1996
+2 ;
DD ;Remove fields from data dictionary
+1 SET DIK="^DD(680,"
SET DA=10.7
SET DA(1)=680
DO ^DIK
+2 SET DIK="^DD(681,"
SET DA=1.7
SET DA(1)=681
DO ^DIK
+3 SET DIK="^DD(681.02,"
SET DA=.01
SET DA(1)=681.02
DO ^DIK
+4 SET DIK="^DD(680.01,"
SET DA(1)=680.01
SET DA=1
DO ^DIK
+5 SET DIK="^DD(680.5,"
SET DA=.01
SET DA(1)=680.5
DO ^DIK
+6 KILL DIK,DA
+7 ; remove FORUM data dictionaries
+8 SET DIU="^LBRL(688,"
SET DIU(0)="D"
DO EN^DIU2
+9 SET DIU="^LBRL(689,"
SET DIU(0)="D"
DO EN^DIU2
+10 SET DIU="^LBRL(689.1,"
SET DIU(0)="D"
DO EN^DIU2
+11 SET DIU="^LBRY(687,"
SET DIU(0)="D"
DO EN^DIU2
+12 SET DIU="^LBRY(687.1,"
SET DIU(0)="D"
DO EN^DIU2
+13 SET DIU="^LBRY(689.2,"
SET DIU(0)="D"
DO EN^DIU2
+14 KILL DIU
+15 WRITE "."
DT ; remove data from file 680 from deleted field
+1 SET LBRD0=0
LP1 SET LBRD0=$ORDER(^LBRY(680,LBRD0))
if 'LBRD0
GOTO ON
+1 SET LBRD1=0
LP2 SET LBRD1=$ORDER(^LBRY(680,LBRD0,4,LBRD1))
if 'LBRD1
GOTO LP1
+1 SET ^LBRY(680,LBRD0,4,LBRD1,0)=$PIECE(^LBRY(680,LBRD0,4,LBRD1,0),U)
+2 GOTO LP2
ON KILL TAF,DA,DIK,IND,LBRD0,LBRD1
+1 IF $$PATCH^XPDUTL("LBR*2.5*2")=1
DO EN
QUIT
STA NEW %
+1 SET %=$$NEWCP^XPDUTL("STNCD","STA1^LBRVPRE")
+2 SET %=$$NEWCP^XPDUTL("PRE1","EN^LBRVPRE")
+3 SET %=$$NEWCP^XPDUTL("PRE3","MUL^LBRVPRE")
+4 SET %=$$NEWCP^XPDUTL("FILE")
+5 QUIT
STA1 ; Get station number
+1 SET LBRWSTA=$PIECE($GET(^XTMP("LBRV",0)),"^",3)
+2 SET %=$$UPCP^XPDUTL("STNCD",LBRWSTA)
+3 QUIT
EN ; Check for type of site
+1 ; PRI = Station (also applicable for single stations)
+2 ; LEG = Legacy (applicable for stations who may move data)
+3 NEW %
+4 if ($GET(XPDQUES("PRE1"))="")
QUIT
+5 SET $PIECE(^XTMP("LBRV",0),";",2)=$GET(XPDQUES("PRE1"))
+6 SET %=$$UPCP^XPDUTL("PRE1",$GET(XPDQUES("PRE1")))
+7 QUIT
MUL ; Multiple site set
+1 NEW %
+2 if 'XPDQUES("PRE3")
QUIT
+3 SET %=$$UPCP^XPDUTL("PRE3",$GET(XPDQUES("PRE3")))
+4 SET LBRVY=XPDQUES("PRE3")
+5 SET DA=+LBRVY
IF $GET(LBRWSTA)=""
SET LBRPRT=$PIECE($GET(^XTMP("LBRV",0)),"^",3)
SET LBRWSTA=$PIECE(LBRPRT,";",1)
+6 SET DIC="^LBRY(680.6,"
SET DIE=DIC
+7 SET DR=".07////^S X=LBRWSTA"
DO ^DIE
KILL DA,DR,DIC,DIE,LBRPRT
+8 SET %=$$UPCP^XPDUTL("FILE",LBRVY)
+9 QUIT
EXIT ;
+1 QUIT
