VALMD ;MJK/ALB - List Manager Demo Routine; APR 2, 1992 ;06/26/2006
;;1.0;List Manager;**8**;Aug 13, 1993;Build 1
;
EN ; -- option entry point
K XQORS,VALMEVL
D EN^VALM("VALM DEMO APPLICATION")
ENQ Q
;
;
INIT ; -- build array
W ! S DIC("A")="Select Package: ",DIC="^DIC(9.4,",DIC(0)="AEMQ" D ^DIC K DIC
I Y<0 S VALMQUIT="" G INITQ
PKG ; -- entry pt if package known
N VALMX,VALMCNTI,VALMPRO,VALMIFN,X,VALMPRE,Z
S VALMPKG=+Y
D CLEAN^VALM10
S (VALMCNTI,VALMCNT)=0,(VALMPRE,VALMPRO)=$P($G(^DIC(9.4,VALMPKG,0)),U,2)
F S VALMPRO=$O(^ORD(101,"B",VALMPRO)) Q:$E(VALMPRO,1,$L(VALMPRE))'=VALMPRE S VALMIFN=0 F S VALMIFN=$O(^ORD(101,"B",VALMPRO,VALMIFN)) Q:'VALMIFN I $D(^ORD(101,VALMIFN,0)) S VALMX=^(0) D
.S VALMCNTI=VALMCNTI+1 W:(VALMCNTI#10)=0 "."
.S X=$$SETFLD^VALM1(VALMCNTI,"","NUMBER")
.S X=$$SETFLD^VALM1($P(VALMX,U),X,"NAME")
.S X=$$SETFLD^VALM1($P(VALMX,U,2),X,"TEXT") K Z S $E(Z,$L(X)+1,240)=""
.S VALMCNT=VALMCNT+1
.D SET^VALM10(VALMCNT,$E(X_Z,1,240),VALMCNTI) ; set text
.S ^TMP("VALMZIDX",$J,VALMCNTI)=VALMCNT_U_VALMIFN
.D:'(VALMCNT#9) FLDCTRL^VALM10(VALMCNT) ; defaults for all fields
.D FLDCTRL^VALM10(VALMCNT,"NUMBER") ; default for 1 field
.D:'(VALMCNT#5) FLDCTRL^VALM10(VALMCNT,"NAME",IOUON,IOUOFF) ; adhoc
D NUL:'VALMCNT
INITQ Q
;
HDR ; -- demo header
N VALMX
S VALMX=$G(^DIC(9.4,VALMPKG,0)),X=" Package: "_$P(VALMX,U)
S VALMHDR(1)=$$SETSTR^VALM1("Prefix: "_$P(VALMX,U,2),X,63,15)
S VALMHDR(2)="Description: "_$E($P(VALMX,U,3),1,65)
Q
;
NUL ; -- set nul message
I 'VALMCNT D
.F X=" "," No protocols to list." S VALMCNT=VALMCNT+1 D SET^VALM10(VALMCNT,X)
.S ^TMP("VALMZIDX",$J,1)=1,^(2)=2
Q
;
FNL ; -- clean up
K DIE,DIC,DR,DA,DE,DQ,VALMY,VALMPKG,^TMP("VALMZIDX",$J)
D CLEAN^VALM10
Q
;
EXP ; -- expand action
D FULL^VALM1
N VALMI,VALMAT,VALMY
D EN^VALM2(XQORNOD(0),"O") S VALMI=0
F S VALMI=$O(VALMY(VALMI)) Q:'VALMI D
.S VALMAT=$G(^TMP("VALMZIDX",$J,VALMI))
.W !!,@VALMAR@(+VALMAT,0),!
.S DA=+$P(VALMAT,U,2),DIC="^ORD(101,",DR="0" D EN^DIQ,PAUSE^VALM1
S VALMBCK="R",VALMSG="'Expand' was last action picked."
Q
;
EDIT ; -- edit action
N VALMA,VALMP,VALMI,VALMAT,VALMY
D MSG^VALM10("'Edit' action...")
D EN^VALM2(XQORNOD(0),"O") S VALMI=0 ; all the user to "O"ptionally answer
F S VALMI=$O(VALMY(VALMI)) Q:'VALMI D
.D SELECT^VALM10(VALMI,1) ; -- 'select' line
.S VALMAT=$G(^TMP("VALMZIDX",$J,VALMI))
.W !!,@VALMAR@(+VALMAT,0)
.S DA=+$P(VALMAT,U,2),VALMP=$G(^ORD(101,DA,0)),DIE=101,DR="1" D ^DIE K DIE,DR
.S VALMA=$G(^ORD(101,DA,0))
.I $P(VALMP,U,2)'=$P(VALMA,U,2) D UPD($P(VALMA,U,2),"TEXT",.VALMAT)
.D SELECT^VALM10(VALMI,0) ; -- 'de-select' line
D MSG^VALM10("")
S VALMBCK=$S(VALMCC:"",1:"R")
Q
;
DESC ; -- display description action
N VALMI,VALMY,VALMAT
D EN^VALM2(XQORNOD(0),"OS") S VALMI=0 ; select only a "S"ingle protocol
F S VALMI=$O(VALMY(VALMI)) Q:'VALMI D
.S VALMAT=+$P($G(^TMP("VALMZIDX",$J,VALMI)),U,2)
.I '$D(^ORD(101,VALMAT,1)) W !!,"No Description entered." D PAUSE^VALM1 Q
.D WP^VALM("^ORD(101,"_VALMAT_",1)",$P($G(^ORD(101,VALMAT,0)),U))
S VALMBCK="R"
Q
;
UPD(TEXT,FLD,VALMAT) ; -- update data for screen
D:VALMCC FLDCTRL^VALM10(+VALMAT,.FLD,.IOINHI,.IOINORM,1)
D FLDTEXT^VALM10(+VALMAT,.FLD,.TEXT)
Q
;
CHG ; -- change package action
K X I $D(XQORNOD(0)) S X=$P($P(XQORNOD(0),U,4),"=",2)
I X="" R !!,"Select Package: ",X:DTIME
S DIC="^DIC(9.4,",DIC(0)="EMQ" D ^DIC K DIC G CHG:X["?"
I Y<0 D G CHGQ
.W !!,*7,"Package has not been changed."
.W ! S DIR(0)="E" D ^DIR K DIR
.S VALMBCK=""
D PKG,HDR S VALMBCK="R" S VALMBG=1
CHGQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVALMD 3665 printed Dec 13, 2024@02:10:05 Page 2
VALMD ;MJK/ALB - List Manager Demo Routine; APR 2, 1992 ;06/26/2006
+1 ;;1.0;List Manager;**8**;Aug 13, 1993;Build 1
+2 ;
EN ; -- option entry point
+1 KILL XQORS,VALMEVL
+2 DO EN^VALM("VALM DEMO APPLICATION")
ENQ QUIT
+1 ;
+2 ;
INIT ; -- build array
+1 WRITE !
SET DIC("A")="Select Package: "
SET DIC="^DIC(9.4,"
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+2 IF Y<0
SET VALMQUIT=""
GOTO INITQ
PKG ; -- entry pt if package known
+1 NEW VALMX,VALMCNTI,VALMPRO,VALMIFN,X,VALMPRE,Z
+2 SET VALMPKG=+Y
+3 DO CLEAN^VALM10
+4 SET (VALMCNTI,VALMCNT)=0
SET (VALMPRE,VALMPRO)=$PIECE($GET(^DIC(9.4,VALMPKG,0)),U,2)
+5 FOR
SET VALMPRO=$ORDER(^ORD(101,"B",VALMPRO))
if $EXTRACT(VALMPRO,1,$LENGTH(VALMPRE))'=VALMPRE
QUIT
SET VALMIFN=0
FOR
SET VALMIFN=$ORDER(^ORD(101,"B",VALMPRO,VALMIFN))
if 'VALMIFN
QUIT
IF $DATA(^ORD(101,VALMIFN,0))
SET VALMX=^(0)
Begin DoDot:1
+6 SET VALMCNTI=VALMCNTI+1
if (VALMCNTI#10)=0
WRITE "."
+7 SET X=$$SETFLD^VALM1(VALMCNTI,"","NUMBER")
+8 SET X=$$SETFLD^VALM1($PIECE(VALMX,U),X,"NAME")
+9 SET X=$$SETFLD^VALM1($PIECE(VALMX,U,2),X,"TEXT")
KILL Z
SET $EXTRACT(Z,$LENGTH(X)+1,240)=""
+10 SET VALMCNT=VALMCNT+1
+11 ; set text
DO SET^VALM10(VALMCNT,$EXTRACT(X_Z,1,240),VALMCNTI)
+12 SET ^TMP("VALMZIDX",$JOB,VALMCNTI)=VALMCNT_U_VALMIFN
+13 ; defaults for all fields
if '(VALMCNT#9)
DO FLDCTRL^VALM10(VALMCNT)
+14 ; default for 1 field
DO FLDCTRL^VALM10(VALMCNT,"NUMBER")
+15 ; adhoc
if '(VALMCNT#5)
DO FLDCTRL^VALM10(VALMCNT,"NAME",IOUON,IOUOFF)
End DoDot:1
+16 if 'VALMCNT
DO NUL
INITQ QUIT
+1 ;
HDR ; -- demo header
+1 NEW VALMX
+2 SET VALMX=$GET(^DIC(9.4,VALMPKG,0))
SET X=" Package: "_$PIECE(VALMX,U)
+3 SET VALMHDR(1)=$$SETSTR^VALM1("Prefix: "_$PIECE(VALMX,U,2),X,63,15)
+4 SET VALMHDR(2)="Description: "_$EXTRACT($PIECE(VALMX,U,3),1,65)
+5 QUIT
+6 ;
NUL ; -- set nul message
+1 IF 'VALMCNT
Begin DoDot:1
+2 FOR X=" "," No protocols to list."
SET VALMCNT=VALMCNT+1
DO SET^VALM10(VALMCNT,X)
+3 SET ^TMP("VALMZIDX",$JOB,1)=1
SET ^(2)=2
End DoDot:1
+4 QUIT
+5 ;
FNL ; -- clean up
+1 KILL DIE,DIC,DR,DA,DE,DQ,VALMY,VALMPKG,^TMP("VALMZIDX",$JOB)
+2 DO CLEAN^VALM10
+3 QUIT
+4 ;
EXP ; -- expand action
+1 DO FULL^VALM1
+2 NEW VALMI,VALMAT,VALMY
+3 DO EN^VALM2(XQORNOD(0),"O")
SET VALMI=0
+4 FOR
SET VALMI=$ORDER(VALMY(VALMI))
if 'VALMI
QUIT
Begin DoDot:1
+5 SET VALMAT=$GET(^TMP("VALMZIDX",$JOB,VALMI))
+6 WRITE !!,@VALMAR@(+VALMAT,0),!
+7 SET DA=+$PIECE(VALMAT,U,2)
SET DIC="^ORD(101,"
SET DR="0"
DO EN^DIQ
DO PAUSE^VALM1
End DoDot:1
+8 SET VALMBCK="R"
SET VALMSG="'Expand' was last action picked."
+9 QUIT
+10 ;
EDIT ; -- edit action
+1 NEW VALMA,VALMP,VALMI,VALMAT,VALMY
+2 DO MSG^VALM10("'Edit' action...")
+3 ; all the user to "O"ptionally answer
DO EN^VALM2(XQORNOD(0),"O")
SET VALMI=0
+4 FOR
SET VALMI=$ORDER(VALMY(VALMI))
if 'VALMI
QUIT
Begin DoDot:1
+5 ; -- 'select' line
DO SELECT^VALM10(VALMI,1)
+6 SET VALMAT=$GET(^TMP("VALMZIDX",$JOB,VALMI))
+7 WRITE !!,@VALMAR@(+VALMAT,0)
+8 SET DA=+$PIECE(VALMAT,U,2)
SET VALMP=$GET(^ORD(101,DA,0))
SET DIE=101
SET DR="1"
DO ^DIE
KILL DIE,DR
+9 SET VALMA=$GET(^ORD(101,DA,0))
+10 IF $PIECE(VALMP,U,2)'=$PIECE(VALMA,U,2)
DO UPD($PIECE(VALMA,U,2),"TEXT",.VALMAT)
+11 ; -- 'de-select' line
DO SELECT^VALM10(VALMI,0)
End DoDot:1
+12 DO MSG^VALM10("")
+13 SET VALMBCK=$SELECT(VALMCC:"",1:"R")
+14 QUIT
+15 ;
DESC ; -- display description action
+1 NEW VALMI,VALMY,VALMAT
+2 ; select only a "S"ingle protocol
DO EN^VALM2(XQORNOD(0),"OS")
SET VALMI=0
+3 FOR
SET VALMI=$ORDER(VALMY(VALMI))
if 'VALMI
QUIT
Begin DoDot:1
+4 SET VALMAT=+$PIECE($GET(^TMP("VALMZIDX",$JOB,VALMI)),U,2)
+5 IF '$DATA(^ORD(101,VALMAT,1))
WRITE !!,"No Description entered."
DO PAUSE^VALM1
QUIT
+6 DO WP^VALM("^ORD(101,"_VALMAT_",1)",$PIECE($GET(^ORD(101,VALMAT,0)),U))
End DoDot:1
+7 SET VALMBCK="R"
+8 QUIT
+9 ;
UPD(TEXT,FLD,VALMAT) ; -- update data for screen
+1 if VALMCC
DO FLDCTRL^VALM10(+VALMAT,.FLD,.IOINHI,.IOINORM,1)
+2 DO FLDTEXT^VALM10(+VALMAT,.FLD,.TEXT)
+3 QUIT
+4 ;
CHG ; -- change package action
+1 KILL X
IF $DATA(XQORNOD(0))
SET X=$PIECE($PIECE(XQORNOD(0),U,4),"=",2)
+2 IF X=""
READ !!,"Select Package: ",X:DTIME
+3 SET DIC="^DIC(9.4,"
SET DIC(0)="EMQ"
DO ^DIC
KILL DIC
if X["?"
GOTO CHG
+4 IF Y<0
Begin DoDot:1
+5 WRITE !!,*7,"Package has not been changed."
+6 WRITE !
SET DIR(0)="E"
DO ^DIR
KILL DIR
+7 SET VALMBCK=""
End DoDot:1
GOTO CHGQ
+8 DO PKG
DO HDR
SET VALMBCK="R"
SET VALMBG=1
CHGQ QUIT
