- 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 5
- ;
- 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")
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPAREDT1 3968 printed Jan 18, 2025@03:41:27 Page 2
- 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 5
- +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")