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))
