- CIAVINX ;MSC/IND/DKM - Pretransportation routines for KIDS ;15-Feb-2008 09:25;DKM
- ;;1.1V2;VUECENTRIC FRAMEWORK;;Mar 20, 2007
- ;;Copyright 2000-2006, Medsphere Systems Corporation
- ;=================================================================
- ; Pre-transportation for export
- EXPPRET N TGT,SUB,FIL,IEN
- S TGT=$$TGT(1),SUB=0
- Q:'TGT
- S @XPDGREF@("EXP")=$$GET1^DIQ(19930.99,TGT,.01)_U_$$GET1^DIQ(19930.99,TGT,.5)
- F S SUB=$O(^CIAVDIST(TGT,SUB)) Q:'SUB S FIL=+$P($G(^(SUB,0)),U,2) D:FIL
- .S FIL=+$P($P(^DD(FIL,.01,0),U,2),"P",2),IEN=0
- .Q:'FIL
- .S @XPDGREF@("EXP",SUB)=FIL
- .F S IEN=$O(^CIAVDIST(TGT,SUB,IEN)) Q:'IEN D
- ..S @XPDGREF@("EXP",SUB,IEN)=$$GET1^DIQ(FIL,IEN,.01)
- Q
- ; Post-init for export
- EXPPOST N TGT,SUB,FIL,IEN,VAL,NEW,BLD,DIK,DA
- S TGT=$G(@XPDGREF@("EXP")),BLD=$P(TGT,U,2)
- S TGT=$$FIND1^DIC(19930.99,,"X",$P(TGT,U))
- Q:'TGT
- S BLD=$$FIND1^DIC(9.6,,"X",BLD)
- S $P(^CIAVDIST(TGT,0),U,2)=$S(BLD:BLD,1:""),SUB=0
- F S SUB=$O(@XPDGREF@("EXP",SUB)) Q:'SUB S FIL=^(SUB) D
- .N SAV
- .M SAV=^CIAVDIST(TGT,SUB)
- .Q:'$D(SAV(0))
- .K SAV("B")
- .K ^CIAVDIST(TGT,SUB)
- .S ^CIAVDIST(TGT,SUB,0)=SAV(0),IEN=0
- .F S IEN=$O(@XPDGREF@("EXP",SUB,IEN)) Q:'IEN S VAL=^(IEN) D
- ..S NEW=$$FIND1^DIC(FIL,,"X",VAL)
- ..I 'NEW W "Unable to resolve entry: ",VAL,!! Q
- ..S $P(SAV(IEN,0),U)=NEW
- ..M ^CIAVDIST(TGT,SUB,NEW)=SAV(IEN)
- S DIK="^CIAVDIST(",DA=TGT
- D IX^DIK
- Q
- ; Pre-transportation for components
- GBL N C,M,P,V,X,X1,Y,Z,DIST,OBJ
- S DIST=$$TGT,C=0
- ; Save pointer mappings for multiples with .01 field pointers
- ; since KIDS doesn't resolve these. (Doesn't work with DINUM)
- D GBLX(19930.2,19930.2,19930.221,9,1)
- D GBLX(19930.21,19930.2,19930.206,2,1)
- D GBLX(19.1,19930.2,19330.204,3,1)
- D GBLX(19.1,19941.21,19941.212,20,5)
- D GBLX(19.1,19941.21,19941.2121,21,5)
- ; Save object code for selected routines
- F X=0:0 S X=$O(^CIAVDIST(DIST,6,X)) Q:'X D
- .S Y=$$GET1^DIQ(9.8,X,.01)
- .Q:'$L(Y)
- .F X1=0:0 S X1=$O(^CIAVDIST(DIST,6,X,1,X1)) Q:'X1 S V=^(X1,0) D
- ..S M=+V,V=$P(V,U,2)
- ..M @XPDGREF@("OBJ",M,V,Y)=^CIAVDIST(DIST,6,X,1,X1,1)
- ; Save initial values for exported parameters.
- F X=0:0 S X=$O(^CIAVDIST(DIST,2,X)) Q:'X D
- .S P=$P(^XTV(8989.51,X,0),U)
- .F Y=0:0 S Y=$O(^CIAVDIST(DIST,2,X,1,Y)) Q:'Y K Z M Z=^(Y) D
- ..K Z(2,0)
- ..S C=C+1
- ..M @XPDGREF@("PARAM",C)=Z(2)
- ..S @XPDGREF@("PARAM",C)=P_U_Z(0)_U_$G(Z(1))
- ; Set rename flag for any object aliases and overwrite for
- ; categories, keys, and/or initializations
- F X=0:0 S X=$O(^CIAVDIST(DIST,1,X)) Q:'X D
- .S P=$P(^CIAVOBJ(19930.2,X,0),U),Z=^CIAVDIST(DIST,1,X,0)
- .F Y=0:0 S Y=$O(^CIAVOBJ(19930.2,X,10,Y)) Q:'Y D RENAME(^(Y,0),P)
- .F Y=2,3,4 S:$P(Z,U,Y) @XPDGREF@("OVERWRITE",P,$S(Y=4:5,1:Y))=""
- ; Additional settings
- S @XPDGREF@("INITIAL")=$G(^CIAVDIST(DIST,50))
- S @XPDGREF@("FINAL")=$G(^CIAVDIST(DIST,51))
- S @XPDGREF@("EC")=$G(^CIAVDIST(DIST,53))
- X $G(^CIAVDIST(DIST,52))
- Q
- ; EP - Export object code for routines
- EXPOBJ N MSYS,GBL,OBJ,VER,RTN,X
- W "Export Object Code for Selected Routines",!!
- X ^%ZOSF("RSEL")
- W !!
- Q:$O(^UTILITY($J,$C(1)))=""
- D ^%ZIS
- Q:POP
- U IO
- S MSYS=$$UP^XLFSTR($P($$VERSION^%ZOSV(1)," "))
- S VER=$TR($$VERSION^%ZOSV()," "),RTN=$C(1)
- W MSYS_U_VER,!
- F S RTN=$O(^UTILITY($J,RTN)) Q:'$L(RTN) D
- .S OBJ=""
- .W RTN,!
- .D EXPC:MSYS="CACHE",EXPJ:MSYS="JUMPS",EXPG:MSYS="GTM"
- .W !
- W "**END**",!
- D ^%ZISC
- Q
- ; Export a Cache binary
- EXPC S OBJ=$$ENCODE^CIAUUU(^rOBJ(RTN))
- F Q:OBJ="" D
- .W $E(OBJ,1,75),!
- .S OBJ=$E(OBJ,76,999999)
- Q
- ; Export a JUMPS binary
- EXPJ S OBJ=^$R(RTN,"OBJECT")
- F Q:OBJ="" D
- .S X=$F(OBJ,$C(10))
- .S:'X X=$L(OBJ)+2
- .W $E(OBJ,1,X-2),!
- .S OBJ=$E(OBJ,X,999999)
- Q
- ; Export a GTM binary
- EXPG W "GTM export not yet supported.",!!
- Q
- ; Import object code into distribution
- IMPOBJ N MSYS,VER,RTN,DIST,FIL,OBJ,QUIT,D1,X
- W "Import Object Code into a Distribution",!!
- S DIST=$$LOOKUP(19930.99,"Distribution")
- Q:'DIST
- R "Object code file: ",FIL,!!
- Q:U[FIL
- D CLOSEALL^CIAUOS,OPEN^CIAUOS(.FIL,"R")
- U FIL
- R X
- S MSYS=$P(X,U),VER=$P(X,U,2),OBJ=""
- S MSYS(0)=$S(MSYS="CACHE":1,MSYS="JUMPS":2,1:0)
- U IO(0)
- W "Target "_MSYS_" Version: "_VER_"// "
- R X,!
- S:$L(X) VER=X
- F U FIL R RTN Q:RTN="**END**" D Q:$D(QUIT)
- .N FDA,IENS,CNT,DATA
- .U IO(0)
- .W ?5,"Importing routine ",RTN,"...",!
- .S RTN(0)=$O(^DIC(9.8,"B",RTN,0))
- .I 'RTN(0) S QUIT=1 Q
- .F D1=0:0 S D1=$O(^CIAVDIST(DIST,6,RTN(0),1,"B",MSYS(0),D1)) Q:'D1 D Q:$L(X)
- ..S X=$P(^CIAVDIST(DIST,6,RTN(0),1,D1,0),U,2),VER(0)=X
- ..F Q:X=VER S X=$P(X,".",1,$L(X,".")-1) Q:'$L(X)
- .S:'D1 VER(0)=VER
- .S D1=$S(D1:D1,1:"+1")
- .S IENS=D1_","_RTN(0)_","_DIST_",",CNT=0
- .U FIL
- .F R X Q:X="" S CNT=CNT+1,DATA(CNT,0)=X
- .S FDA(19930.9961,IENS,.01)=MSYS(0)
- .S FDA(19930.9961,IENS,.5)=VER(0)
- .S FDA(19930.9961,IENS,1)="DATA"
- .D UPDATE^DIE(,"FDA")
- D CLOSE^CIAUOS(FIL)
- W:$D(QUIT) "Routine "_RTN_" not found. Import aborted.",!!
- Q
- ; Lookup an entry in file #FN using prompt PM.
- LOOKUP(FN,PM,FL,SC) ;
- Q:'FN -1
- N DIC,DLAYGO,X,Y
- W !
- F FL=''$G(FL):-1:0 D
- .S DIC=FN,DIC(0)=$S(FL:"E",1:"AE"),DIC("A")=PM_": ",X="??"
- .S:$L($G(SC)) DIC("S")=SC
- .D ^DIC
- W !
- Q $S(Y>0:+Y,1:0)
- GBLX(TGT,SRC,SUB,NOD,TYP) ;
- N K,X,Y,Z
- S @XPDGREF@("PTRS",SUB)=NOD_U_SRC_U_TGT
- S TGT=$$ROOT^DILFD(TGT,,1),SRC=$$ROOT^DILFD(SRC,,1),X=0
- F S X=$O(@SRC@(X)) Q:'X S Y=$P(^(X,0),U),Z=0 D:$$SCRN(X,TYP)
- .S @XPDGREF@("PTRS",SUB,Y)=""
- .F S Z=$O(@SRC@(X,NOD,Z)) Q:'Z S K=+$G(^(Z,0)) D:K
- ..S K=$P($G(@TGT@(K,0)),U)
- ..S:$L(K) @XPDGREF@("PTRS",SUB,Y,K)=""
- Q
- ; Set progid's to be renamed
- RENAME(OLD,NEW) ;
- S OLD=$TR(OLD," ")
- S:$L(OLD) @XPDGREF@("RENAME",OLD,NEW)=""
- Q
- ; Set target distribution (user is prompted if necessary)
- ; If NOSCN is set, selection will not be screened.
- TGT(NOSCN) ;EP
- N DIC,Y
- Q:$G(XPDERR) 0
- S Y=+$G(@XPDGREF@("TGT"))
- Q:Y>0 Y
- S Y=$O(^CIAVDIST("C",XPDA,0))
- I Y,'$O(^CIAVDIST("C",XPDA,Y)) W "Target distribution: ",$P(^CIAVDIST(Y,0),U)
- E D
- .S DIC=19930.99,DIC(0)="AEF",DIC("A")="Enter target distribution: "
- .S:'$G(NOSCN) DIC("S")="I $P(^(0),U,2)=XPDA"
- .D ^DIC
- .S Y=+Y
- W !!
- I Y<1 S XPDERR=1,Y=0
- E S @XPDGREF@("TGT")=Y
- Q Y
- ; Screen entries
- ; IEN = Entry to screen
- ; TYP = 1: Object Registry
- ; 2: Parameter Definition
- ; 3: Parameter Template
- ; 4: Template Registry
- ; 5: Event Type
- ; 6: Routine
- ; 7: Object Category
- ; Returns true if entry is to be included.
- SCRN(IEN,TYP) ;
- Q:'$G(TYP) 1
- Q $D(^CIAVDIST($$TGT,TYP,IEN))
- CIAVINX ;MSC/IND/DKM - Pretransportation routines for KIDS ;15-Feb-2008 09:25;DKM
- +1 ;;1.1V2;VUECENTRIC FRAMEWORK;;Mar 20, 2007
- +2 ;;Copyright 2000-2006, Medsphere Systems Corporation
- +3 ;=================================================================
- +4 ; Pre-transportation for export
- EXPPRET NEW TGT,SUB,FIL,IEN
- +1 SET TGT=$$TGT(1)
- SET SUB=0
- +2 IF 'TGT
- QUIT
- +3 SET @XPDGREF@("EXP")=$$GET1^DIQ(19930.99,TGT,.01)_U_$$GET1^DIQ(19930.99,TGT,.5)
- +4 FOR
- SET SUB=$ORDER(^CIAVDIST(TGT,SUB))
- IF 'SUB
- QUIT
- SET FIL=+$PIECE($GET(^(SUB,0)),U,2)
- IF FIL
- Begin DoDot:1
- +5 SET FIL=+$PIECE($PIECE(^DD(FIL,.01,0),U,2),"P",2)
- SET IEN=0
- +6 IF 'FIL
- QUIT
- +7 SET @XPDGREF@("EXP",SUB)=FIL
- +8 FOR
- SET IEN=$ORDER(^CIAVDIST(TGT,SUB,IEN))
- IF 'IEN
- QUIT
- Begin DoDot:2
- +9 SET @XPDGREF@("EXP",SUB,IEN)=$$GET1^DIQ(FIL,IEN,.01)
- End DoDot:2
- End DoDot:1
- +10 QUIT
- +11 ; Post-init for export
- EXPPOST NEW TGT,SUB,FIL,IEN,VAL,NEW,BLD,DIK,DA
- +1 SET TGT=$GET(@XPDGREF@("EXP"))
- SET BLD=$PIECE(TGT,U,2)
- +2 SET TGT=$$FIND1^DIC(19930.99,,"X",$PIECE(TGT,U))
- +3 IF 'TGT
- QUIT
- +4 SET BLD=$$FIND1^DIC(9.6,,"X",BLD)
- +5 SET $PIECE(^CIAVDIST(TGT,0),U,2)=$SELECT(BLD:BLD,1:"")
- SET SUB=0
- +6 FOR
- SET SUB=$ORDER(@XPDGREF@("EXP",SUB))
- IF 'SUB
QUIT
SET FIL=^(SUB)
Begin DoDot:1
+7 NEW SAV
+8 MERGE SAV=^CIAVDIST(TGT,SUB)
+9 IF '$DATA(SAV(0))
QUIT
+10 KILL SAV("B")
+11 KILL ^CIAVDIST(TGT,SUB)
+12 SET ^CIAVDIST(TGT,SUB,0)=SAV(0)
SET IEN=0
+13 FOR
SET IEN=$ORDER(@XPDGREF@("EXP",SUB,IEN))
IF 'IEN
QUIT
SET VAL=^(IEN)
Begin DoDot:2
+14 SET NEW=$$FIND1^DIC(FIL,,"X",VAL)
+15 IF 'NEW
WRITE "Unable to resolve entry: ",VAL,!!
QUIT
+16 SET $PIECE(SAV(IEN,0),U)=NEW
+17 MERGE ^CIAVDIST(TGT,SUB,NEW)=SAV(IEN)
End DoDot:2
End DoDot:1
+18 SET DIK="^CIAVDIST("
SET DA=TGT
+19 DO IX^DIK
+20 QUIT
+21 ; Pre-transportation for components
GBL NEW C,M,P,V,X,X1,Y,Z,DIST,OBJ
+1 SET DIST=$$TGT
SET C=0
+2 ; Save pointer mappings for multiples with .01 field pointers
+3 ; since KIDS doesn't resolve these. (Doesn't work with DINUM)
+4 DO GBLX(19930.2,19930.2,19930.221,9,1)
+5 DO GBLX(19930.21,19930.2,19930.206,2,1)
+6 DO GBLX(19.1,19930.2,19330.204,3,1)
+7 DO GBLX(19.1,19941.21,19941.212,20,5)
+8 DO GBLX(19.1,19941.21,19941.2121,21,5)
+9 ; Save object code for selected routines
+10 FOR X=0:0
SET X=$ORDER(^CIAVDIST(DIST,6,X))
IF 'X
QUIT
Begin DoDot:1
+11 SET Y=$$GET1^DIQ(9.8,X,.01)
+12 IF '$LENGTH(Y)
QUIT
+13 FOR X1=0:0
SET X1=$ORDER(^CIAVDIST(DIST,6,X,1,X1))
IF 'X1
QUIT
SET V=^(X1,0)
Begin DoDot:2
+14 SET M=+V
SET V=$PIECE(V,U,2)
+15 MERGE @XPDGREF@("OBJ",M,V,Y)=^CIAVDIST(DIST,6,X,1,X1,1)
End DoDot:2
End DoDot:1
+16 ; Save initial values for exported parameters.
+17 FOR X=0:0
SET X=$ORDER(^CIAVDIST(DIST,2,X))
IF 'X
QUIT
Begin DoDot:1
+18 SET P=$PIECE(^XTV(8989.51,X,0),U)
+19 FOR Y=0:0
SET Y=$ORDER(^CIAVDIST(DIST,2,X,1,Y))
IF 'Y
QUIT
KILL Z
MERGE Z=^(Y)
Begin DoDot:2
+20 KILL Z(2,0)
+21 SET C=C+1
+22 MERGE @XPDGREF@("PARAM",C)=Z(2)
+23 SET @XPDGREF@("PARAM",C)=P_U_Z(0)_U_$GET(Z(1))
End DoDot:2
End DoDot:1
+24 ; Set rename flag for any object aliases and overwrite for
+25 ; categories, keys, and/or initializations
+26 FOR X=0:0
SET X=$ORDER(^CIAVDIST(DIST,1,X))
IF 'X
QUIT
Begin DoDot:1
+27 SET P=$PIECE(^CIAVOBJ(19930.2,X,0),U)
SET Z=^CIAVDIST(DIST,1,X,0)
+28 FOR Y=0:0
SET Y=$ORDER(^CIAVOBJ(19930.2,X,10,Y))
IF 'Y
QUIT
DO RENAME(^(Y,0),P)
+29 FOR Y=2,3,4
IF $PIECE(Z,U,Y)
SET @XPDGREF@("OVERWRITE",P,$SELECT(Y=4:5,1:Y))=""
End DoDot:1
+30 ; Additional settings
+31 SET @XPDGREF@("INITIAL")=$GET(^CIAVDIST(DIST,50))
+32 SET @XPDGREF@("FINAL")=$GET(^CIAVDIST(DIST,51))
+33 SET @XPDGREF@("EC")=$GET(^CIAVDIST(DIST,53))
+34 XECUTE $GET(^CIAVDIST(DIST,52))
+35 QUIT
+36 ; EP - Export object code for routines
EXPOBJ NEW MSYS,GBL,OBJ,VER,RTN,X
+1 WRITE "Export Object Code for Selected Routines",!!
+2 XECUTE ^%ZOSF("RSEL")
+3 WRITE !!
+4 IF $ORDER(^UTILITY($JOB,$CHAR(1)))=""
QUIT
+5 DO ^%ZIS
+6 IF POP
QUIT
+7 USE IO
+8 SET MSYS=$$UP^XLFSTR($PIECE($$VERSION^%ZOSV(1)," "))
+9 SET VER=$TRANSLATE($$VERSION^%ZOSV()," ")
SET RTN=$CHAR(1)
+10 WRITE MSYS_U_VER,!
+11 FOR
SET RTN=$ORDER(^UTILITY($JOB,RTN))
IF '$LENGTH(RTN)
QUIT
Begin DoDot:1
+12 SET OBJ=""
+13 WRITE RTN,!
+14 IF MSYS="CACHE"
DO EXPC
IF MSYS="JUMPS"
DO EXPJ
IF MSYS="GTM"
DO EXPG
+15 WRITE !
End DoDot:1
+16 WRITE "**END**",!
+17 DO ^%ZISC
+18 QUIT
+19 ; Export a Cache binary
EXPC SET OBJ=$$ENCODE^CIAUUU(^rOBJ(RTN))
+1 FOR
IF OBJ=""
QUIT
Begin DoDot:1
+2 WRITE $EXTRACT(OBJ,1,75),!
+3 SET OBJ=$EXTRACT(OBJ,76,999999)
End DoDot:1
+4 QUIT
+5 ; Export a JUMPS binary
EXPJ SET OBJ=^$RANDOM(RTN,"OBJECT")
+1 FOR
IF OBJ=""
QUIT
Begin DoDot:1
+2 SET X=$FIND(OBJ,$CHAR(10))
+3 IF 'X
SET X=$LENGTH(OBJ)+2
+4 WRITE $EXTRACT(OBJ,1,X-2),!
+5 SET OBJ=$EXTRACT(OBJ,X,999999)
End DoDot:1
+6 QUIT
+7 ; Export a GTM binary
EXPG WRITE "GTM export not yet supported.",!!
+1 QUIT
+2 ; Import object code into distribution
IMPOBJ NEW MSYS,VER,RTN,DIST,FIL,OBJ,QUIT,D1,X
+1 WRITE "Import Object Code into a Distribution",!!
+2 SET DIST=$$LOOKUP(19930.99,"Distribution")
+3 IF 'DIST
QUIT
+4 READ "Object code file: ",FIL,!!
+5 IF U[FIL
QUIT
+6 DO CLOSEALL^CIAUOS
DO OPEN^CIAUOS(.FIL,"R")
+7 USE FIL
+8 READ X
+9 SET MSYS=$PIECE(X,U)
SET VER=$PIECE(X,U,2)
SET OBJ=""
+10 SET MSYS(0)=$SELECT(MSYS="CACHE":1,MSYS="JUMPS":2,1:0)
+11 USE IO(0)
+12 WRITE "Target "_MSYS_" Version: "_VER_"// "
+13 READ X,!
+14 IF $LENGTH(X)
SET VER=X
+15 FOR
USE FIL
READ RTN
IF RTN="**END**"
QUIT
Begin DoDot:1
+16 NEW FDA,IENS,CNT,DATA
+17 USE IO(0)
+18 WRITE ?5,"Importing routine ",RTN,"...",!
+19 SET RTN(0)=$ORDER(^DIC(9.8,"B",RTN,0))
+20 IF 'RTN(0)
SET QUIT=1
QUIT
+21 FOR D1=0:0
SET D1=$ORDER(^CIAVDIST(DIST,6,RTN(0),1,"B",MSYS(0),D1))
IF 'D1
QUIT
Begin DoDot:2
+22 SET X=$PIECE(^CIAVDIST(DIST,6,RTN(0),1,D1,0),U,2)
SET VER(0)=X
+23 FOR
IF X=VER
QUIT
SET X=$PIECE(X,".",1,$LENGTH(X,".")-1)
IF '$LENGTH(X)
QUIT
End DoDot:2
IF $LENGTH(X)
QUIT
+24 IF 'D1
SET VER(0)=VER
+25 SET D1=$SELECT(D1:D1,1:"+1")
+26 SET IENS=D1_","_RTN(0)_","_DIST_","
SET CNT=0
+27 USE FIL
+28 FOR
READ X
IF X=""
QUIT
SET CNT=CNT+1
SET DATA(CNT,0)=X
+29 SET FDA(19930.9961,IENS,.01)=MSYS(0)
+30 SET FDA(19930.9961,IENS,.5)=VER(0)
+31 SET FDA(19930.9961,IENS,1)="DATA"
+32 DO UPDATE^DIE(,"FDA")
End DoDot:1
IF $DATA(QUIT)
QUIT
+33 DO CLOSE^CIAUOS(FIL)
+34 IF $DATA(QUIT)
WRITE "Routine "_RTN_" not found. Import aborted.",!!
+35 QUIT
+36 ; Lookup an entry in file #FN using prompt PM.
LOOKUP(FN,PM,FL,SC) ;
+1 IF 'FN
QUIT -1
+2 NEW DIC,DLAYGO,X,Y
+3 WRITE !
+4 FOR FL=''$GET(FL):-1:0
Begin DoDot:1
+5 SET DIC=FN
SET DIC(0)=$SELECT(FL:"E",1:"AE")
SET DIC("A")=PM_": "
SET X="??"
+6 IF $LENGTH($GET(SC))
SET DIC("S")=SC
+7 DO ^DIC
End DoDot:1
+8 WRITE !
+9 QUIT $SELECT(Y>0:+Y,1:0)
GBLX(TGT,SRC,SUB,NOD,TYP) ;
+1 NEW K,X,Y,Z
+2 SET @XPDGREF@("PTRS",SUB)=NOD_U_SRC_U_TGT
+3 SET TGT=$$ROOT^DILFD(TGT,,1)
SET SRC=$$ROOT^DILFD(SRC,,1)
SET X=0
+4 FOR
SET X=$ORDER(@SRC@(X))
IF 'X
QUIT
SET Y=$PIECE(^(X,0),U)
SET Z=0
IF $$SCRN(X,TYP)
Begin DoDot:1
+5 SET @XPDGREF@("PTRS",SUB,Y)=""
+6 FOR
SET Z=$ORDER(@SRC@(X,NOD,Z))
IF 'Z
QUIT
SET K=+$GET(^(Z,0))
IF K
Begin DoDot:2
+7 SET K=$PIECE($GET(@TGT@(K,0)),U)
+8 IF $LENGTH(K)
SET @XPDGREF@("PTRS",SUB,Y,K)=""
End DoDot:2
End DoDot:1
+9 QUIT
+10 ; Set progid's to be renamed
RENAME(OLD,NEW) ;
+1 SET OLD=$TRANSLATE(OLD," ")
+2 IF $LENGTH(OLD)
SET @XPDGREF@("RENAME",OLD,NEW)=""
+3 QUIT
+4 ; Set target distribution (user is prompted if necessary)
+5 ; If NOSCN is set, selection will not be screened.
TGT(NOSCN) ;EP
+1 NEW DIC,Y
+2 IF $GET(XPDERR)
QUIT 0
+3 SET Y=+$GET(@XPDGREF@("TGT"))
+4 IF Y>0
QUIT Y
+5 SET Y=$ORDER(^CIAVDIST("C",XPDA,0))
+6 IF Y
IF '$ORDER(^CIAVDIST("C",XPDA,Y))
WRITE "Target distribution: ",$PIECE(^CIAVDIST(Y,0),U)
+7 IF '$TEST
Begin DoDot:1
+8 SET DIC=19930.99
SET DIC(0)="AEF"
SET DIC("A")="Enter target distribution: "
+9 IF '$GET(NOSCN)
SET DIC("S")="I $P(^(0),U,2)=XPDA"
+10 DO ^DIC
+11 SET Y=+Y
End DoDot:1
+12 WRITE !!
+13 IF Y<1
SET XPDERR=1
SET Y=0
+14 IF '$TEST
SET @XPDGREF@("TGT")=Y
+15 QUIT Y
+16 ; Screen entries
+17 ; IEN = Entry to screen
+18 ; TYP = 1: Object Registry
+19 ; 2: Parameter Definition
+20 ; 3: Parameter Template
+21 ; 4: Template Registry
+22 ; 5: Event Type
+23 ; 6: Routine
+24 ; 7: Object Category
+25 ; Returns true if entry is to be included.
SCRN(IEN,TYP) ;
+1 IF '$GET(TYP)
QUIT 1
+2 QUIT $DATA(^CIAVDIST($$TGT,TYP,IEN))
