XPAREDT2 ; SLC/KCM - Supporting Calls - Instances, Values ;04/08/2003 11:22 [ 12/18/2003 5:02 PM ]
;;7.3;TOOLKIT;**26,35,52,74,1002**;Apr 25, 1995
;
EDIT1 ; called only from EDIT, expects ENT,PAR,INST to be defined
N VALTYPE,X S VALTYPE=$E($G(^XTV(8989.51,+PAR,1)))
I VALTYPE="W" D I ERR W $$ERR Q
. D GETWP^XPAR(.X,ENT,+PAR,$P(INST,U),.ERR) S:'ERR $P(X,U,2)=$G(X)
I VALTYPE'="W" D
. S X=$$GET^XPAR(ENT,+PAR,$P(INST,U),"B")
. I $L(X),$E(^XTV(8989.51,+PAR,1))="P" S X="`"_X
S Y="" D EDITVAL(.Y,+PAR,"V",.X) Q:(Y="")!($E(Y)=U)
I Y="@" D DEL^XPAR(ENT,+PAR,$P(INST,U),.ERR) D Q
. I ERR W $$ERR Q
. W " ...deleted"
; I VALTYPE'="W" W " ",$P(Y,U,2)
S Y=$P(Y,U)
D EN^XPAR(ENT,+PAR,$P(INST,U),.Y,.ERR) I ERR W $$ERR Q
Q
EDITVAL(DTA,PAR,TYP,DFLT) ; edit the value for an instance or a value
; .DTA=internal value^external value returned, wp in DTA(n,0) nodes
; PAR=parameter which describes the data being edited
; TYP=edit type - I:instance, V:value, S:select instance
; .DFLT=internal default value^external default value
; internal values are preceded by "`" if they are pointers
N DIR,SUB,TERM,WP,X
S SUB=$S(TYP="V":0,1:5),Y=""
S DIR(0)=$P($G(^XTV(8989.51,+PAR,SUB+1)),U,1,2)
S $P(DIR(0),U,1)=$P(DIR(0),U,1)_"OA"
I "P"=$E(DIR(0)) S $P(DIR(0),":",2)="AEMQZ"
I $L($G(^XTV(8989.51,+PAR,SUB+2))) S $P(DIR(0),U,3)=^(SUB+2)
I $L($G(^XTV(8989.51,+PAR,SUB+3))) S DIR("S")=^(SUB+3)
I (TYP="I")!(TYP="S") S TERM=$P($G(^XTV(8989.51,+PAR,0)),U,4)
I TYP="V" S TERM=$P($G(^XTV(8989.51,+PAR,0)),U,5)
I '$L(TERM) S TERM=$S(TYP="V":"Value",1:"Instance")
S DIR("A")=$S(TYP="S":"Select ",1:"")_TERM_": "
I $L($G(DFLT)) S DIR("B")=$P(DFLT,U,2)
I $L($P($G(^XTV(8989.51,+PAR,SUB+1)),U,3)) S DIR("?")=$P(^(SUB+1),U,3)
I TYP="S" S DIR("?")="^D SHWINST^XPAREDT2(ENT,PAR,20,1)"
S DIR("??")="^D SHWDESC^XPAREDT2(PAR)"
I $E(DIR(0))="W" D
. S $P(DIR(0),U,1)="FOA",WP=1
. K ^TMP($J,"XPARWP") M ^TMP($J,"XPARWP")=DFLT
I $E(DIR(0))="S" S $P(DIR(0),U,1)=$P(DIR(0),U,1)_"M"
; PDIR simulates call to DIR, returning X & Y
D PDIR S DTA("X")=X,DTA=Y S:$D(DTOUT)!$D(DUOUT) DTA=""
I $D(DTOUT)!$D(DUOUT)!("@"[DTA) Q
I $E(DIR(0))="P" S DTA="`"_+Y_U_$P(Y(0),U,1)
I "SDY"[$E(DIR(0)) S DTA=Y_U_$P(Y(0),U,1)
I '$L($P(DTA,U,2)) S $P(DTA,U,2)=$P(DTA,U)
I '$D(DIRUT),$G(WP) D ; edit the word processing field
. N DIWESUB,DIC,Y
. S DIWESUB=$P(DTA,U,2),DIC="^TMP($J,""XPARWP"","
. D EN^DIWE
. S I=0 F S I=$O(^TMP($J,"XPARWP",I)) Q:'I S DTA(I,0)=^(I,0)
Q
PDIR ; call DIR if not pointer type, otherwise call DIC
N DIC S X=""
I $E(DIR(0))'="P" D ^DIR S:X="@" Y="@" Q
F D I $D(DTOUT)!$D(DUOUT)!($L(Y))!('$L(X)) Q
. S DIC=+$P(DIR(0),U,2),DIC(0)="EMQZ"
. S:$D(DIR("S")) DIC("S")=DIR("S")
. W !,DIR("A")_$S($D(DIR("B")):DIR("B")_"// ",1:"")
. R X:DTIME S:'$T DTOUT="" S:$E(X)=U DUOUT="" S:X="@" Y="@"
. I '$L(X),$L($G(DFLT)) S X=$P(DFLT,U) ;"`"_+DFLT
. I X="?",$L($P($G(DIR("?")),U,2)) X $P(DIR("?"),U,2,999)
. I $D(INSTLST),$L(X),($E(X)'="`") D ; match existing instance
. . N I S I=0
. . F S I=$O(INSTLST(I)) Q:'I I $E($P(INSTLST(I),U),1,$L(X))=X D Q
. . . W $E($P(INSTLST(I),U),$L(X)+1,999)
. . . S X=$P(INSTLST(I),U)
. Q:$D(DTOUT)!$D(DUOUT)!(Y="@")!('$L(X))
. D ^DIC K DIC("S") I Y<0 S Y=""
Q
SHWINST(ENT,PAR,CNT,SCR,LST) ; list CNT instances of an entity/parameter
N I,TERM,ERR,DIR,DIRUT,DUOUT,DTOUT,X,Y,LC,RC,RCPOS
S TERM=$P($G(^XTV(8989.51,+PAR,0)),U,4) I '$L(TERM) S TERM="Instance"
D GETLST^XPAR(.LST,ENT,PAR,"E",.ERR) I ERR W $$ERR Q
I 'LST W !!,"There are currently no entries for ",TERM,".",! Q
I LST>CNT,'$G(SCR) W !!,LST," entries for ",TERM," currently exist.",! Q
S LC=$L(TERM),RC=$L("Value")
S I=0
F S I=$O(LST(I)) Q:'I D
. I $L($P(LST(I),U,1))>LC S LC=$L($P(LST(I),U,1))
. I $L($P(LST(I),U,2))>RC S RC=$L($P(LST(I),U,2))
I LC+RC>77 D
. I LC>38,RC<38 S LC=77-RC Q
. I LC<38,RC>38 S RC=77-LC Q
. S LC=38,RC=39
S RCPOS=LC+2
W !!,TERM,?RCPOS,"Value",!,$$DASH^XPAREDIT($L(TERM)),?RCPOS,"-----",!
S I=0 F S I=$O(LST(I)) Q:'I D Q:$D(DUOUT)
. W $E($P(LST(I),U,1),1,LC),?RCPOS,$E($P(LST(I),U,2),1,RC),!
. I I#CNT=0,$O(LST(I)) S DIR(0)="E" D ^DIR W !
Q
SELINST(INST,ENT,PAR) ; select a specific instance from multiple parameter
; .INST=external value of instance
N TERM,ERR,DIR
S TERM=$P($G(^XTV(8989.51,+PAR,0)),U,4) S:'$L(TERM) TERM="Instance"
S INST="" D EDITVAL(.INST,+PAR,"S") Q:'$L(INST)!($E(INST)=U)
I $P(INST,U)=" " D
. S INST=$G(^DISV(DUZ,"XPAR01",+PAR,ENT)) S:INST="" INST=" "
I '$L($$GET^XPAR(ENT,PAR,$P(INST,U))) D ; if instance does not exist
. S DIR(0)="Y",DIR("B")="Yes" ; verify adding new one
. S DIR("A")="Are you adding "_$P(INST,U,2)_" as a new "_TERM
. D ^DIR I $D(DIRUT)!('Y) S INST="" Q
. ; D ADD^XPAR(ENT,+PAR,INST,"",.ERR) I ERR W $$ERR S INST=""
; DIR doesn't return space, so spacebar recall only works with Free
I $L(INST),$E($G(^XTV(8989.51,+PAR,6)))="F" D
. S ^DISV(DUZ,"XPAR01",+PAR,ENT)=$P(INST,U,2)
Q
SHWDESC(PAR) ; show description of parameter
Q:'PAR S I=0 F S I=$O(^XTV(8989.51,PAR,20,I)) Q:'I W !,^(I,0)
Q
ERR() ; function - displays error message, expects ERR to be present
W !!,">>> ",$P($G(ERR),U,2),!!
Q ""
XPAREDT2 ; SLC/KCM - Supporting Calls - Instances, Values ;04/08/2003 11:22 [ 12/18/2003 5:02 PM ]
+1 ;;7.3;TOOLKIT;**26,35,52,74,1002**;Apr 25, 1995
+2 ;
EDIT1 ; called only from EDIT, expects ENT,PAR,INST to be defined
+1 NEW VALTYPE,X
SET VALTYPE=$EXTRACT($GET(^XTV(8989.51,+PAR,1)))
+2 IF VALTYPE="W"
Begin DoDot:1
+3 DO GETWP^XPAR(.X,ENT,+PAR,$PIECE(INST,U),.ERR)
IF 'ERR
SET $PIECE(X,U,2)=$GET(X)
End DoDot:1
IF ERR
WRITE $$ERR
QUIT
+4 IF VALTYPE'="W"
Begin DoDot:1
+5 SET X=$$GET^XPAR(ENT,+PAR,$PIECE(INST,U),"B")
+6 IF $LENGTH(X)
IF $EXTRACT(^XTV(8989.51,+PAR,1))="P"
SET X="`"_X
End DoDot:1
+7 SET Y=""
DO EDITVAL(.Y,+PAR,"V",.X)
IF (Y="")!($EXTRACT(Y)=U)
QUIT
+8 IF Y="@"
DO DEL^XPAR(ENT,+PAR,$PIECE(INST,U),.ERR)
Begin DoDot:1
+9 IF ERR
WRITE $$ERR
QUIT
+10 WRITE " ...deleted"
End DoDot:1
QUIT
+11 ; I VALTYPE'="W" W " ",$P(Y,U,2)
+12 SET Y=$PIECE(Y,U)
+13 DO EN^XPAR(ENT,+PAR,$PIECE(INST,U),.Y,.ERR)
IF ERR
WRITE $$ERR
QUIT
+14 QUIT
EDITVAL(DTA,PAR,TYP,DFLT) ; edit the value for an instance or a value
+1 ; .DTA=internal value^external value returned, wp in DTA(n,0) nodes
+2 ; PAR=parameter which describes the data being edited
+3 ; TYP=edit type - I:instance, V:value, S:select instance
+4 ; .DFLT=internal default value^external default value
+5 ; internal values are preceded by "`" if they are pointers
+6 NEW DIR,SUB,TERM,WP,X
+7 SET SUB=$SELECT(TYP="V":0,1:5)
SET Y=""
+8 SET DIR(0)=$PIECE($GET(^XTV(8989.51,+PAR,SUB+1)),U,1,2)
+9 SET $PIECE(DIR(0),U,1)=$PIECE(DIR(0),U,1)_"OA"
+10 IF "P"=$EXTRACT(DIR(0))
SET $PIECE(DIR(0),":",2)="AEMQZ"
+11 IF $LENGTH($GET(^XTV(8989.51,+PAR,SUB+2)))
SET $PIECE(DIR(0),U,3)=^(SUB+2)
+12 IF $LENGTH($GET(^XTV(8989.51,+PAR,SUB+3)))
SET DIR("S")=^(SUB+3)
+13 IF (TYP="I")!(TYP="S")
SET TERM=$PIECE($GET(^XTV(8989.51,+PAR,0)),U,4)
+14 IF TYP="V"
SET TERM=$PIECE($GET(^XTV(8989.51,+PAR,0)),U,5)
+15 IF '$LENGTH(TERM)
SET TERM=$SELECT(TYP="V":"Value",1:"Instance")
+16 SET DIR("A")=$SELECT(TYP="S":"Select ",1:"")_TERM_": "
+17 IF $LENGTH($GET(DFLT))
SET DIR("B")=$PIECE(DFLT,U,2)
+18 IF $LENGTH($PIECE($GET(^XTV(8989.51,+PAR,SUB+1)),U,3))
SET DIR("?")=$PIECE(^(SUB+1),U,3)
+19 IF TYP="S"
SET DIR("?")="^D SHWINST^XPAREDT2(ENT,PAR,20,1)"
+20 SET DIR("??")="^D SHWDESC^XPAREDT2(PAR)"
+21 IF $EXTRACT(DIR(0))="W"
Begin DoDot:1
+22 SET $PIECE(DIR(0),U,1)="FOA"
SET WP=1
+23 KILL ^TMP($JOB,"XPARWP")
MERGE ^TMP($JOB,"XPARWP")=DFLT
End DoDot:1
+24 IF $EXTRACT(DIR(0))="S"
SET $PIECE(DIR(0),U,1)=$PIECE(DIR(0),U,1)_"M"
+25 ; PDIR simulates call to DIR, returning X & Y
+26 DO PDIR
SET DTA("X")=X
SET DTA=Y
IF $DATA(DTOUT)!$DATA(DUOUT)
SET DTA=""
+27 IF $DATA(DTOUT)!$DATA(DUOUT)!("@"[DTA)
QUIT
+28 IF $EXTRACT(DIR(0))="P"
SET DTA="`"_+Y_U_$PIECE(Y(0),U,1)
+29 IF "SDY"[$EXTRACT(DIR(0))
SET DTA=Y_U_$PIECE(Y(0),U,1)
+30 IF '$LENGTH($PIECE(DTA,U,2))
SET $PIECE(DTA,U,2)=$PIECE(DTA,U)
+31 ; edit the word processing field
IF '$DATA(DIRUT)
IF $GET(WP)
Begin DoDot:1
+32 NEW DIWESUB,DIC,Y
+33 SET DIWESUB=$PIECE(DTA,U,2)
SET DIC="^TMP($J,""XPARWP"","
+34 DO EN^DIWE
+35 SET I=0
FOR
SET I=$ORDER(^TMP($JOB,"XPARWP",I))
IF 'I
QUIT
SET DTA(I,0)=^(I,0)
End DoDot:1
+36 QUIT
PDIR ; call DIR if not pointer type, otherwise call DIC
+1 NEW DIC
SET X=""
+2 IF $EXTRACT(DIR(0))'="P"
DO ^DIR
IF X="@"
SET Y="@"
QUIT
+3 FOR
Begin DoDot:1
+4 SET DIC=+$PIECE(DIR(0),U,2)
SET DIC(0)="EMQZ"
+5 IF $DATA(DIR("S"))
SET DIC("S")=DIR("S")
+6 WRITE !,DIR("A")_$SELECT($DATA(DIR("B")):DIR("B")_"// ",1:"")
+7 READ X:DTIME
IF '$TEST
SET DTOUT=""
IF $EXTRACT(X)=U
SET DUOUT=""
IF X="@"
SET Y="@"
+8 ;"`"_+DFLT
IF '$LENGTH(X)
IF $LENGTH($GET(DFLT))
SET X=$PIECE(DFLT,U)
+9 IF X="?"
IF $LENGTH($PIECE($GET(DIR("?")),U,2))
XECUTE $PIECE(DIR("?"),U,2,999)
+10 ; match existing instance
IF $DATA(INSTLST)
IF $LENGTH(X)
IF ($EXTRACT(X)'="`")
Begin DoDot:2
+11 NEW I
SET I=0
+12 FOR
SET I=$ORDER(INSTLST(I))
IF 'I
QUIT
IF $EXTRACT($PIECE(INSTLST(I),U),1,$LENGTH(X))=X
Begin DoDot:3
+13 WRITE $EXTRACT($PIECE(INSTLST(I),U),$LENGTH(X)+1,999)
+14 SET X=$PIECE(INSTLST(I),U)
End DoDot:3
QUIT
End DoDot:2
+15 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="@")!('$LENGTH(X))
QUIT
+16 DO ^DIC
KILL DIC("S")
IF Y<0
SET Y=""
End DoDot:1
IF $DATA(DTOUT)!$DATA(DUOUT)!($LENGTH(Y))!('$LENGTH(X))
QUIT
+17 QUIT
SHWINST(ENT,PAR,CNT,SCR,LST) ; list CNT instances of an entity/parameter
+1 NEW I,TERM,ERR,DIR,DIRUT,DUOUT,DTOUT,X,Y,LC,RC,RCPOS
+2 SET TERM=$PIECE($GET(^XTV(8989.51,+PAR,0)),U,4)
IF '$LENGTH(TERM)
SET TERM="Instance"
+3 DO GETLST^XPAR(.LST,ENT,PAR,"E",.ERR)
IF ERR
WRITE $$ERR
QUIT
+4 IF 'LST
WRITE !!,"There are currently no entries for ",TERM,".",!
QUIT
+5 IF LST>CNT
IF '$GET(SCR)
WRITE !!,LST," entries for ",TERM," currently exist.",!
QUIT
+6 SET LC=$LENGTH(TERM)
SET RC=$LENGTH("Value")
+7 SET I=0
+8 FOR
SET I=$ORDER(LST(I))
IF 'I
QUIT
Begin DoDot:1
+9 IF $LENGTH($PIECE(LST(I),U,1))>LC
SET LC=$LENGTH($PIECE(LST(I),U,1))
+10 IF $LENGTH($PIECE(LST(I),U,2))>RC
SET RC=$LENGTH($PIECE(LST(I),U,2))
End DoDot:1
+11 IF LC+RC>77
Begin DoDot:1
+12 IF LC>38
IF RC<38
SET LC=77-RC
QUIT
+13 IF LC<38
IF RC>38
SET RC=77-LC
QUIT
+14 SET LC=38
SET RC=39
End DoDot:1
+15 SET RCPOS=LC+2
+16 WRITE !!,TERM,?RCPOS,"Value",!,$$DASH^XPAREDIT($LENGTH(TERM)),?RCPOS,"-----",!
+17 SET I=0
FOR
SET I=$ORDER(LST(I))
IF 'I
QUIT
Begin DoDot:1
+18 WRITE $EXTRACT($PIECE(LST(I),U,1),1,LC),?RCPOS,$EXTRACT($PIECE(LST(I),U,2),1,RC),!
+19 IF I#CNT=0
IF $ORDER(LST(I))
SET DIR(0)="E"
DO ^DIR
WRITE !
End DoDot:1
IF $DATA(DUOUT)
QUIT
+20 QUIT
SELINST(INST,ENT,PAR) ; select a specific instance from multiple parameter
+1 ; .INST=external value of instance
+2 NEW TERM,ERR,DIR
+3 SET TERM=$PIECE($GET(^XTV(8989.51,+PAR,0)),U,4)
IF '$LENGTH(TERM)
SET TERM="Instance"
+4 SET INST=""
DO EDITVAL(.INST,+PAR,"S")
IF '$LENGTH(INST)!($EXTRACT(INST)=U)
QUIT
+5 IF $PIECE(INST,U)=" "
Begin DoDot:1
+6 SET INST=$GET(^DISV(DUZ,"XPAR01",+PAR,ENT))
IF INST=""
SET INST=" "
End DoDot:1
+7 ; if instance does not exist
IF '$LENGTH($$GET^XPAR(ENT,PAR,$PIECE(INST,U)))
Begin DoDot:1
+8 ; verify adding new one
SET DIR(0)="Y"
SET DIR("B")="Yes"
+9 SET DIR("A")="Are you adding "_$PIECE(INST,U,2)_" as a new "_TERM
+10 DO ^DIR
IF $DATA(DIRUT)!('Y)
SET INST=""
QUIT
+11 ; D ADD^XPAR(ENT,+PAR,INST,"",.ERR) I ERR W $$ERR S INST=""
End DoDot:1
+12 ; DIR doesn't return space, so spacebar recall only works with Free
+13 IF $LENGTH(INST)
IF $EXTRACT($GET(^XTV(8989.51,+PAR,6)))="F"
Begin DoDot:1
+14 SET ^DISV(DUZ,"XPAR01",+PAR,ENT)=$PIECE(INST,U,2)
End DoDot:1
+15 QUIT
SHWDESC(PAR) ; show description of parameter
+1 IF 'PAR
QUIT
SET I=0
FOR
SET I=$ORDER(^XTV(8989.51,PAR,20,I))
IF 'I
QUIT
WRITE !,^(I,0)
+2 QUIT
ERR() ; function - displays error message, expects ERR to be present
+1 WRITE !!,">>> ",$PIECE($GET(ERR),U,2),!!
+2 QUIT ""
