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