Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORWTPN

ORWTPN.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1. GETSUB(VALUE,USER) ; from ORWTPP
  1.  ; get Ask for Subject on notes for user
  1.  N NODE
  1.  S NODE=+$O(^TIU(8926,"B",USER,0))
  1.  S VALUE=+$P($G(^TIU(8926,NODE,0)),U,8)
  1.  Q
  1.  ;
  1. SETSUB(OK,VALUE,USER) ; from ORWTPP
  1.  ; set Ask for Subject on note for user
  1.  N DA,DIE,DIK,DR,NODE,NUM
  1.  S OK=1
  1.  S VALUE=+$G(VALUE),VALUE=$S(VALUE=1:1,VALUE=0:0,1:"")
  1.  I VALUE="" S OK=0 Q
  1.  S NODE=+$O(^TIU(8926,"B",USER,0))
  1.  I 'NODE D  Q  ; make new entry if user does not have TIU preferences
  1.  .I 'VALUE Q  ; no need to set since default for no user preference is 0
  1.  .L +^TIU(8926,0):5 I '$T S OK=0 Q
  1.  .S NUM=1+$P(^TIU(8926,0),U,3)
  1.  .F  Q:'$D(^TIU(8926,NUM,0))  S NUM=NUM+1
  1.  .S $P(^(0),U,4)=1+$P(^TIU(8926,0),U,4),$P(^(0),U,3)=NUM
  1.  .S ^TIU(8926,NUM,0)=USER_"^^^^^^^1"
  1.  .L -^TIU(8926,0)
  1.  .S DA=NUM,DIK="^TIU(8926,"
  1.  .D IX1^DIK
  1.  I USER'=+$G(^TIU(8926,NODE,0)) Q
  1.  S DA=NODE,DIE="^TIU(8926,",DR=".08///"_VALUE
  1.  D ^DIE
  1.  Q
  1.  ;
  1. GETCOS(ORY,ORUSER,ORFROM,ORDIR,ORVIZ) ; Get cosigners for user (from ORWTPP).
  1.  ; (Keep this code matched with NP1^ORWU1 / NEWPERS^ORWU.)
  1.  ;
  1.  ; Params:
  1.  ;  .ORY=returned list, ORFROM=text to $O from, ORDIR=$O direction.
  1.  ;  ORDIR=Direction to move through x-ref.
  1.  ;  ORFROM=Starting value to use.
  1.  ;  ORUSER=User seeking a Cosigner.
  1.  ;  ORVIZ=If true, includes RDV users; otherwise not (optional).
  1.  ;
  1.  N OR1DIV,ORCNT,ORDATE,ORDD,ORDIV,ORDUP,ORGOOD,ORI,ORIEN1,ORIEN2,ORKEY,ORLAST,ORMAX,ORMRK,ORMULTI,ORNODE,ORPREV,ORSRV,ORTTL
  1.  ;
  1.  S ORI=0,ORMAX=44,(ORLAST,ORPREV)="",ORKEY=$G(ORKEY),ORDATE=$G(ORDATE)
  1.  S ORMULTI=$$ALL^VASITE ; Do once at beginning of call.
  1.  ;
  1.  ; NP3^ORWU1 tag includes visitors, uses full "B" x-ref.
  1.  I +$G(ORVIZ)=1 D NP3^ORWU1(1) Q  ; Use alt. version, skip rest.
  1.  ;
  1.  F  Q:ORI'<ORMAX  S ORFROM=$O(^VA(200,"AUSER",ORFROM),ORDIR) Q:ORFROM=""  D
  1.  .S ORIEN1=""
  1.  .F  S ORIEN1=$O(^VA(200,"AUSER",ORFROM,ORIEN1),ORDIR) Q:'ORIEN1  D
  1.  ..;
  1.  ..; Screen default cosigner selection:
  1.  ..I '$$SCRDFCS^TIULA3(ORUSER,ORIEN1) Q
  1.  ..S ORNODE=$P($G(^VA(200,ORIEN1,0)),U)
  1.  ..I '$L(ORNODE) Q
  1.  ..S ORI=ORI+1,ORY(ORI)=ORIEN1_"^"_$$NAMEFMT^XLFNAME(ORFROM,"F","DcMPC")
  1.  ..S ORDUP=0                            ; Init flag, check dupe.
  1.  ..I ($P(ORPREV_" "," ")=$P(ORFROM_" "," ")) S ORDUP=1
  1.  ..;
  1.  ..; Append Title if not duplicated:
  1.  ..I 'ORDUP D
  1.  ...S ORIEN2=ORIEN1
  1.  ...D NP4^ORWU1(0)                      ; Get Title.
  1.  ...I ORTTL="" Q
  1.  ...S ORY(ORI)=ORY(ORI)_U_"- "_ORTTL
  1.  ..;
  1.  ..; Get data in case of dupes:
  1.  ..I ORDUP D
  1.  ...S ORIEN2=ORLAST                     ; Prev IEN for NP2^ORWU1 call.
  1.  ...;
  1.  ...; Reset, use previous array element, call for extended data:
  1.  ...S ORI=ORI-1,ORY(ORI)=$P(ORY(ORI),U)_U_$P(ORY(ORI),U,2)  D NP2^ORWU1
  1.  ...;
  1.  ...; Then return to current user for second extended data call:
  1.  ...S ORIEN2=ORIEN1,ORI=ORI+1  D NP2^ORWU1
  1.  ..S ORLAST=ORIEN1,ORPREV=ORFROM        ; Reassign vars for next pass.
  1.  ;
  1.  Q
  1.  ;
  1. GETDCOS(VALUE,USER) ; from ORWTPP
  1.  ; get default cosigner for user
  1.  N IEN,NAME,NODE
  1.  S NODE=+$O(^TIU(8926,"B",USER,0))
  1.  S IEN=+$P($G(^TIU(8926,NODE,0)),U,9)
  1.  S NAME=$P($G(^VA(200,IEN,0)),U)
  1.  S VALUE=IEN_U_NAME
  1.  Q
  1.  ;
  1. SETDCOS(OK,VALUE,USER) ; from ORWTPP
  1.  ; set default cosigner for user
  1.  N DA,DIE,DIK,DR,NODE,NUM
  1.  S OK=1
  1.  S VALUE=+$G(VALUE)
  1.  I 'VALUE S VALUE="@"
  1.  S NODE=+$O(^TIU(8926,"B",USER,0))
  1.  I 'NODE D  Q  ; make new entry if user does not have TIU preferences
  1.  .I 'VALUE Q
  1.  .I '$$SCRDFCS^TIULA3(USER,VALUE) Q
  1.  .L +^TIU(8926,0):5 I '$T S OK=0 Q
  1.  .S NUM=1+$P(^TIU(8926,0),U,3)
  1.  .F  Q:'$D(^TIU(8926,NUM,0))  S NUM=NUM+1
  1.  .S $P(^(0),U,4)=1+$P(^TIU(8926,0),U,4),$P(^(0),U,3)=NUM
  1.  .S ^TIU(8926,NUM,0)=USER_"^^^^^^^^"_VALUE
  1.  .L -^TIU(8926,0)
  1.  .S DA=NUM,DIK="^TIU(8926,"
  1.  .D IX1^DIK
  1.  I USER'=+$G(^TIU(8926,NODE,0)) Q
  1.  S DA=NODE,DIE="^TIU(8926,",DR=".09///"_$S(VALUE:"`"_VALUE,1:"@")
  1.  D ^DIE
  1.  Q
  1.  ;
  1. GETCLASS(VALUES) ; RPC
  1.  ; get available document classes
  1.  N CNT,NODE,NUM K VALUES
  1.  S CNT=0
  1.  S NUM=0 F  S NUM=$O(^TIU(8925.1,"AT","CL",NUM)) Q:NUM<1  D
  1.  .I '$$CLASPICK^TIULA4(38,NUM,"CL") Q
  1.  .S NODE=$G(^TIU(8925.1,NUM,0))
  1.  .I '$L(NODE) Q
  1.  .S CNT=CNT+1
  1.  .S VALUES(CNT)=NUM_U_NODE
  1.  Q
  1.  ;
  1. GETTC(VALUES,CLASS,FROM,DIR) ; RPC
  1.  ; get titles for a class
  1.  N CNT,IEN,NODE,NUM K VALUES
  1.  S CNT=44,NUM=0
  1.  F  Q:NUM>CNT  S FROM=$O(^TIU(8925.1,"B",FROM),DIR) Q:FROM=""  D
  1.  .S IEN=0 F  S IEN=$O(^TIU(8925.1,"B",FROM,IEN)) Q:IEN<1  D
  1.  ..I '$D(^TIU(8925.1,"AT","DOC",IEN)) Q
  1.  ..I '$$ISA^TIULX(IEN,CLASS) Q
  1.  ..I '$$CANPICK^TIULP(IEN) Q
  1.  ..I '$$CANENTR^TIULP(IEN) Q
  1.  ..S NODE=$G(^TIU(8925.1,IEN,0))
  1.  ..I '$L(NODE) Q
  1.  ..S NUM=NUM+1
  1.  ..S VALUES(NUM)=IEN_U_NODE
  1.  Q
  1.  ;
  1. GETTU(VALUES,CLASS,USER) ; from ORWTPP
  1.  ; get titles for a user
  1.  N CNT,IEN,NUM,NUM1,NODE K VALUES
  1.  S CNT=0
  1.  S NUM=+$O(^TIU(8925.98,"AC",USER,CLASS,0))
  1.  I 'NUM Q
  1.  S NUM1=0 F  S NUM1=$O(^TIU(8925.98,NUM,10,NUM1)) Q:NUM1<1  D
  1.  .S IEN=+$G(^TIU(8925.98,NUM,10,NUM1,0))
  1.  .S NODE=$P($G(^TIU(8925.1,IEN,0)),U)
  1.  .I '$L(NODE) Q
  1.  .S CNT=CNT+1
  1.  .S VALUES(CNT)=IEN_U_NODE_U_(.0000001*$P(^TIU(8925.98,NUM,10,NUM1,0),U,2))_U_$P(^(0),U,3)
  1.  Q
  1.  ;
  1. GETTD(VALUE,CLASS,USER) ; from ORWTPP
  1.  ; get default title for user
  1.  N IEN,NUM,NODE
  1.  S VALUE=-1,USER=+$G(USER)
  1.  S NUM=+$O(^TIU(8925.98,"AC",USER,CLASS,0))
  1.  I 'NUM Q
  1.  S IEN=+$P($G(^TIU(8925.98,NUM,0)),U,3)
  1.  S NODE=$G(^TIU(8925.1,IEN,0))
  1.  I '$L(NODE) Q
  1.  S VALUE=IEN
  1.  Q
  1.  ;
  1. SAVET(OK,CLASS,DEFAULT,VALUES,USER) ; from ORWTPP
  1.  ; save titles for user
  1.  N CNT,DA,DIK,IEN,NUM,VALUE K DA
  1.  S CLASS=+$G(CLASS),DEFAULT=+$G(DEFAULT),OK=1
  1.  I DEFAULT'>0 S DEFAULT=""
  1.  S IEN=+$O(^TIU(8925.98,"AC",USER,CLASS,0))
  1.  I IEN D  Q
  1.  .S DA(1)=IEN
  1.  .S DIK="^TIU(8925.98,"_DA(1)_",10,"
  1.  .L +^TIU(8925.98,IEN):5 I '$T S OK=0 Q
  1.  .S DA=0 F  S DA=$O(^TIU(8925.98,IEN,10,DA)) Q:DA<1  D
  1.  ..D ^DIK
  1.  .S CNT=0
  1.  .S NUM=0 F  S NUM=$O(VALUES(NUM)) Q:NUM<1  D
  1.  ..S VALUE=+VALUES(NUM) I 'VALUE Q
  1.  ..S CNT=CNT+1
  1.  ..S ^TIU(8925.98,IEN,10,CNT,0)=VALUE_U_CNT_U_$P(VALUES(NUM),U,4)
  1.  .S ^TIU(8925.98,IEN,10,0)="^8925.9801IP^"_CNT_U_CNT
  1.  .S $P(^TIU(8925.98,IEN,0),U,3)=DEFAULT
  1.  .K DA S DA=IEN,DIK="^TIU(8925.98,"
  1.  .D IX1^DIK
  1.  .L -^TIU(8925.98,IEN)
  1.  S DA=1+$P(^TIU(8925.98,0),U,3)
  1.  L +^TIU(8925.98,0):5 I '$T S OK=0 Q
  1.  F  Q:'$D(^TIU(8925.98,DA))  S DA=DA+1
  1.  S ^TIU(8925.98,DA,0)=USER_U_CLASS_U_DEFAULT
  1.  S $P(^(0),U,4)=1+$P(^TIU(8925.98,0),U,4),$P(^(0),U,3)=DA
  1.  L -^TIU(8925.98,0)
  1.  S CNT=0
  1.  S NUM=0 F  S NUM=$O(VALUES(NUM)) Q:NUM<1  D
  1.  .S VALUE=+VALUES(NUM)
  1.  .I 'VALUE Q
  1.  .S CNT=CNT+1
  1.  .S ^TIU(8925.98,DA,10,CNT,0)=VALUE
  1.  S ^TIU(8925.98,DA,10,0)="^8925.9801IP^"_CNT_U_CNT
  1.  S DIK="^TIU(8925.98,"
  1.  D IX1^DIK
  1.  Q