Routine: VALMD

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)

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

FNL ; -- clean up

 K DIE,DIC,DR,DA,DE,DQ,VALMY,VALMPKG,^TMP("VALMZIDX",$J)

 D CLEAN^VALM10

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."

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

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"

UPD(TEXT,FLD,VALMAT) ; -- update data for screen

 D:VALMCC FLDCTRL^VALM10(+VALMAT,.FLD,.IOINHI,.IOINORM,1)

 D FLDTEXT^VALM10(+VALMAT,.FLD,.TEXT)

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  Feb 18, 2025@23:36:28                                                                                                                                                                                                       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

VALMD.m