XPAREDT1 ; SLC/KCM - Supporting Calls - Entities; [3/31/03 7:19am] ;9/12/07 16:19
;;7.3;TOOLKIT;**26,109**;Apr 25, 1995;Build 10
;
BLDLST ; ...continued from BLDLST^XPAREDIT(LST,PAR)
; Build list of entities allowed for this parameter
; # is precedence, 'fixed' is VP to implied instance (i.e., SYS, PKG)
; .LST(#)=file number^message^order^prefix^fixed^lookup info
; ("M", message) = #
; ("P", prefix) = #
; PAR=ien^name
N IEN,SEQ,FN,X K LST ; make sure LST is empty initially
S SEQ=0,LST=0
F S SEQ=$O(^XTV(8989.51,+PAR,30,"B",SEQ)) Q:'SEQ S IEN=$O(^(SEQ,0)) D
. S FN=$P(^XTV(8989.51,+PAR,30,IEN,0),"^",2) I FN=9.4,(DUZ(0)'["@") Q
. S X=^XTV(8989.518,FN,0),X=FN_U_$P(X,U,3)_U_U_$P(X,U,2)
. S LST=LST+1,LST(SEQ)=X
. S LST("M",$$UPPER($P(X,U,2)))=SEQ
. S LST("P",$P(X,U,4))=SEQ
. ; find IEN's where only one entity instance is possible
. I FN=9.4 D ; find package to which this parameter belongs
. . N PRN,PRE
. . S PRN=$P($G(^XTV(8989.51,+PAR,0)),"^",1) Q:'$L(PRN)
. . S PRE=PRN F S PRE=$O(^DIC(9.4,"C",PRE),-1) Q:'$L(PRE) Q:(PRE=$E(PRN,1,$L(PRE))) I '($E(PRE,1)=$E(PRN,1)) S PRE="" Q
. . Q:'$L(PRE)
. . S X=$O(^DIC(9.4,"C",PRE,0))
. . S $P(LST(SEQ),U,5)=X_";DIC(9.4,"
. . S $P(LST(SEQ),U,6)=$P(^DIC(9.4,X,0),"^",1)
. I FN=4.2 D ; find domain for this system
. . S X=$$KSP^XUPARAM("WHERE")
. . S $P(LST(SEQ),U,5)=$$FIND1^DIC(4.2,"","QX",X)_";DIC(4.2,"
. . S $P(LST(SEQ),U,6)=X
. I FN=4 D ; find division if this site not multi-divisional
. . S X=$$KSP^XUPARAM("INST")
. . I $P($G(^DIC(4,X,"DIV")),U,1)'="Y" D
. . . S $P(LST(SEQ),U,5)=X_";DIC(4,"
. . . S $P(LST(SEQ),U,6)=$P(^DIC(4,X,0),"^",1)
. I '$L($P(LST(SEQ),U,5)) D ; otherwise...
. . S $P(LST(SEQ),U,6)=$P($G(^DIC(FN,0)),"^",1)
Q
GETCLS ; ...continued from GETCLS^XPAREDIT(X,PAR,LST)
; Choose the class of entity
; optionally, lookup entity using variable pointer syntax (PRE.NAME)
; .X=returns seq # or entity in VP format
; PAR=ien^name for parameter
; .LST=list from which the entity is selected
N TMP,DONE
D SHWCLS
S DONE=0 F D Q:DONE
. W !,"Enter selection: " R X:DTIME S:'$T X="^" S X=$$UPPER(X)
. I '$L(X)!(X="^")!(X="^^") S ENT="",DONE=1 Q
. I $E(X)="?" D HLPCLS I $E(X,1,2)="??" D SHWCLS ; help requested
. I X=" " S X=$G(^DISV(DUZ,"XPAR01",+PAR)) Q:'X ; spacebar recall
. I +X,$D(LST(X)) S DONE=1 Q ; # -> seq #
. I $D(LST("P",X)) S X=LST("P",X),DONE=1 Q ; PRE -> seq #
. I $D(LST("M",X)) S X=LST("M",X),DONE=1 Q ; NAME -> seq #
. S TMP=$O(LST("M",X))
. I $E(TMP,1,$L(X))=X S X=LST("M",TMP),DONE=1 Q ; PARTIAL -> seq #
. I $L(X,".")>1,$D(LST("P",$P(X,".",1))) D Q:DONE ; if VP syntax
. . S TMP=$P(X,".",2)
. . D LOOKUP^XPAREDIT(.TMP,+LST(LST("P",$P(X,".",1)))) ; silent lookup
. . I $L(TMP) S X=TMP,DONE=1 ; PRE.NAME -> VP
. W " ??" D HLPCLS ; invalid entry
I +X,X'[";" D ;Don't show for resoved pointer p109
. W " ",$P(LST(X),U,2)," ",$P(LST(X),U,6) ; echo selection
. I +LST(X)=9.4 D
. . W !!,"Parameters set for 'Package' may be replaced if "
. . W $P(LST(X),U,6),!,"is installed in this account."
. S ^DISV(DUZ,"XPAR01",+PAR)=X
Q
SHWCLS ; procedure used only by GETCLS
; show entity classes appropriate for this parameter
N I,X
W !!,$P(PAR,"^",2)," may be set for the following:",!!
S I=0 F S I=$O(LST(I)) Q:'I S X=LST(I) D
. W ?5,I,?9,$P(X,"^",2),?23,$P(X,U,4),?30
. I $L($P(X,U,5)) W "["_$P(X,U,6)_"]",!
. I '$L($P(X,U,5)) W "[choose from "_$P(X,U,6)_"]",!
Q
HLPCLS ; procedure used only by GETCLS
; display help for entity class selection
W !,"Enter the number, name, or abbreviation of the selection."
W !,"You may also use variable pointer syntax (Example: LOC.WEST2)."
Q
UPPER(X) ; function - convert lower to upper case
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
XPAREDT1 ; SLC/KCM - Supporting Calls - Entities; [3/31/03 7:19am] ;9/12/07 16:19
+1 ;;7.3;TOOLKIT;**26,109**;Apr 25, 1995;Build 10
+2 ;
BLDLST ; ...continued from BLDLST^XPAREDIT(LST,PAR)
+1 ; Build list of entities allowed for this parameter
+2 ; # is precedence, 'fixed' is VP to implied instance (i.e., SYS, PKG)
+3 ; .LST(#)=file number^message^order^prefix^fixed^lookup info
+4 ; ("M", message) = #
+5 ; ("P", prefix) = #
+6 ; PAR=ien^name
+7 ; make sure LST is empty initially
NEW IEN,SEQ,FN,X
KILL LST
+8 SET SEQ=0
SET LST=0
+9 FOR
SET SEQ=$ORDER(^XTV(8989.51,+PAR,30,"B",SEQ))
IF 'SEQ
QUIT
SET IEN=$ORDER(^(SEQ,0))
Begin DoDot:1
+10 SET FN=$PIECE(^XTV(8989.51,+PAR,30,IEN,0),"^",2)
IF FN=9.4
IF (DUZ(0)'["@")
QUIT
+11 SET X=^XTV(8989.518,FN,0)
SET X=FN_U_$PIECE(X,U,3)_U_U_$PIECE(X,U,2)
+12 SET LST=LST+1
SET LST(SEQ)=X
+13 SET LST("M",$$UPPER($PIECE(X,U,2)))=SEQ
+14 SET LST("P",$PIECE(X,U,4))=SEQ
+15 ; find IEN's where only one entity instance is possible
+16 ; find package to which this parameter belongs
IF FN=9.4
Begin DoDot:2
+17 NEW PRN,PRE
+18 SET PRN=$PIECE($GET(^XTV(8989.51,+PAR,0)),"^",1)
IF '$LENGTH(PRN)
QUIT
+19 SET PRE=PRN
FOR
SET PRE=$ORDER(^DIC(9.4,"C",PRE),-1)
IF '$LENGTH(PRE)
QUIT
IF (PRE=$EXTRACT(PRN,1,$LENGTH(PRE)))
QUIT
IF '($EXTRACT(PRE,1)=$EXTRACT(PRN,1))
SET PRE=""
QUIT
+20 IF '$LENGTH(PRE)
QUIT
+21 SET X=$ORDER(^DIC(9.4,"C",PRE,0))
+22 SET $PIECE(LST(SEQ),U,5)=X_";DIC(9.4,"
+23 SET $PIECE(LST(SEQ),U,6)=$PIECE(^DIC(9.4,X,0),"^",1)
End DoDot:2
+24 ; find domain for this system
IF FN=4.2
Begin DoDot:2
+25 SET X=$$KSP^XUPARAM("WHERE")
+26 SET $PIECE(LST(SEQ),U,5)=$$FIND1^DIC(4.2,"","QX",X)_";DIC(4.2,"
+27 SET $PIECE(LST(SEQ),U,6)=X
End DoDot:2
+28 ; find division if this site not multi-divisional
IF FN=4
Begin DoDot:2
+29 SET X=$$KSP^XUPARAM("INST")
+30 IF $PIECE($GET(^DIC(4,X,"DIV")),U,1)'="Y"
Begin DoDot:3
+31 SET $PIECE(LST(SEQ),U,5)=X_";DIC(4,"
+32 SET $PIECE(LST(SEQ),U,6)=$PIECE(^DIC(4,X,0),"^",1)
End DoDot:3
End DoDot:2
+33 ; otherwise...
IF '$LENGTH($PIECE(LST(SEQ),U,5))
Begin DoDot:2
+34 SET $PIECE(LST(SEQ),U,6)=$PIECE($GET(^DIC(FN,0)),"^",1)
End DoDot:2
End DoDot:1
+35 QUIT
GETCLS ; ...continued from GETCLS^XPAREDIT(X,PAR,LST)
+1 ; Choose the class of entity
+2 ; optionally, lookup entity using variable pointer syntax (PRE.NAME)
+3 ; .X=returns seq # or entity in VP format
+4 ; PAR=ien^name for parameter
+5 ; .LST=list from which the entity is selected
+6 NEW TMP,DONE
+7 DO SHWCLS
+8 SET DONE=0
FOR
Begin DoDot:1
+9 WRITE !,"Enter selection: "
READ X:DTIME
IF '$TEST
SET X="^"
SET X=$$UPPER(X)
+10 IF '$LENGTH(X)!(X="^")!(X="^^")
SET ENT=""
SET DONE=1
QUIT
+11 ; help requested
IF $EXTRACT(X)="?"
DO HLPCLS
IF $EXTRACT(X,1,2)="??"
DO SHWCLS
+12 ; spacebar recall
IF X=" "
SET X=$GET(^DISV(DUZ,"XPAR01",+PAR))
IF 'X
QUIT
+13 ; # -> seq #
IF +X
IF $DATA(LST(X))
SET DONE=1
QUIT
+14 ; PRE -> seq #
IF $DATA(LST("P",X))
SET X=LST("P",X)
SET DONE=1
QUIT
+15 ; NAME -> seq #
IF $DATA(LST("M",X))
SET X=LST("M",X)
SET DONE=1
QUIT
+16 SET TMP=$ORDER(LST("M",X))
+17 ; PARTIAL -> seq #
IF $EXTRACT(TMP,1,$LENGTH(X))=X
SET X=LST("M",TMP)
SET DONE=1
QUIT
+18 ; if VP syntax
IF $LENGTH(X,".")>1
IF $DATA(LST("P",$PIECE(X,".",1)))
Begin DoDot:2
+19 SET TMP=$PIECE(X,".",2)
+20 ; silent lookup
DO LOOKUP^XPAREDIT(.TMP,+LST(LST("P",$PIECE(X,".",1))))
+21 ; PRE.NAME -> VP
IF $LENGTH(TMP)
SET X=TMP
SET DONE=1
End DoDot:2
IF DONE
QUIT
+22 ; invalid entry
WRITE " ??"
DO HLPCLS
End DoDot:1
IF DONE
QUIT
+23 ;Don't show for resoved pointer p109
IF +X
IF X'[";"
Begin DoDot:1
+24 ; echo selection
WRITE " ",$PIECE(LST(X),U,2)," ",$PIECE(LST(X),U,6)
+25 IF +LST(X)=9.4
Begin DoDot:2
+26 WRITE !!,"Parameters set for 'Package' may be replaced if "
+27 WRITE $PIECE(LST(X),U,6),!,"is installed in this account."
End DoDot:2
+28 SET ^DISV(DUZ,"XPAR01",+PAR)=X
End DoDot:1
+29 QUIT
SHWCLS ; procedure used only by GETCLS
+1 ; show entity classes appropriate for this parameter
+2 NEW I,X
+3 WRITE !!,$PIECE(PAR,"^",2)," may be set for the following:",!!
+4 SET I=0
FOR
SET I=$ORDER(LST(I))
IF 'I
QUIT
SET X=LST(I)
Begin DoDot:1
+5 WRITE ?5,I,?9,$PIECE(X,"^",2),?23,$PIECE(X,U,4),?30
+6 IF $LENGTH($PIECE(X,U,5))
WRITE "["_$PIECE(X,U,6)_"]",!
+7 IF '$LENGTH($PIECE(X,U,5))
WRITE "[choose from "_$PIECE(X,U,6)_"]",!
End DoDot:1
+8 QUIT
HLPCLS ; procedure used only by GETCLS
+1 ; display help for entity class selection
+2 WRITE !,"Enter the number, name, or abbreviation of the selection."
+3 WRITE !,"You may also use variable pointer syntax (Example: LOC.WEST2)."
+4 QUIT
UPPER(X) ; function - convert lower to upper case
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
