USRCLASS ; SLC/JER - User Class Management actions ; 12/14/15 9:34am
;;1.0;AUTHORIZATION/SUBSCRIPTION;**7,11,33,37**;Sep 25, 2015;Build 31
;Per VA Directive 6402, this routine should not be modified
;
; External References DBIA#
; POSTX^HMPEVNT 6301
;
EDIT ; Edit user classes
N USRDA,USRDATA,USREXPND,USRI,USRSTAT,DIROUT,USRCHNG
N USRLST,NAME,NAME1,NAME2,LINE,CANTMSG,DA
D:'$D(VALMY) EN^VALM2(XQORNOD(0)) S USRI=0,USRCHNG=0
F S USRI=$O(VALMY(USRI)) Q:+USRI'>0 D Q:$D(DIROUT)!(+$P(USRDATA,U,2)'>0)
. S USRDATA=$S(VALMAR="^TMP(""USRCLASS"",$J)":$G(^TMP("USRCLASSIDX",$J,USRI)),1:$G(^TMP("USREXPIDX",$J,USRI)))
. I (+$P(USRDATA,U,2)'>0) D Q
. . S CANTMSG=1,VALMBCK="Q",USRCHNG=0
. W !!,"Editing #",+USRDATA,!
. S USRDA=+$P(USRDATA,U,2)
. S NAME=$P(^USR(8930,USRDA,0),U),NAME1="|_ "_NAME,NAME2="-"_NAME
. S LINE=^TMP("USRCLASS",$J,USRI,0)
. D EDIT1
. I (LINE[NAME1)!(LINE[NAME2) D Q
. . S CANTMSG=1,VALMBCK="Q",USRCHNG=0
. I +$G(USRCHNG) S USRLST=$S($L($G(USRLST)):$G(USRLST)_", ",1:"")_USRI
. I $D(USRDATA) D
.. D UPDATE^USRL(USRDATA)
.. I $D(DA) D POSTX^HMPEVNT("asu-class",USRDA) ; asu class was changed DBIA 6301
.. I '$D(DA) D POSTX^HMPEVNT("asu-class",USRDA,"@") ; asu class was deleted DBIA 6301
.. ;D ECLASS^HMPAT ;send edits to HMP
Q:$D(DIROUT)
I $D(CANTMSG) D K VALMY S VALMBCK="Q" Q
. W !!," Expanded entries cannot be refreshed; please re-enter the option"
. W !,"to see the result of your edits." H 3
W !," Refreshing the list. If expanded entries require refreshing please"
W !,"collapse and re-expand the entries." H 2
S VALMSG="** "_$S($L($G(USRLST)):"Item"_$S($L($G(USRLST),",")>1:"s ",1:" ")_$G(USRLST),1:"Nothing")_" Edited **"
K VALMY S VALMBCK="R"
Q
EDIT1 ; Single record edit
; Receives USRDA
N DIE,DR
I '+$G(USRDA) W !,"No Classes selected." H 2 Q
S DIE="^USR(8930,",DA=USRDA,DR="[USR CLASS STRUCTURE EDIT]"
D FULL^VALM1,^DIE
S USRCHNG=1 ;Needs check if not really changed.
Q
EXPAND ; Expand/Collapse user class hierarchy display
N USRDNM,USRLNM,USRSTAT,USRVALMY
D:'$D(VALMY) EN^VALM2(XQORNOD(0))
I $D(VALMY) M USRVALMY=VALMY D EC^USRECCL(.USRVALMY)
W !,"Refreshing the list."
K VALMY S VALMBCK="R"
S USRSTAT=+$P($G(^TMP("USRCLASS",$J,0)),U,2)
S USRDNM=$P($G(^TMP("USRCLASS",$J,0)),U,3)
S USRLNM=$P($G(^TMP("USRCLASS",$J,0)),U,4)
S VALMCNT=+$G(@VALMAR@(0))
S VALMBCK="R"
Q
CREATE ; Class constructor
N USRCREAT
N DIC,DLAYGO,X,Y,USRSTAT,USRDNM,USRLNM D FULL^VALM1
S (DIC,DLAYGO)=8930,DIC(0)="AELMQ",DIC("A")="Select CLASS: "
D ^DIC Q:+Y'>0
S USRCREAT=+$P(Y,U,3)
S DA=+Y,DIE=DIC,DIE("NO^")="BACK",DR="[USR CLASS STRUCTURE EDIT]"
D ^DIE
S USRSTAT=+$P($G(^TMP("USRCLASS",$J,0)),U,2)
S USRDNM=$P($G(^TMP("USRCLASS",$J,0)),U,3)
S USRLNM=$P($G(^TMP("USRCLASS",$J,0)),U,4)
I 'USRCREAT Q ; Don't rebuild without cause
;send new class to HMP via VxSync
D POSTX^HMPEVNT("asu-class",DA) ;DBIA 6301
;D ECLASS^HMPAT ;send edits to HMP
D BUILD^USRCLST(USRSTAT,USRDNM,USRLNM)
S VALMCNT=+$G(@VALMAR@(0))
S VALMBCK="R"
Q
MEMBERS ; List Members of classes and their subclasses
N USRDA,USRDATA,USREXPND,USRI,USRSTAT,VALMCNT,DIROUT
D:'$D(VALMY) EN^VALM2(XQORNOD(0)) S USRI=0
F S USRI=$O(VALMY(USRI)) Q:+USRI'>0 D Q:$D(DIROUT)
. S USRDATA=$S(VALMAR="^TMP(""USRCLASS"",$J)":$G(^TMP("USRCLASSIDX",$J,USRI)),1:$G(^TMP("USREXPIDX",$J,USRI)))
. W !!,"Listing Members of #",+USRDATA,!
. S USRDA=+$P(USRDATA,U,2) D EN^VALM("USR LIST MEMBERSHIP BY CLASS")
. I $D(USRDATA) D UPDATE^USRL(USRDATA)
W !,"Refreshing the list."
S VALMSG="Members listed"
K VALMY S VALMBCK="R"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HUSRCLASS 3677 printed Dec 13, 2024@01:38:39 Page 2
USRCLASS ; SLC/JER - User Class Management actions ; 12/14/15 9:34am
+1 ;;1.0;AUTHORIZATION/SUBSCRIPTION;**7,11,33,37**;Sep 25, 2015;Build 31
+2 ;Per VA Directive 6402, this routine should not be modified
+3 ;
+4 ; External References DBIA#
+5 ; POSTX^HMPEVNT 6301
+6 ;
EDIT ; Edit user classes
+1 NEW USRDA,USRDATA,USREXPND,USRI,USRSTAT,DIROUT,USRCHNG
+2 NEW USRLST,NAME,NAME1,NAME2,LINE,CANTMSG,DA
+3 if '$DATA(VALMY)
DO EN^VALM2(XQORNOD(0))
SET USRI=0
SET USRCHNG=0
+4 FOR
SET USRI=$ORDER(VALMY(USRI))
if +USRI'>0
QUIT
Begin DoDot:1
+5 SET USRDATA=$SELECT(VALMAR="^TMP(""USRCLASS"",$J)":$GET(^TMP("USRCLASSIDX",$JOB,USRI)),1:$GET(^TMP("USREXPIDX",$JOB,USRI)))
+6 IF (+$PIECE(USRDATA,U,2)'>0)
Begin DoDot:2
+7 SET CANTMSG=1
SET VALMBCK="Q"
SET USRCHNG=0
End DoDot:2
QUIT
+8 WRITE !!,"Editing #",+USRDATA,!
+9 SET USRDA=+$PIECE(USRDATA,U,2)
+10 SET NAME=$PIECE(^USR(8930,USRDA,0),U)
SET NAME1="|_ "_NAME
SET NAME2="-"_NAME
+11 SET LINE=^TMP("USRCLASS",$JOB,USRI,0)
+12 DO EDIT1
+13 IF (LINE[NAME1)!(LINE[NAME2)
Begin DoDot:2
+14 SET CANTMSG=1
SET VALMBCK="Q"
SET USRCHNG=0
End DoDot:2
QUIT
+15 IF +$GET(USRCHNG)
SET USRLST=$SELECT($LENGTH($GET(USRLST)):$GET(USRLST)_", ",1:"")_USRI
+16 IF $DATA(USRDATA)
Begin DoDot:2
+17 DO UPDATE^USRL(USRDATA)
+18 ; asu class was changed DBIA 6301
IF $DATA(DA)
DO POSTX^HMPEVNT("asu-class",USRDA)
+19 ; asu class was deleted DBIA 6301
IF '$DATA(DA)
DO POSTX^HMPEVNT("asu-class",USRDA,"@")
+20 ;D ECLASS^HMPAT ;send edits to HMP
End DoDot:2
End DoDot:1
if $DATA(DIROUT)!(+$PIECE(USRDATA,U,2)'>0)
QUIT
+21 if $DATA(DIROUT)
QUIT
+22 IF $DATA(CANTMSG)
Begin DoDot:1
+23 WRITE !!," Expanded entries cannot be refreshed; please re-enter the option"
+24 WRITE !,"to see the result of your edits."
HANG 3
End DoDot:1
KILL VALMY
SET VALMBCK="Q"
QUIT
+25 WRITE !," Refreshing the list. If expanded entries require refreshing please"
+26 WRITE !,"collapse and re-expand the entries."
HANG 2
+27 SET VALMSG="** "_$SELECT($LENGTH($GET(USRLST)):"Item"_$SELECT($LENGTH($GET(USRLST),",")>1:"s ",1:" ")_$GET(USRLST),1:"Nothing")_" Edited **"
+28 KILL VALMY
SET VALMBCK="R"
+29 QUIT
EDIT1 ; Single record edit
+1 ; Receives USRDA
+2 NEW DIE,DR
+3 IF '+$GET(USRDA)
WRITE !,"No Classes selected."
HANG 2
QUIT
+4 SET DIE="^USR(8930,"
SET DA=USRDA
SET DR="[USR CLASS STRUCTURE EDIT]"
+5 DO FULL^VALM1
DO ^DIE
+6 ;Needs check if not really changed.
SET USRCHNG=1
+7 QUIT
EXPAND ; Expand/Collapse user class hierarchy display
+1 NEW USRDNM,USRLNM,USRSTAT,USRVALMY
+2 if '$DATA(VALMY)
DO EN^VALM2(XQORNOD(0))
+3 IF $DATA(VALMY)
MERGE USRVALMY=VALMY
DO EC^USRECCL(.USRVALMY)
+4 WRITE !,"Refreshing the list."
+5 KILL VALMY
SET VALMBCK="R"
+6 SET USRSTAT=+$PIECE($GET(^TMP("USRCLASS",$JOB,0)),U,2)
+7 SET USRDNM=$PIECE($GET(^TMP("USRCLASS",$JOB,0)),U,3)
+8 SET USRLNM=$PIECE($GET(^TMP("USRCLASS",$JOB,0)),U,4)
+9 SET VALMCNT=+$GET(@VALMAR@(0))
+10 SET VALMBCK="R"
+11 QUIT
CREATE ; Class constructor
+1 NEW USRCREAT
+2 NEW DIC,DLAYGO,X,Y,USRSTAT,USRDNM,USRLNM
DO FULL^VALM1
+3 SET (DIC,DLAYGO)=8930
SET DIC(0)="AELMQ"
SET DIC("A")="Select CLASS: "
+4 DO ^DIC
if +Y'>0
QUIT
+5 SET USRCREAT=+$PIECE(Y,U,3)
+6 SET DA=+Y
SET DIE=DIC
SET DIE("NO^")="BACK"
SET DR="[USR CLASS STRUCTURE EDIT]"
+7 DO ^DIE
+8 SET USRSTAT=+$PIECE($GET(^TMP("USRCLASS",$JOB,0)),U,2)
+9 SET USRDNM=$PIECE($GET(^TMP("USRCLASS",$JOB,0)),U,3)
+10 SET USRLNM=$PIECE($GET(^TMP("USRCLASS",$JOB,0)),U,4)
+11 ; Don't rebuild without cause
IF 'USRCREAT
QUIT
+12 ;send new class to HMP via VxSync
+13 ;DBIA 6301
DO POSTX^HMPEVNT("asu-class",DA)
+14 ;D ECLASS^HMPAT ;send edits to HMP
+15 DO BUILD^USRCLST(USRSTAT,USRDNM,USRLNM)
+16 SET VALMCNT=+$GET(@VALMAR@(0))
+17 SET VALMBCK="R"
+18 QUIT
MEMBERS ; List Members of classes and their subclasses
+1 NEW USRDA,USRDATA,USREXPND,USRI,USRSTAT,VALMCNT,DIROUT
+2 if '$DATA(VALMY)
DO EN^VALM2(XQORNOD(0))
SET USRI=0
+3 FOR
SET USRI=$ORDER(VALMY(USRI))
if +USRI'>0
QUIT
Begin DoDot:1
+4 SET USRDATA=$SELECT(VALMAR="^TMP(""USRCLASS"",$J)":$GET(^TMP("USRCLASSIDX",$JOB,USRI)),1:$GET(^TMP("USREXPIDX",$JOB,USRI)))
+5 WRITE !!,"Listing Members of #",+USRDATA,!
+6 SET USRDA=+$PIECE(USRDATA,U,2)
DO EN^VALM("USR LIST MEMBERSHIP BY CLASS")
+7 IF $DATA(USRDATA)
DO UPDATE^USRL(USRDATA)
End DoDot:1
if $DATA(DIROUT)
QUIT
+8 WRITE !,"Refreshing the list."
+9 SET VALMSG="Members listed"
+10 KILL VALMY
SET VALMBCK="R"
+11 QUIT
