ORWTPN ; SLC/STAFF - Personal Preference - Notes ;Mar 15, 2022@10:43:05
;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,149,187,195,405**;Dec 17, 1997;Build 211
;
GETSUB(VALUE,USER) ; from ORWTPP
; get Ask for Subject on notes for user
N NODE
S NODE=+$O(^TIU(8926,"B",USER,0))
S VALUE=+$P($G(^TIU(8926,NODE,0)),U,8)
Q
;
SETSUB(OK,VALUE,USER) ; from ORWTPP
; set Ask for Subject on note for user
N DA,DIE,DIK,DR,NODE,NUM
S OK=1
S VALUE=+$G(VALUE),VALUE=$S(VALUE=1:1,VALUE=0:0,1:"")
I VALUE="" S OK=0 Q
S NODE=+$O(^TIU(8926,"B",USER,0))
I 'NODE D Q ; make new entry if user does not have TIU preferences
.I 'VALUE Q ; no need to set since default for no user preference is 0
.L +^TIU(8926,0):5 I '$T S OK=0 Q
.S NUM=1+$P(^TIU(8926,0),U,3)
.F Q:'$D(^TIU(8926,NUM,0)) S NUM=NUM+1
.S $P(^(0),U,4)=1+$P(^TIU(8926,0),U,4),$P(^(0),U,3)=NUM
.S ^TIU(8926,NUM,0)=USER_"^^^^^^^1"
.L -^TIU(8926,0)
.S DA=NUM,DIK="^TIU(8926,"
.D IX1^DIK
I USER'=+$G(^TIU(8926,NODE,0)) Q
S DA=NODE,DIE="^TIU(8926,",DR=".08///"_VALUE
D ^DIE
Q
;
GETCOS(ORY,ORUSER,ORFROM,ORDIR,ORVIZ,ORSIM) ; Get cosigners for user (from ORWTPP).
; (Keep this code matched with NP1^ORWU1 / NEWPERS^ORWU.)
;
; Params:
; .ORY=returned list, ORFROM=text to $O from, ORDIR=$O direction.
; ORDIR=Direction to move through x-ref.
; ORFROM=Starting value to use.
; ORUSER=User seeking a Cosigner.
; ORVIZ=If true, includes RDV users; otherwise not (optional).
; ORSIM=If true, this indicates that this is a Similar Provider RPC call NSR#20110606/539
;
N OR1DIV,ORCNT,ORDATE,ORDD,ORDIV,ORDUP,ORGOOD,ORI,ORIEN1,ORIEN2,ORKEY,ORLAST,ORMAX,ORMRK,ORMULTI,ORNODE,ORPREV,ORSRV,ORTTL
N ORFNM,ORFNMLEN,ORLNM,OPTIEN,ORDUPNM ; ** NSR 20110606/539 - Add first and last names, first name length and OPTIEN it is the IEN to the OPTION file
N A,ORTAB,S1
;
K ORTAB S S1=0 F S S1=$O(^ORD(101.13,S1)) Q:'S1 S A=$P($G(^ORD(101.13,S1,0)),"^") I A="COR"!(A="NVA") S ORTAB(A)=S1
S ORI=0,ORMAX=44,(ORLAST,ORPREV,ORDUPNM)="",ORKEY=$G(ORKEY),ORDATE=$G(ORDATE),ORSIM=$G(ORSIM) ; NSR 20110606/539 added ORSIM
S OPTIEN=$$LKOPT^XPDMENU("OR CPRS GUI CHART") ;Set IEN to option file - NSR 20110606/539
S ORMULTI=$$ALL^VASITE ; IA# 10112. Do once at beginning of call.
I +ORSIM D ; ** NSR 20110606/539 - If ORSIM, ORFROM is IEN and needs to be changed to name. Also get first name, its length and last name **
.N LASTCHAR,ORFIEN,ORFROM1,XFNM,XFNMLEN
.S ORFIEN=ORFROM
.S (ORFROM,ORFROM1)=$P(^VA(200,ORFROM,0),U),$P(ORFROM,",",2)=$E($P(ORFROM,",",2),1,2)
.S ORFNM=$P(ORFROM,",",2),ORFNMLEN=$L(ORFNM),ORLNM=$P(ORFROM,",") ; ** NSR 20110606/539 - Add ORFNM, ORFNMLEN and ORLNM **
.I ORFNM]"" D
..S XFNM=$P(ORFROM,",",2),XFNMLEN=$L(XFNM),LASTCHAR=$C($A(XFNM,XFNMLEN)-1),XFNM=$E(XFNM,1,XFNMLEN-1)_LASTCHAR_$C(126)
..S $P(ORFROM,",",2)=XFNM
.S ORI=ORI+1,ORY(ORI)=ORFIEN_"^"_$$NAMEFMT^XLFNAME(ORFROM1,"F","DcMPC")
.S ORDUPNM(ORFIEN)=""
.S ORIEN2=ORFIEN
.;Using NP2 instead of NP4(0) in case duplicate (same but different) entry found later
.D NP2^ORWU1
E D
.S (ORFNM,ORFNMLEN,ORLNM)=""
;
; NP3^ORWU1 tag includes visitors, uses full "B" x-ref.
I +$G(ORVIZ)=1 D NP3^ORWU1(1) Q ; Use alt. version, skip rest.
;
F Q:ORI'<ORMAX S ORFROM=$O(^VA(200,"AUSER",ORFROM),ORDIR) Q:ORFROM=""!'$$CHKORSIM^ORWU1(ORSIM,ORFNM,ORFNMLEN,ORFROM,ORLNM) D ; NSR 20110606/539 - Check for quitting with ORSIM and names comparison
.S ORIEN1=""
.F S ORIEN1=$O(^VA(200,"AUSER",ORFROM,ORIEN1),ORDIR) Q:'ORIEN1 D
..I $D(ORDUPNM(ORIEN1)) Q
..; NSR 20120101 Limit Signers by Tabs & Excluded User Class
..I '+$$CPRSTAB^ORWU1(ORIEN1,ORTAB("COR")),'+$$CPRSTAB^ORWU1(ORIEN1,ORTAB("NVA")) Q ; Check core tab & Non-VA tab access including effective date and expiration date
..I '+$$ACCESS^XQCHK(ORIEN1,OPTIEN) Q ;NSR 20110606/539
..; Screen default cosigner selection:
..I '$$SCRDFCS^TIULA3(ORUSER,ORIEN1) Q
..S ORNODE=$P($G(^VA(200,ORIEN1,0)),U)
..I '$L(ORNODE) Q
..I +ORI,+ORY(ORI)=ORIEN1 Q ; if the current IEN is already in list, quit
..S ORI=ORI+1,ORY(ORI)=ORIEN1_"^"_$$NAMEFMT^XLFNAME(ORFROM,"F","DcMPC")
..S ORDUP=0 ; Init flag, check dupe.
..I ($P(ORPREV_" "," ")=$P(ORFROM_" "," ")) S ORDUP=1
..;
..; Append Title if not duplicated:
..I 'ORDUP D
...S ORIEN2=ORIEN1
...D NP4^ORWU1(0) ; Get Title.
...I ORTTL="" Q
...S ORY(ORI)=ORY(ORI)_U_"- "_ORTTL
..;
..; Get data in case of dupes:
..I ORDUP D
...S ORIEN2=ORLAST ; Prev IEN for NP2^ORWU1 call.
...;
...; Reset, use previous array element, call for extended data:
...S ORI=ORI-1,ORY(ORI)=$P(ORY(ORI),U)_U_$P(ORY(ORI),U,2) D NP2^ORWU1
...;
...; Then return to current user for second extended data call:
...S ORIEN2=ORIEN1,ORI=ORI+1 D NP2^ORWU1
..S ORLAST=ORIEN1,ORPREV=ORFROM ; Reassign vars for next pass.
;
Q
;
GETDCOS(VALUE,USER) ; from ORWTPP
; get default cosigner for user
N IEN,NAME,NODE
S NODE=+$O(^TIU(8926,"B",USER,0))
S IEN=+$P($G(^TIU(8926,NODE,0)),U,9)
S NAME=$P($G(^VA(200,IEN,0)),U)
S VALUE=IEN_U_NAME
Q
;
SETDCOS(OK,VALUE,USER) ; from ORWTPP
; set default cosigner for user
N DA,DIE,DIK,DR,NODE,NUM
S OK=1
S VALUE=+$G(VALUE)
I 'VALUE S VALUE="@"
S NODE=+$O(^TIU(8926,"B",USER,0))
I 'NODE D Q ; make new entry if user does not have TIU preferences
.I 'VALUE Q
.I '$$SCRDFCS^TIULA3(USER,VALUE) Q
.L +^TIU(8926,0):5 I '$T S OK=0 Q
.S NUM=1+$P(^TIU(8926,0),U,3)
.F Q:'$D(^TIU(8926,NUM,0)) S NUM=NUM+1
.S $P(^(0),U,4)=1+$P(^TIU(8926,0),U,4),$P(^(0),U,3)=NUM
.S ^TIU(8926,NUM,0)=USER_"^^^^^^^^"_VALUE
.L -^TIU(8926,0)
.S DA=NUM,DIK="^TIU(8926,"
.D IX1^DIK
I USER'=+$G(^TIU(8926,NODE,0)) Q
S DA=NODE,DIE="^TIU(8926,",DR=".09///"_$S(VALUE:"`"_VALUE,1:"@")
D ^DIE
Q
;
GETCLASS(VALUES) ; RPC
; get available document classes
N CNT,NODE,NUM K VALUES
S CNT=0
S NUM=0 F S NUM=$O(^TIU(8925.1,"AT","CL",NUM)) Q:NUM<1 D
.I '$$CLASPICK^TIULA4(38,NUM,"CL") Q
.S NODE=$G(^TIU(8925.1,NUM,0))
.I '$L(NODE) Q
.S CNT=CNT+1
.S VALUES(CNT)=NUM_U_NODE
Q
;
GETTC(VALUES,CLASS,FROM,DIR) ; RPC
; get titles for a class
N CNT,IEN,NODE,NUM K VALUES
S CNT=44,NUM=0
F Q:NUM>CNT S FROM=$O(^TIU(8925.1,"B",FROM),DIR) Q:FROM="" D
.S IEN=0 F S IEN=$O(^TIU(8925.1,"B",FROM,IEN)) Q:IEN<1 D
..I '$D(^TIU(8925.1,"AT","DOC",IEN)) Q
..I '$$ISA^TIULX(IEN,CLASS) Q
..I '$$CANPICK^TIULP(IEN) Q
..I '$$CANENTR^TIULP(IEN) Q
..S NODE=$G(^TIU(8925.1,IEN,0))
..I '$L(NODE) Q
..S NUM=NUM+1
..S VALUES(NUM)=IEN_U_NODE
Q
;
GETTU(VALUES,CLASS,USER) ; from ORWTPP
; get titles for a user
N CNT,IEN,NUM,NUM1,NODE K VALUES
S CNT=0
S NUM=+$O(^TIU(8925.98,"AC",USER,CLASS,0))
I 'NUM Q
S NUM1=0 F S NUM1=$O(^TIU(8925.98,NUM,10,NUM1)) Q:NUM1<1 D
.S IEN=+$G(^TIU(8925.98,NUM,10,NUM1,0))
.S NODE=$P($G(^TIU(8925.1,IEN,0)),U)
.I '$L(NODE) Q
.S CNT=CNT+1
.S VALUES(CNT)=IEN_U_NODE_U_(.0000001*$P(^TIU(8925.98,NUM,10,NUM1,0),U,2))_U_$P(^(0),U,3)
Q
;
GETTD(VALUE,CLASS,USER) ; from ORWTPP
; get default title for user
N IEN,NUM,NODE
S VALUE=-1,USER=+$G(USER)
S NUM=+$O(^TIU(8925.98,"AC",USER,CLASS,0))
I 'NUM Q
S IEN=+$P($G(^TIU(8925.98,NUM,0)),U,3)
S NODE=$G(^TIU(8925.1,IEN,0))
I '$L(NODE) Q
S VALUE=IEN
Q
;
SAVET(OK,CLASS,DEFAULT,VALUES,USER) ; from ORWTPP
; save titles for user
N CNT,DA,DIK,IEN,NUM,VALUE K DA
S CLASS=+$G(CLASS),DEFAULT=+$G(DEFAULT),OK=1
I DEFAULT'>0 S DEFAULT=""
S IEN=+$O(^TIU(8925.98,"AC",USER,CLASS,0))
I IEN D Q
.S DA(1)=IEN
.S DIK="^TIU(8925.98,"_DA(1)_",10,"
.L +^TIU(8925.98,IEN):5 I '$T S OK=0 Q
.S DA=0 F S DA=$O(^TIU(8925.98,IEN,10,DA)) Q:DA<1 D
..D ^DIK
.S CNT=0
.S NUM=0 F S NUM=$O(VALUES(NUM)) Q:NUM<1 D
..S VALUE=+VALUES(NUM) I 'VALUE Q
..S CNT=CNT+1
..S ^TIU(8925.98,IEN,10,CNT,0)=VALUE_U_CNT_U_$P(VALUES(NUM),U,4)
.S ^TIU(8925.98,IEN,10,0)="^8925.9801IP^"_CNT_U_CNT
.S $P(^TIU(8925.98,IEN,0),U,3)=DEFAULT
.K DA S DA=IEN,DIK="^TIU(8925.98,"
.D IX1^DIK
.L -^TIU(8925.98,IEN)
S DA=1+$P(^TIU(8925.98,0),U,3)
L +^TIU(8925.98,0):5 I '$T S OK=0 Q
F Q:'$D(^TIU(8925.98,DA)) S DA=DA+1
S ^TIU(8925.98,DA,0)=USER_U_CLASS_U_DEFAULT
S $P(^(0),U,4)=1+$P(^TIU(8925.98,0),U,4),$P(^(0),U,3)=DA
L -^TIU(8925.98,0)
S CNT=0
S NUM=0 F S NUM=$O(VALUES(NUM)) Q:NUM<1 D
.S VALUE=+VALUES(NUM)
.I 'VALUE Q
.S CNT=CNT+1
.S ^TIU(8925.98,DA,10,CNT,0)=VALUE
S ^TIU(8925.98,DA,10,0)="^8925.9801IP^"_CNT_U_CNT
S DIK="^TIU(8925.98,"
D IX1^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWTPN 8595 printed Apr 09, 2024@21:28:59 Page 2
ORWTPN ; SLC/STAFF - Personal Preference - Notes ;Mar 15, 2022@10:43:05
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,149,187,195,405**;Dec 17, 1997;Build 211
+2 ;
GETSUB(VALUE,USER) ; from ORWTPP
+1 ; get Ask for Subject on notes for user
+2 NEW NODE
+3 SET NODE=+$ORDER(^TIU(8926,"B",USER,0))
+4 SET VALUE=+$PIECE($GET(^TIU(8926,NODE,0)),U,8)
+5 QUIT
+6 ;
SETSUB(OK,VALUE,USER) ; from ORWTPP
+1 ; set Ask for Subject on note for user
+2 NEW DA,DIE,DIK,DR,NODE,NUM
+3 SET OK=1
+4 SET VALUE=+$GET(VALUE)
SET VALUE=$SELECT(VALUE=1:1,VALUE=0:0,1:"")
+5 IF VALUE=""
SET OK=0
QUIT
+6 SET NODE=+$ORDER(^TIU(8926,"B",USER,0))
+7 ; make new entry if user does not have TIU preferences
IF 'NODE
Begin DoDot:1
+8 ; no need to set since default for no user preference is 0
IF 'VALUE
QUIT
+9 LOCK +^TIU(8926,0):5
IF '$TEST
SET OK=0
QUIT
+10 SET NUM=1+$PIECE(^TIU(8926,0),U,3)
+11 FOR
if '$DATA(^TIU(8926,NUM,0))
QUIT
SET NUM=NUM+1
+12 SET $PIECE(^(0),U,4)=1+$PIECE(^TIU(8926,0),U,4)
SET $PIECE(^(0),U,3)=NUM
+13 SET ^TIU(8926,NUM,0)=USER_"^^^^^^^1"
+14 LOCK -^TIU(8926,0)
+15 SET DA=NUM
SET DIK="^TIU(8926,"
+16 DO IX1^DIK
End DoDot:1
QUIT
+17 IF USER'=+$GET(^TIU(8926,NODE,0))
QUIT
+18 SET DA=NODE
SET DIE="^TIU(8926,"
SET DR=".08///"_VALUE
+19 DO ^DIE
+20 QUIT
+21 ;
GETCOS(ORY,ORUSER,ORFROM,ORDIR,ORVIZ,ORSIM) ; Get cosigners for user (from ORWTPP).
+1 ; (Keep this code matched with NP1^ORWU1 / NEWPERS^ORWU.)
+2 ;
+3 ; Params:
+4 ; .ORY=returned list, ORFROM=text to $O from, ORDIR=$O direction.
+5 ; ORDIR=Direction to move through x-ref.
+6 ; ORFROM=Starting value to use.
+7 ; ORUSER=User seeking a Cosigner.
+8 ; ORVIZ=If true, includes RDV users; otherwise not (optional).
+9 ; ORSIM=If true, this indicates that this is a Similar Provider RPC call NSR#20110606/539
+10 ;
+11 NEW OR1DIV,ORCNT,ORDATE,ORDD,ORDIV,ORDUP,ORGOOD,ORI,ORIEN1,ORIEN2,ORKEY,ORLAST,ORMAX,ORMRK,ORMULTI,ORNODE,ORPREV,ORSRV,ORTTL
+12 ; ** NSR 20110606/539 - Add first and last names, first name length and OPTIEN it is the IEN to the OPTION file
NEW ORFNM,ORFNMLEN,ORLNM,OPTIEN,ORDUPNM
+13 NEW A,ORTAB,S1
+14 ;
+15 KILL ORTAB
SET S1=0
FOR
SET S1=$ORDER(^ORD(101.13,S1))
if 'S1
QUIT
SET A=$PIECE($GET(^ORD(101.13,S1,0)),"^")
IF A="COR"!(A="NVA")
SET ORTAB(A)=S1
+16 ; NSR 20110606/539 added ORSIM
SET ORI=0
SET ORMAX=44
SET (ORLAST,ORPREV,ORDUPNM)=""
SET ORKEY=$GET(ORKEY)
SET ORDATE=$GET(ORDATE)
SET ORSIM=$GET(ORSIM)
+17 ;Set IEN to option file - NSR 20110606/539
SET OPTIEN=$$LKOPT^XPDMENU("OR CPRS GUI CHART")
+18 ; IA# 10112. Do once at beginning of call.
SET ORMULTI=$$ALL^VASITE
+19 ; ** NSR 20110606/539 - If ORSIM, ORFROM is IEN and needs to be changed to name. Also get first name, its length and last name **
IF +ORSIM
Begin DoDot:1
+20 NEW LASTCHAR,ORFIEN,ORFROM1,XFNM,XFNMLEN
+21 SET ORFIEN=ORFROM
+22 SET (ORFROM,ORFROM1)=$PIECE(^VA(200,ORFROM,0),U)
SET $PIECE(ORFROM,",",2)=$EXTRACT($PIECE(ORFROM,",",2),1,2)
+23 ; ** NSR 20110606/539 - Add ORFNM, ORFNMLEN and ORLNM **
SET ORFNM=$PIECE(ORFROM,",",2)
SET ORFNMLEN=$LENGTH(ORFNM)
SET ORLNM=$PIECE(ORFROM,",")
+24 IF ORFNM]""
Begin DoDot:2
+25 SET XFNM=$PIECE(ORFROM,",",2)
SET XFNMLEN=$LENGTH(XFNM)
SET LASTCHAR=$CHAR($ASCII(XFNM,XFNMLEN)-1)
SET XFNM=$EXTRACT(XFNM,1,XFNMLEN-1)_LASTCHAR_$CHAR(126)
+26 SET $PIECE(ORFROM,",",2)=XFNM
End DoDot:2
+27 SET ORI=ORI+1
SET ORY(ORI)=ORFIEN_"^"_$$NAMEFMT^XLFNAME(ORFROM1,"F","DcMPC")
+28 SET ORDUPNM(ORFIEN)=""
+29 SET ORIEN2=ORFIEN
+30 ;Using NP2 instead of NP4(0) in case duplicate (same but different) entry found later
+31 DO NP2^ORWU1
End DoDot:1
+32 IF '$TEST
Begin DoDot:1
+33 SET (ORFNM,ORFNMLEN,ORLNM)=""
End DoDot:1
+34 ;
+35 ; NP3^ORWU1 tag includes visitors, uses full "B" x-ref.
+36 ; Use alt. version, skip rest.
IF +$GET(ORVIZ)=1
DO NP3^ORWU1(1)
QUIT
+37 ;
+38 ; NSR 20110606/539 - Check for quitting with ORSIM and names comparison
FOR
if ORI'<ORMAX
QUIT
SET ORFROM=$ORDER(^VA(200,"AUSER",ORFROM),ORDIR)
if ORFROM=""!'$$CHKORSIM^ORWU1(ORSIM,ORFNM,ORFNMLEN,ORFROM,ORLNM)
QUIT
Begin DoDot:1
+39 SET ORIEN1=""
+40 FOR
SET ORIEN1=$ORDER(^VA(200,"AUSER",ORFROM,ORIEN1),ORDIR)
if 'ORIEN1
QUIT
Begin DoDot:2
+41 IF $DATA(ORDUPNM(ORIEN1))
QUIT
+42 ; NSR 20120101 Limit Signers by Tabs & Excluded User Class
+43 ; Check core tab & Non-VA tab access including effective date and expiration date
IF '+$$CPRSTAB^ORWU1(ORIEN1,ORTAB("COR"))
IF '+$$CPRSTAB^ORWU1(ORIEN1,ORTAB("NVA"))
QUIT
+44 ;NSR 20110606/539
IF '+$$ACCESS^XQCHK(ORIEN1,OPTIEN)
QUIT
+45 ; Screen default cosigner selection:
+46 IF '$$SCRDFCS^TIULA3(ORUSER,ORIEN1)
QUIT
+47 SET ORNODE=$PIECE($GET(^VA(200,ORIEN1,0)),U)
+48 IF '$LENGTH(ORNODE)
QUIT
+49 ; if the current IEN is already in list, quit
IF +ORI
IF +ORY(ORI)=ORIEN1
QUIT
+50 SET ORI=ORI+1
SET ORY(ORI)=ORIEN1_"^"_$$NAMEFMT^XLFNAME(ORFROM,"F","DcMPC")
+51 ; Init flag, check dupe.
SET ORDUP=0
+52 IF ($PIECE(ORPREV_" "," ")=$PIECE(ORFROM_" "," "))
SET ORDUP=1
+53 ;
+54 ; Append Title if not duplicated:
+55 IF 'ORDUP
Begin DoDot:3
+56 SET ORIEN2=ORIEN1
+57 ; Get Title.
DO NP4^ORWU1(0)
+58 IF ORTTL=""
QUIT
+59 SET ORY(ORI)=ORY(ORI)_U_"- "_ORTTL
End DoDot:3
+60 ;
+61 ; Get data in case of dupes:
+62 IF ORDUP
Begin DoDot:3
+63 ; Prev IEN for NP2^ORWU1 call.
SET ORIEN2=ORLAST
+64 ;
+65 ; Reset, use previous array element, call for extended data:
+66 SET ORI=ORI-1
SET ORY(ORI)=$PIECE(ORY(ORI),U)_U_$PIECE(ORY(ORI),U,2)
DO NP2^ORWU1
+67 ;
+68 ; Then return to current user for second extended data call:
+69 SET ORIEN2=ORIEN1
SET ORI=ORI+1
DO NP2^ORWU1
End DoDot:3
+70 ; Reassign vars for next pass.
SET ORLAST=ORIEN1
SET ORPREV=ORFROM
End DoDot:2
End DoDot:1
+71 ;
+72 QUIT
+73 ;
GETDCOS(VALUE,USER) ; from ORWTPP
+1 ; get default cosigner for user
+2 NEW IEN,NAME,NODE
+3 SET NODE=+$ORDER(^TIU(8926,"B",USER,0))
+4 SET IEN=+$PIECE($GET(^TIU(8926,NODE,0)),U,9)
+5 SET NAME=$PIECE($GET(^VA(200,IEN,0)),U)
+6 SET VALUE=IEN_U_NAME
+7 QUIT
+8 ;
SETDCOS(OK,VALUE,USER) ; from ORWTPP
+1 ; set default cosigner for user
+2 NEW DA,DIE,DIK,DR,NODE,NUM
+3 SET OK=1
+4 SET VALUE=+$GET(VALUE)
+5 IF 'VALUE
SET VALUE="@"
+6 SET NODE=+$ORDER(^TIU(8926,"B",USER,0))
+7 ; make new entry if user does not have TIU preferences
IF 'NODE
Begin DoDot:1
+8 IF 'VALUE
QUIT
+9 IF '$$SCRDFCS^TIULA3(USER,VALUE)
QUIT
+10 LOCK +^TIU(8926,0):5
IF '$TEST
SET OK=0
QUIT
+11 SET NUM=1+$PIECE(^TIU(8926,0),U,3)
+12 FOR
if '$DATA(^TIU(8926,NUM,0))
QUIT
SET NUM=NUM+1
+13 SET $PIECE(^(0),U,4)=1+$PIECE(^TIU(8926,0),U,4)
SET $PIECE(^(0),U,3)=NUM
+14 SET ^TIU(8926,NUM,0)=USER_"^^^^^^^^"_VALUE
+15 LOCK -^TIU(8926,0)
+16 SET DA=NUM
SET DIK="^TIU(8926,"
+17 DO IX1^DIK
End DoDot:1
QUIT
+18 IF USER'=+$GET(^TIU(8926,NODE,0))
QUIT
+19 SET DA=NODE
SET DIE="^TIU(8926,"
SET DR=".09///"_$SELECT(VALUE:"`"_VALUE,1:"@")
+20 DO ^DIE
+21 QUIT
+22 ;
GETCLASS(VALUES) ; RPC
+1 ; get available document classes
+2 NEW CNT,NODE,NUM
KILL VALUES
+3 SET CNT=0
+4 SET NUM=0
FOR
SET NUM=$ORDER(^TIU(8925.1,"AT","CL",NUM))
if NUM<1
QUIT
Begin DoDot:1
+5 IF '$$CLASPICK^TIULA4(38,NUM,"CL")
QUIT
+6 SET NODE=$GET(^TIU(8925.1,NUM,0))
+7 IF '$LENGTH(NODE)
QUIT
+8 SET CNT=CNT+1
+9 SET VALUES(CNT)=NUM_U_NODE
End DoDot:1
+10 QUIT
+11 ;
GETTC(VALUES,CLASS,FROM,DIR) ; RPC
+1 ; get titles for a class
+2 NEW CNT,IEN,NODE,NUM
KILL VALUES
+3 SET CNT=44
SET NUM=0
+4 FOR
if NUM>CNT
QUIT
SET FROM=$ORDER(^TIU(8925.1,"B",FROM),DIR)
if FROM=""
QUIT
Begin DoDot:1
+5 SET IEN=0
FOR
SET IEN=$ORDER(^TIU(8925.1,"B",FROM,IEN))
if IEN<1
QUIT
Begin DoDot:2
+6 IF '$DATA(^TIU(8925.1,"AT","DOC",IEN))
QUIT
+7 IF '$$ISA^TIULX(IEN,CLASS)
QUIT
+8 IF '$$CANPICK^TIULP(IEN)
QUIT
+9 IF '$$CANENTR^TIULP(IEN)
QUIT
+10 SET NODE=$GET(^TIU(8925.1,IEN,0))
+11 IF '$LENGTH(NODE)
QUIT
+12 SET NUM=NUM+1
+13 SET VALUES(NUM)=IEN_U_NODE
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
GETTU(VALUES,CLASS,USER) ; from ORWTPP
+1 ; get titles for a user
+2 NEW CNT,IEN,NUM,NUM1,NODE
KILL VALUES
+3 SET CNT=0
+4 SET NUM=+$ORDER(^TIU(8925.98,"AC",USER,CLASS,0))
+5 IF 'NUM
QUIT
+6 SET NUM1=0
FOR
SET NUM1=$ORDER(^TIU(8925.98,NUM,10,NUM1))
if NUM1<1
QUIT
Begin DoDot:1
+7 SET IEN=+$GET(^TIU(8925.98,NUM,10,NUM1,0))
+8 SET NODE=$PIECE($GET(^TIU(8925.1,IEN,0)),U)
+9 IF '$LENGTH(NODE)
QUIT
+10 SET CNT=CNT+1
+11 SET VALUES(CNT)=IEN_U_NODE_U_(.0000001*$PIECE(^TIU(8925.98,NUM,10,NUM1,0),U,2))_U_$PIECE(^(0),U,3)
End DoDot:1
+12 QUIT
+13 ;
GETTD(VALUE,CLASS,USER) ; from ORWTPP
+1 ; get default title for user
+2 NEW IEN,NUM,NODE
+3 SET VALUE=-1
SET USER=+$GET(USER)
+4 SET NUM=+$ORDER(^TIU(8925.98,"AC",USER,CLASS,0))
+5 IF 'NUM
QUIT
+6 SET IEN=+$PIECE($GET(^TIU(8925.98,NUM,0)),U,3)
+7 SET NODE=$GET(^TIU(8925.1,IEN,0))
+8 IF '$LENGTH(NODE)
QUIT
+9 SET VALUE=IEN
+10 QUIT
+11 ;
SAVET(OK,CLASS,DEFAULT,VALUES,USER) ; from ORWTPP
+1 ; save titles for user
+2 NEW CNT,DA,DIK,IEN,NUM,VALUE
KILL DA
+3 SET CLASS=+$GET(CLASS)
SET DEFAULT=+$GET(DEFAULT)
SET OK=1
+4 IF DEFAULT'>0
SET DEFAULT=""
+5 SET IEN=+$ORDER(^TIU(8925.98,"AC",USER,CLASS,0))
+6 IF IEN
Begin DoDot:1
+7 SET DA(1)=IEN
+8 SET DIK="^TIU(8925.98,"_DA(1)_",10,"
+9 LOCK +^TIU(8925.98,IEN):5
IF '$TEST
SET OK=0
QUIT
+10 SET DA=0
FOR
SET DA=$ORDER(^TIU(8925.98,IEN,10,DA))
if DA<1
QUIT
Begin DoDot:2
+11 DO ^DIK
End DoDot:2
+12 SET CNT=0
+13 SET NUM=0
FOR
SET NUM=$ORDER(VALUES(NUM))
if NUM<1
QUIT
Begin DoDot:2
+14 SET VALUE=+VALUES(NUM)
IF 'VALUE
QUIT
+15 SET CNT=CNT+1
+16 SET ^TIU(8925.98,IEN,10,CNT,0)=VALUE_U_CNT_U_$PIECE(VALUES(NUM),U,4)
End DoDot:2
+17 SET ^TIU(8925.98,IEN,10,0)="^8925.9801IP^"_CNT_U_CNT
+18 SET $PIECE(^TIU(8925.98,IEN,0),U,3)=DEFAULT
+19 KILL DA
SET DA=IEN
SET DIK="^TIU(8925.98,"
+20 DO IX1^DIK
+21 LOCK -^TIU(8925.98,IEN)
End DoDot:1
QUIT
+22 SET DA=1+$PIECE(^TIU(8925.98,0),U,3)
+23 LOCK +^TIU(8925.98,0):5
IF '$TEST
SET OK=0
QUIT
+24 FOR
if '$DATA(^TIU(8925.98,DA))
QUIT
SET DA=DA+1
+25 SET ^TIU(8925.98,DA,0)=USER_U_CLASS_U_DEFAULT
+26 SET $PIECE(^(0),U,4)=1+$PIECE(^TIU(8925.98,0),U,4)
SET $PIECE(^(0),U,3)=DA
+27 LOCK -^TIU(8925.98,0)
+28 SET CNT=0
+29 SET NUM=0
FOR
SET NUM=$ORDER(VALUES(NUM))
if NUM<1
QUIT
Begin DoDot:1
+30 SET VALUE=+VALUES(NUM)
+31 IF 'VALUE
QUIT
+32 SET CNT=CNT+1
+33 SET ^TIU(8925.98,DA,10,CNT,0)=VALUE
End DoDot:1
+34 SET ^TIU(8925.98,DA,10,0)="^8925.9801IP^"_CNT_U_CNT
+35 SET DIK="^TIU(8925.98,"
+36 DO IX1^DIK
+37 QUIT
