- XUSER1 ;ISF/RWF - User file Utilities ;09/30/09 16:38
- ;;8.0;KERNEL;**169,210,222,514**;Jul 10, 1995;Build 14
- Q
- ;
- PAGE() ;Do a page break; Return 0 if ok to continue, 1 if to abort
- N DIR
- S DIR(0)="E" D ^DIR:($E(IOST,1,2)["C-")
- Q:$D(DIRUT) 1 W @IOF S ($X,$Y)=0
- Q 0
- ;
- GKEYS(IE,XUA) ;Get the keys held. IE=user
- N %,V,XUB
- S %=0 ;Sort list alphabetical
- F S %=$O(^VA(200,IE,51,%)) Q:(%'>0) S V=$P($G(^DIC(19.1,%,0)),U,1) I $L(V) S XUB(V)=""
- S V="" ;return to user
- F %=1:1 S V=$O(XUB(V)) Q:'$L(V) S XUA(%)=V
- Q
- ;
- SHLIST(ARRAY,LM,SP) ; Show a list, Array=list, LM=Left Margin, SP=spacing
- ;Set DN=0 to get FM22 to stop the print
- N %,Y2,Y4,Y5,Y6,DIR
- I $Y+4>IOSL,$$PAGE S DN=0 Q
- S Y4=-1,%=0,Y2=IOM-LM\SP,Y5=0
- F S %=$O(ARRAY(%)),Y4=Y4+1 Q:(%'>0)!$D(DIRUT) S Y6=$G(ARRAY(%)) D:$L(Y6)
- . S:Y4'<SP Y4=0 S Y5=(Y4*Y2+LM)
- . I $X>0,Y5+$L(Y6)'<IOM S Y4=0,Y5=(Y4*Y2+LM)
- . I 'Y4 W ! I $Y+3>IOSL S Y4=0,Y5=(Y4*Y2+LM) I $$PAGE S DN=0 Q
- . W ?Y5,Y6 S:(($X+1)>(Y5+Y2)) Y4=Y4+1
- . Q
- Q
- ;
- SHPC(IE) ;Show the Person Class
- N %,Y S:'$D(DT) DT=$$DT^XLFDT
- S %=$X,Y=$$GET^XUA4A72(IE,DT)
- I $L(Y) W $P(Y,U,2) I $L($P(Y,U,3)) W !,?(%+2),$P(Y,U,3) I $L($P(Y,U,4)) W !,?(%+4),$P(Y,U,4)
- Q
- GMG(IE,XUA) ;Get mail groups
- N %,Y,XUI,Y4,Y2,XUK
- S %=0
- F S %=$O(^XMB(3.8,"AB",IE,%)) Q:%'>0 S XUA(%)=$P($G(^XMB(3.8,%,0)),U,1)
- Q
- GPARAM(IE,PRAM,XUA) ;Get an entry from the Parameter tool
- ;IE is the user to get the list for. PARAM what parameter, XUA return array.
- N XUENT,XUX,XUERR,XU1
- S XUENT=IE_";VA(200,"_$S($G(^VA(200,IE,5)):"^SRV.`"_+$G(^(5)),1:""),XUA=""
- D GETLST^XPAR(.XUX,XUENT,PRAM,"E",.XUERR)
- Q:XUX'>0
- S XUA(.5)=PRAM_":"
- F %=1:1:XUX S XUA(%)=$P(XUX(%),U,2)
- Q
- ;
- DIVCHG ;Allow user to change Division [DUZ(2)] value
- ;Called from option: XUSER DIV CHG
- N Y,X,DIC,I,CD
- I '$D(^VA(200,+$G(DUZ),0))#2 W !,"You are not a valid user.",!!,$C(7) Q
- I $G(DUZ(2))="" D ;Should not happen
- . N XOPT D XOPT^XUS1A S DUZ(2)=$P(XOPT,U,17)
- S CD=$$NS^XUAF4(DUZ(2))
- W !,"Your current Division is ",$P(CD,U)_" "_$P(CD,U,2)
- S X=+$O(^VA(200,DUZ,2,0)),Y=+$O(^(X))
- I 'Y W !,"You do not have any choices. ",!," Change is not possible.",!! Q
- K DIC S DIC="^VA(200,DUZ,2,",DIC(0)="AEMNQ"
- S DIC("S")="I $G(^DIC(4,+Y,99))"
- ;Check if user has a default
- S X=$O(^VA(200,DUZ,2,"AX1",1,0)) S:X>0 DIC("B")=$P($$NS^XUAF4(X),U)
- D ^DIC K DIC
- I Y'>0 D Q
- .W !,$C(7),"Division Unchanged - Currently you are assigned to "
- .W $P(CD,U)_" "_$P(CD,U,2),!
- S DUZ(2)=+Y,CD=$$NS^XUAF4(DUZ(2))
- W !?5,"Division is now set to [ ",$P(CD,U)_" "_$P(CD,U,2)," ]",!
- Q
- ;
- NETNM(NM,IEN) ;Check NetName, Called from input transform for field 501.1 NPF.
- ;Return 1 to abort, 0 to allow
- N NPF,OV
- S NPF(0)=$P($G(^VA(200,IEN,0)),U,1),OV=0
- I $E(NM,1,3)'="VHA" D EN^DDIOL("WARNING: Prefix not VHA.","") S OV=1
- S NPF(1)=$E($P(NPF(0),","),1,5)_$E($P(NPF(0),",",2),1)
- I $E(NM,7,6+$L(NPF(1)))'=NPF(1) D EN^DDIOL("WARNING: Missing "_NPF(1)_" from username.","") S OV=1
- I OV S OV='((DUZ(0)["@")!$D(^XUSEC("XUMGR",DUZ)))
- Q OV
- ;
- XUSER1 ;ISF/RWF - User file Utilities ;09/30/09 16:38
- +1 ;;8.0;KERNEL;**169,210,222,514**;Jul 10, 1995;Build 14
- +2 QUIT
- +3 ;
- PAGE() ;Do a page break; Return 0 if ok to continue, 1 if to abort
- +1 NEW DIR
- +2 SET DIR(0)="E"
- IF ($EXTRACT(IOST,1,2)["C-")
- DO ^DIR
- +3 IF $DATA(DIRUT)
- QUIT 1
- WRITE @IOF
- SET ($X,$Y)=0
- +4 QUIT 0
- +5 ;
- GKEYS(IE,XUA) ;Get the keys held. IE=user
- +1 NEW %,V,XUB
- +2 ;Sort list alphabetical
- SET %=0
- +3 FOR
- SET %=$ORDER(^VA(200,IE,51,%))
- IF (%'>0)
- QUIT
- SET V=$PIECE($GET(^DIC(19.1,%,0)),U,1)
- IF $LENGTH(V)
- SET XUB(V)=""
- +4 ;return to user
- SET V=""
- +5 FOR %=1:1
- SET V=$ORDER(XUB(V))
- IF '$LENGTH(V)
- QUIT
- SET XUA(%)=V
- +6 QUIT
- +7 ;
- SHLIST(ARRAY,LM,SP) ; Show a list, Array=list, LM=Left Margin, SP=spacing
- +1 ;Set DN=0 to get FM22 to stop the print
- +2 NEW %,Y2,Y4,Y5,Y6,DIR
- +3 IF $Y+4>IOSL
- IF $$PAGE
- SET DN=0
- QUIT
- +4 SET Y4=-1
- SET %=0
- SET Y2=IOM-LM\SP
- SET Y5=0
- +5 FOR
- SET %=$ORDER(ARRAY(%))
- SET Y4=Y4+1
- IF (%'>0)!$DATA(DIRUT)
- QUIT
- SET Y6=$GET(ARRAY(%))
- IF $LENGTH(Y6)
- Begin DoDot:1
- +6 IF Y4'<SP
- SET Y4=0
- SET Y5=(Y4*Y2+LM)
- +7 IF $X>0
- IF Y5+$LENGTH(Y6)'<IOM
- SET Y4=0
- SET Y5=(Y4*Y2+LM)
- +8 IF 'Y4
- WRITE !
- IF $Y+3>IOSL
- SET Y4=0
- SET Y5=(Y4*Y2+LM)
- IF $$PAGE
- SET DN=0
- QUIT
- +9 WRITE ?Y5,Y6
- IF (($X+1)>(Y5+Y2))
- SET Y4=Y4+1
- +10 QUIT
- End DoDot:1
- +11 QUIT
- +12 ;
- SHPC(IE) ;Show the Person Class
- +1 NEW %,Y
- IF '$DATA(DT)
- SET DT=$$DT^XLFDT
- +2 SET %=$X
- SET Y=$$GET^XUA4A72(IE,DT)
- +3 IF $LENGTH(Y)
- WRITE $PIECE(Y,U,2)
- IF $LENGTH($PIECE(Y,U,3))
- WRITE !,?(%+2),$PIECE(Y,U,3)
- IF $LENGTH($PIECE(Y,U,4))
- WRITE !,?(%+4),$PIECE(Y,U,4)
- +4 QUIT
- GMG(IE,XUA) ;Get mail groups
- +1 NEW %,Y,XUI,Y4,Y2,XUK
- +2 SET %=0
- +3 FOR
- SET %=$ORDER(^XMB(3.8,"AB",IE,%))
- IF %'>0
- QUIT
- SET XUA(%)=$PIECE($GET(^XMB(3.8,%,0)),U,1)
- +4 QUIT
- GPARAM(IE,PRAM,XUA) ;Get an entry from the Parameter tool
- +1 ;IE is the user to get the list for. PARAM what parameter, XUA return array.
- +2 NEW XUENT,XUX,XUERR,XU1
- +3 SET XUENT=IE_";VA(200,"_$SELECT($GET(^VA(200,IE,5)):"^SRV.`"_+$GET(^(5)),1:"")
- SET XUA=""
- +4 DO GETLST^XPAR(.XUX,XUENT,PRAM,"E",.XUERR)
- +5 IF XUX'>0
- QUIT
- +6 SET XUA(.5)=PRAM_":"
- +7 FOR %=1:1:XUX
- SET XUA(%)=$PIECE(XUX(%),U,2)
- +8 QUIT
- +9 ;
- DIVCHG ;Allow user to change Division [DUZ(2)] value
- +1 ;Called from option: XUSER DIV CHG
- +2 NEW Y,X,DIC,I,CD
- +3 IF '$DATA(^VA(200,+$GET(DUZ),0))#2
- WRITE !,"You are not a valid user.",!!,$CHAR(7)
- QUIT
- +4 ;Should not happen
- IF $GET(DUZ(2))=""
- Begin DoDot:1
- +5 NEW XOPT
- DO XOPT^XUS1A
- SET DUZ(2)=$PIECE(XOPT,U,17)
- End DoDot:1
- +6 SET CD=$$NS^XUAF4(DUZ(2))
- +7 WRITE !,"Your current Division is ",$PIECE(CD,U)_" "_$PIECE(CD,U,2)
- +8 SET X=+$ORDER(^VA(200,DUZ,2,0))
- SET Y=+$ORDER(^(X))
- +9 IF 'Y
- WRITE !,"You do not have any choices. ",!," Change is not possible.",!!
- QUIT
- +10 KILL DIC
- SET DIC="^VA(200,DUZ,2,"
- SET DIC(0)="AEMNQ"
- +11 SET DIC("S")="I $G(^DIC(4,+Y,99))"
- +12 ;Check if user has a default
- +13 SET X=$ORDER(^VA(200,DUZ,2,"AX1",1,0))
- IF X>0
- SET DIC("B")=$PIECE($$NS^XUAF4(X),U)
- +14 DO ^DIC
- KILL DIC
- +15 IF Y'>0
- Begin DoDot:1
- +16 WRITE !,$CHAR(7),"Division Unchanged - Currently you are assigned to "
- +17 WRITE $PIECE(CD,U)_" "_$PIECE(CD,U,2),!
- End DoDot:1
- QUIT
- +18 SET DUZ(2)=+Y
- SET CD=$$NS^XUAF4(DUZ(2))
- +19 WRITE !?5,"Division is now set to [ ",$PIECE(CD,U)_" "_$PIECE(CD,U,2)," ]",!
- +20 QUIT
- +21 ;
- NETNM(NM,IEN) ;Check NetName, Called from input transform for field 501.1 NPF.
- +1 ;Return 1 to abort, 0 to allow
- +2 NEW NPF,OV
- +3 SET NPF(0)=$PIECE($GET(^VA(200,IEN,0)),U,1)
- SET OV=0
- +4 IF $EXTRACT(NM,1,3)'="VHA"
- DO EN^DDIOL("WARNING: Prefix not VHA.","")
- SET OV=1
- +5 SET NPF(1)=$EXTRACT($PIECE(NPF(0),","),1,5)_$EXTRACT($PIECE(NPF(0),",",2),1)
- +6 IF $EXTRACT(NM,7,6+$LENGTH(NPF(1)))'=NPF(1)
- DO EN^DDIOL("WARNING: Missing "_NPF(1)_" from username.","")
- SET OV=1
- +7 IF OV
- SET OV='((DUZ(0)["@")!$DATA(^XUSEC("XUMGR",DUZ)))
- +8 QUIT OV
- +9 ;
