ORWTPN ; SLC/STAFF Personal Preference - Notes ;2/21/01 08:11 [1/29/04 2:32pm]
;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,149,187,195**;Dec 17, 1997
;
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) ; 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).
;
N OR1DIV,ORCNT,ORDATE,ORDD,ORDIV,ORDUP,ORGOOD,ORI,ORIEN1,ORIEN2,ORKEY,ORLAST,ORMAX,ORMRK,ORMULTI,ORNODE,ORPREV,ORSRV,ORTTL
;
S ORI=0,ORMAX=44,(ORLAST,ORPREV)="",ORKEY=$G(ORKEY),ORDATE=$G(ORDATE)
S ORMULTI=$$ALL^VASITE ; Do once at beginning of call.
;
; 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="" D
.S ORIEN1=""
.F S ORIEN1=$O(^VA(200,"AUSER",ORFROM,ORIEN1),ORDIR) Q:'ORIEN1 D
..;
..; Screen default cosigner selection:
..I '$$SCRDFCS^TIULA3(ORUSER,ORIEN1) Q
..S ORNODE=$P($G(^VA(200,ORIEN1,0)),U)
..I '$L(ORNODE) Q
..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
ORWTPN ; SLC/STAFF Personal Preference - Notes ;2/21/01 08:11 [1/29/04 2:32pm]
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,149,187,195**;Dec 17, 1997
+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) ; 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 ;
+10 NEW OR1DIV,ORCNT,ORDATE,ORDD,ORDIV,ORDUP,ORGOOD,ORI,ORIEN1,ORIEN2,ORKEY,ORLAST,ORMAX,ORMRK,ORMULTI,ORNODE,ORPREV,ORSRV,ORTTL
+11 ;
+12 SET ORI=0
SET ORMAX=44
SET (ORLAST,ORPREV)=""
SET ORKEY=$GET(ORKEY)
SET ORDATE=$GET(ORDATE)
+13 ; Do once at beginning of call.
SET ORMULTI=$$ALL^VASITE
+14 ;
+15 ; NP3^ORWU1 tag includes visitors, uses full "B" x-ref.
+16 ; Use alt. version, skip rest.
IF +$GET(ORVIZ)=1
DO NP3^ORWU1(1)
QUIT
+17 ;
+18 FOR
IF ORI'<ORMAX
QUIT
SET ORFROM=$ORDER(^VA(200,"AUSER",ORFROM),ORDIR)
IF ORFROM=""
QUIT
Begin DoDot:1
+19 SET ORIEN1=""
+20 FOR
SET ORIEN1=$ORDER(^VA(200,"AUSER",ORFROM,ORIEN1),ORDIR)
IF 'ORIEN1
QUIT
Begin DoDot:2
+21 ;
+22 ; Screen default cosigner selection:
+23 IF '$$SCRDFCS^TIULA3(ORUSER,ORIEN1)
QUIT
+24 SET ORNODE=$PIECE($GET(^VA(200,ORIEN1,0)),U)
+25 IF '$LENGTH(ORNODE)
QUIT
+26 SET ORI=ORI+1
SET ORY(ORI)=ORIEN1_"^"_$$NAMEFMT^XLFNAME(ORFROM,"F","DcMPC")
+27 ; Init flag, check dupe.
SET ORDUP=0
+28 IF ($PIECE(ORPREV_" "," ")=$PIECE(ORFROM_" "," "))
SET ORDUP=1
+29 ;
+30 ; Append Title if not duplicated:
+31 IF 'ORDUP
Begin DoDot:3
+32 SET ORIEN2=ORIEN1
+33 ; Get Title.
DO NP4^ORWU1(0)
+34 IF ORTTL=""
QUIT
+35 SET ORY(ORI)=ORY(ORI)_U_"- "_ORTTL
End DoDot:3
+36 ;
+37 ; Get data in case of dupes:
+38 IF ORDUP
Begin DoDot:3
+39 ; Prev IEN for NP2^ORWU1 call.
SET ORIEN2=ORLAST
+40 ;
+41 ; Reset, use previous array element, call for extended data:
+42 SET ORI=ORI-1
SET ORY(ORI)=$PIECE(ORY(ORI),U)_U_$PIECE(ORY(ORI),U,2)
DO NP2^ORWU1
+43 ;
+44 ; Then return to current user for second extended data call:
+45 SET ORIEN2=ORIEN1
SET ORI=ORI+1
DO NP2^ORWU1
End DoDot:3
+46 ; Reassign vars for next pass.
SET ORLAST=ORIEN1
SET ORPREV=ORFROM
End DoDot:2
End DoDot:1
+47 ;
+48 QUIT
+49 ;
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
