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 ;Mar 15, 2022@10:43:05
  1. ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,149,187,195,405**;Dec 17, 1997;Build 211
  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,ORSIM) ; 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. ; ORSIM=If true, this indicates that this is a Similar Provider RPC call NSR#20110606/539
  1. ;
  1. N OR1DIV,ORCNT,ORDATE,ORDD,ORDIV,ORDUP,ORGOOD,ORI,ORIEN1,ORIEN2,ORKEY,ORLAST,ORMAX,ORMRK,ORMULTI,ORNODE,ORPREV,ORSRV,ORTTL
  1. 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
  1. N A,ORTAB,S1
  1. ;
  1. 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
  1. S ORI=0,ORMAX=44,(ORLAST,ORPREV,ORDUPNM)="",ORKEY=$G(ORKEY),ORDATE=$G(ORDATE),ORSIM=$G(ORSIM) ; NSR 20110606/539 added ORSIM
  1. S OPTIEN=$$LKOPT^XPDMENU("OR CPRS GUI CHART") ;Set IEN to option file - NSR 20110606/539
  1. S ORMULTI=$$ALL^VASITE ; IA# 10112. Do once at beginning of call.
  1. 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 **
  1. .N LASTCHAR,ORFIEN,ORFROM1,XFNM,XFNMLEN
  1. .S ORFIEN=ORFROM
  1. .S (ORFROM,ORFROM1)=$P(^VA(200,ORFROM,0),U),$P(ORFROM,",",2)=$E($P(ORFROM,",",2),1,2)
  1. .S ORFNM=$P(ORFROM,",",2),ORFNMLEN=$L(ORFNM),ORLNM=$P(ORFROM,",") ; ** NSR 20110606/539 - Add ORFNM, ORFNMLEN and ORLNM **
  1. .I ORFNM]"" D
  1. ..S XFNM=$P(ORFROM,",",2),XFNMLEN=$L(XFNM),LASTCHAR=$C($A(XFNM,XFNMLEN)-1),XFNM=$E(XFNM,1,XFNMLEN-1)_LASTCHAR_$C(126)
  1. ..S $P(ORFROM,",",2)=XFNM
  1. .S ORI=ORI+1,ORY(ORI)=ORFIEN_"^"_$$NAMEFMT^XLFNAME(ORFROM1,"F","DcMPC")
  1. .S ORDUPNM(ORFIEN)=""
  1. .S ORIEN2=ORFIEN
  1. .;Using NP2 instead of NP4(0) in case duplicate (same but different) entry found later
  1. .D NP2^ORWU1
  1. E D
  1. .S (ORFNM,ORFNMLEN,ORLNM)=""
  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=""!'$$CHKORSIM^ORWU1(ORSIM,ORFNM,ORFNMLEN,ORFROM,ORLNM) D ; NSR 20110606/539 - Check for quitting with ORSIM and names comparison
  1. .S ORIEN1=""
  1. .F S ORIEN1=$O(^VA(200,"AUSER",ORFROM,ORIEN1),ORDIR) Q:'ORIEN1 D
  1. ..I $D(ORDUPNM(ORIEN1)) Q
  1. ..; NSR 20120101 Limit Signers by Tabs & Excluded User Class
  1. ..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
  1. ..I '+$$ACCESS^XQCHK(ORIEN1,OPTIEN) Q ;NSR 20110606/539
  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. ..I +ORI,+ORY(ORI)=ORIEN1 Q ; if the current IEN is already in list, quit
  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