- 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 Jan 18, 2025@03:38:42 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