ORWTPL ; SLC/STAFF - Personal Preference Lists ;Oct 19, 2018@10:16
;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,109,173,243,273,377**;Oct 24, 2000;Build 582
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;DBIA reference section
;4329 - ^VA(200
;10013 - DIK
;2263 - XPAR
;
NEWLIST(VAL,LISTNAME,USER,ORVIZ) ; from ORWTPP
; set user's new personal list
N CAPNAME
S LISTNAME=$G(LISTNAME)
I '$L(LISTNAME) S VAL="^invalid list name" Q
S CAPNAME=$$UPPER^ORU(LISTNAME)
I $D(^OR(100.21,"D",CAPNAME)) S VAL="^invalid list name - duplicate of another name" Q
I $O(^OR(100.21,"B",LISTNAME,0)) S VAL="^invalid list name - duplicate of another name" Q
;*** check input transform, duplicate name for same user
N DA,DIK,NUM
L +^OR(100.21,0):20 I '$T S VAL="^unable to set up" Q
S NUM=1+$P(^OR(100.21,0),U,3)
F Q:'$D(^OR(100.21,NUM,0)) S NUM=NUM+1
S $P(^OR(100.21,0),U,3)=NUM,$P(^(0),U,4)=$P(^(0),U,4)+1
S ^OR(100.21,NUM,0)=LISTNAME_"^P"
L -^OR(100.21,0)
K ^OR(100.21,NUM,1),^(2),^(10)
S ^OR(100.21,NUM,1,0)="^100.212PA^"_USER_"^1"
S ^OR(100.21,NUM,1,USER,0)=USER
S ^OR(100.21,NUM,11)=$G(ORVIZ)_U
S DIK="^OR(100.21,",DA=NUM
D IX1^DIK
S VAL=NUM_U_LISTNAME_"^^^^^^^"_$G(ORVIZ)
Q
;
DELLIST(OK,LISTNUM,USER) ; from ORWTPP
; delete user's personal list
N DA,DIK
S LISTNUM=+$G(LISTNUM),OK=1
I '$O(^OR(100.21,"C",USER,LISTNUM,0)) S OK=0 Q
I $P($G(^OR(100.21,LISTNUM,0)),U,2)'="P" S OK=0 Q
S DA=LISTNUM,DIK="^OR(100.21,"
D ^DIK
Q
;
SAVELIST(OK,PLIST,LISTNUM,USER,ORVIZ) ; from ORWTPP
; save user's personal list changes
N CNT,DA,DFN,DIK,NUM K DA
S LISTNUM=+$G(LISTNUM),OK=1
I $P($G(^OR(100.21,LISTNUM,0)),U,2)'="P" S OK=0 Q
I '$D(^OR(100.21,"C",USER,LISTNUM)) S OK=0 Q
I '$D(^OR(100.21,LISTNUM,10,0))#2 S ^(0)="^100.2101AV^"
S DA(1)=LISTNUM,DIK="^OR(100.21,"_LISTNUM_",10,"
S DA=0 F S DA=$O(^OR(100.21,LISTNUM,10,DA)) Q:DA<1 D ^DIK
K DA
S CNT=0
S NUM=0 F S NUM=$O(PLIST(NUM)) Q:NUM<1 D
.S DFN=+PLIST(NUM) I 'DFN Q
.S CNT=CNT+1
.S ^OR(100.21,LISTNUM,10,CNT,0)=DFN_";DPT("
S ^OR(100.21,LISTNUM,10,0)="^100.2101AV^"_CNT_U_CNT
S ^OR(100.21,LISTNUM,11)=$G(ORVIZ)_U
S DA=LISTNUM,DIK="^OR(100.21,"
D IX1^DIK
Q
;
LSDEF(INFO,USER) ; from ORWTPP
; get user's list sources
N TYPE
S INFO=""
F TYPE="P","S","T","W","C" D
.S INFO=INFO_$P($$LISTSRC^ORQPTQ11(USER,TYPE),U)_U
Q
;
SORTDEF(SORT,USER) ; from ORWTPP
; get user's sort order - Modified by PKS - 8/30/2001
N ORSECT
S ORSECT=$G(^VA(200,USER,5))
I +ORSECT>0 S ORSECT=$P(ORSECT,U)
S SORT=$$GET^XPAR("USR.`"_USER_"^SRV.`"_$G(ORSECT)_"^DIV^SYS^PKG","ORLP DEFAULT LIST ORDER",1,"I") I SORT']"" S SORT="A"
Q
;
CLDAYS(DAYS,USER) ; from ORWTPP
; get user's clinic defaults
N DAY
S DAYS=""
F DAY="MONDAY","TUESDAY","WEDNESDAY","THURSDAY","FRIDAY","SATURDAY","SUNDAY" D
.S DAYS=DAYS_$$GET^XPAR("USR.`"_USER,"ORLP DEFAULT CLINIC "_DAY,1,"I")_U
Q
;
CLRANGE(RANGE,USER) ; from ORWTPP
; get user's default clinic start, stop dates
N RNG
S RANGE=""
F RNG="START","STOP" D
.S RANGE=RANGE_$$GET^XPAR("USR.`"_USER,"ORLP DEFAULT CLINIC "_RNG_" DATE",1,"I")_U
Q
;
SAVECD(OK,INFO,USER) ; from ORWTPP
; save user's clinic defaults
N FRI,MON,SAT,START,STOP,SUN,THURS,TUES,WED
S OK=1
S START=+$P(INFO,U,1) S START=$S(START=0:"T",START<0:"T"_START,1:"T+"_START)
S STOP=+$P(INFO,U,2) S STOP=$S(STOP=0:"T",STOP<0:"T"_STOP,1:"T+"_STOP)
S MON=+$P(INFO,U,3),MON=$S('MON:"@",1:"`"_MON)
S TUES=+$P(INFO,U,4),TUES=$S('TUES:"@",1:"`"_TUES)
S WED=+$P(INFO,U,5),WED=$S('WED:"@",1:"`"_WED)
S THURS=+$P(INFO,U,6),THURS=$S('THURS:"@",1:"`"_THURS)
S FRI=+$P(INFO,U,7),FRI=$S('FRI:"@",1:"`"_FRI)
S SAT=+$P(INFO,U,8),SAT=$S('SAT:"@",1:"`"_SAT)
S SUN=+$P(INFO,U,9),SUN=$S('SUN:"@",1:"`"_SUN)
D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC START DATE",1,START)
D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC STOP DATE",1,STOP)
D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC MONDAY",1,MON)
D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC TUESDAY",1,TUES)
D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC WEDNESDAY",1,WED)
D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC THURSDAY",1,THURS)
D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC FRIDAY",1,FRI)
D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC SATURDAY",1,SAT)
D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC SUNDAY",1,SUN)
Q
;
SAVEPLD(OK,INFO,USER) ; from ORWTPP
; save user's clinic defaults
N PCMM,PROV,SORT,SOURCE,SPEC,TEAM,WARD
S OK=1
S SOURCE=$P(INFO,U,1)
S SORT=$P(INFO,U,2)
S PROV=+$P(INFO,U,3),PROV=$S('PROV:"@",1:"`"_PROV)
S SPEC=+$P(INFO,U,4),SPEC=$S('SPEC:"@",1:"`"_SPEC)
S TEAM=+$P(INFO,U,5),TEAM=$S('TEAM:"@",1:"`"_TEAM)
S WARD=+$P(INFO,U,6),WARD=$S('WARD:"@",1:"`"_WARD)
S PCMM=+$P(INFO,U,7),PCMM=$S('PCMM:"@",1:"`"_PCMM) ; ajb 377
D EN^XPAR(USER_";VA(200,","ORLP DEFAULT LIST SOURCE",1,SOURCE)
D EN^XPAR(USER_";VA(200,","ORLP DEFAULT LIST ORDER",1,SORT)
D EN^XPAR(USER_";VA(200,","ORLP DEFAULT PROVIDER",1,PROV)
D EN^XPAR(USER_";VA(200,","ORLP DEFAULT SPECIALTY",1,SPEC)
D EN^XPAR(USER_";VA(200,","ORLP DEFAULT TEAM",1,TEAM)
D EN^XPAR(USER_";VA(200,","ORLP DEFAULT WARD",1,WARD)
D EN^XPAR(USER_";VA(200,","ORLP DEFAULT PCMM TEAM",1,PCMM) ; ajb 377
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWTPL 5284 printed Sep 23, 2025@20:13:52 Page 2
ORWTPL ; SLC/STAFF - Personal Preference Lists ;Oct 19, 2018@10:16
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,109,173,243,273,377**;Oct 24, 2000;Build 582
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;DBIA reference section
+5 ;4329 - ^VA(200
+6 ;10013 - DIK
+7 ;2263 - XPAR
+8 ;
NEWLIST(VAL,LISTNAME,USER,ORVIZ) ; from ORWTPP
+1 ; set user's new personal list
+2 NEW CAPNAME
+3 SET LISTNAME=$GET(LISTNAME)
+4 IF '$LENGTH(LISTNAME)
SET VAL="^invalid list name"
QUIT
+5 SET CAPNAME=$$UPPER^ORU(LISTNAME)
+6 IF $DATA(^OR(100.21,"D",CAPNAME))
SET VAL="^invalid list name - duplicate of another name"
QUIT
+7 IF $ORDER(^OR(100.21,"B",LISTNAME,0))
SET VAL="^invalid list name - duplicate of another name"
QUIT
+8 ;*** check input transform, duplicate name for same user
+9 NEW DA,DIK,NUM
+10 LOCK +^OR(100.21,0):20
IF '$TEST
SET VAL="^unable to set up"
QUIT
+11 SET NUM=1+$PIECE(^OR(100.21,0),U,3)
+12 FOR
if '$DATA(^OR(100.21,NUM,0))
QUIT
SET NUM=NUM+1
+13 SET $PIECE(^OR(100.21,0),U,3)=NUM
SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)+1
+14 SET ^OR(100.21,NUM,0)=LISTNAME_"^P"
+15 LOCK -^OR(100.21,0)
+16 KILL ^OR(100.21,NUM,1),^(2),^(10)
+17 SET ^OR(100.21,NUM,1,0)="^100.212PA^"_USER_"^1"
+18 SET ^OR(100.21,NUM,1,USER,0)=USER
+19 SET ^OR(100.21,NUM,11)=$GET(ORVIZ)_U
+20 SET DIK="^OR(100.21,"
SET DA=NUM
+21 DO IX1^DIK
+22 SET VAL=NUM_U_LISTNAME_"^^^^^^^"_$GET(ORVIZ)
+23 QUIT
+24 ;
DELLIST(OK,LISTNUM,USER) ; from ORWTPP
+1 ; delete user's personal list
+2 NEW DA,DIK
+3 SET LISTNUM=+$GET(LISTNUM)
SET OK=1
+4 IF '$ORDER(^OR(100.21,"C",USER,LISTNUM,0))
SET OK=0
QUIT
+5 IF $PIECE($GET(^OR(100.21,LISTNUM,0)),U,2)'="P"
SET OK=0
QUIT
+6 SET DA=LISTNUM
SET DIK="^OR(100.21,"
+7 DO ^DIK
+8 QUIT
+9 ;
SAVELIST(OK,PLIST,LISTNUM,USER,ORVIZ) ; from ORWTPP
+1 ; save user's personal list changes
+2 NEW CNT,DA,DFN,DIK,NUM
KILL DA
+3 SET LISTNUM=+$GET(LISTNUM)
SET OK=1
+4 IF $PIECE($GET(^OR(100.21,LISTNUM,0)),U,2)'="P"
SET OK=0
QUIT
+5 IF '$DATA(^OR(100.21,"C",USER,LISTNUM))
SET OK=0
QUIT
+6 IF '$DATA(^OR(100.21,LISTNUM,10,0))#2
SET ^(0)="^100.2101AV^"
+7 SET DA(1)=LISTNUM
SET DIK="^OR(100.21,"_LISTNUM_",10,"
+8 SET DA=0
FOR
SET DA=$ORDER(^OR(100.21,LISTNUM,10,DA))
if DA<1
QUIT
DO ^DIK
+9 KILL DA
+10 SET CNT=0
+11 SET NUM=0
FOR
SET NUM=$ORDER(PLIST(NUM))
if NUM<1
QUIT
Begin DoDot:1
+12 SET DFN=+PLIST(NUM)
IF 'DFN
QUIT
+13 SET CNT=CNT+1
+14 SET ^OR(100.21,LISTNUM,10,CNT,0)=DFN_";DPT("
End DoDot:1
+15 SET ^OR(100.21,LISTNUM,10,0)="^100.2101AV^"_CNT_U_CNT
+16 SET ^OR(100.21,LISTNUM,11)=$GET(ORVIZ)_U
+17 SET DA=LISTNUM
SET DIK="^OR(100.21,"
+18 DO IX1^DIK
+19 QUIT
+20 ;
LSDEF(INFO,USER) ; from ORWTPP
+1 ; get user's list sources
+2 NEW TYPE
+3 SET INFO=""
+4 FOR TYPE="P","S","T","W","C"
Begin DoDot:1
+5 SET INFO=INFO_$PIECE($$LISTSRC^ORQPTQ11(USER,TYPE),U)_U
End DoDot:1
+6 QUIT
+7 ;
SORTDEF(SORT,USER) ; from ORWTPP
+1 ; get user's sort order - Modified by PKS - 8/30/2001
+2 NEW ORSECT
+3 SET ORSECT=$GET(^VA(200,USER,5))
+4 IF +ORSECT>0
SET ORSECT=$PIECE(ORSECT,U)
+5 SET SORT=$$GET^XPAR("USR.`"_USER_"^SRV.`"_$GET(ORSECT)_"^DIV^SYS^PKG","ORLP DEFAULT LIST ORDER",1,"I")
IF SORT']""
SET SORT="A"
+6 QUIT
+7 ;
CLDAYS(DAYS,USER) ; from ORWTPP
+1 ; get user's clinic defaults
+2 NEW DAY
+3 SET DAYS=""
+4 FOR DAY="MONDAY","TUESDAY","WEDNESDAY","THURSDAY","FRIDAY","SATURDAY","SUNDAY"
Begin DoDot:1
+5 SET DAYS=DAYS_$$GET^XPAR("USR.`"_USER,"ORLP DEFAULT CLINIC "_DAY,1,"I")_U
End DoDot:1
+6 QUIT
+7 ;
CLRANGE(RANGE,USER) ; from ORWTPP
+1 ; get user's default clinic start, stop dates
+2 NEW RNG
+3 SET RANGE=""
+4 FOR RNG="START","STOP"
Begin DoDot:1
+5 SET RANGE=RANGE_$$GET^XPAR("USR.`"_USER,"ORLP DEFAULT CLINIC "_RNG_" DATE",1,"I")_U
End DoDot:1
+6 QUIT
+7 ;
SAVECD(OK,INFO,USER) ; from ORWTPP
+1 ; save user's clinic defaults
+2 NEW FRI,MON,SAT,START,STOP,SUN,THURS,TUES,WED
+3 SET OK=1
+4 SET START=+$PIECE(INFO,U,1)
SET START=$SELECT(START=0:"T",START<0:"T"_START,1:"T+"_START)
+5 SET STOP=+$PIECE(INFO,U,2)
SET STOP=$SELECT(STOP=0:"T",STOP<0:"T"_STOP,1:"T+"_STOP)
+6 SET MON=+$PIECE(INFO,U,3)
SET MON=$SELECT('MON:"@",1:"`"_MON)
+7 SET TUES=+$PIECE(INFO,U,4)
SET TUES=$SELECT('TUES:"@",1:"`"_TUES)
+8 SET WED=+$PIECE(INFO,U,5)
SET WED=$SELECT('WED:"@",1:"`"_WED)
+9 SET THURS=+$PIECE(INFO,U,6)
SET THURS=$SELECT('THURS:"@",1:"`"_THURS)
+10 SET FRI=+$PIECE(INFO,U,7)
SET FRI=$SELECT('FRI:"@",1:"`"_FRI)
+11 SET SAT=+$PIECE(INFO,U,8)
SET SAT=$SELECT('SAT:"@",1:"`"_SAT)
+12 SET SUN=+$PIECE(INFO,U,9)
SET SUN=$SELECT('SUN:"@",1:"`"_SUN)
+13 DO EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC START DATE",1,START)
+14 DO EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC STOP DATE",1,STOP)
+15 DO EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC MONDAY",1,MON)
+16 DO EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC TUESDAY",1,TUES)
+17 DO EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC WEDNESDAY",1,WED)
+18 DO EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC THURSDAY",1,THURS)
+19 DO EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC FRIDAY",1,FRI)
+20 DO EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC SATURDAY",1,SAT)
+21 DO EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC SUNDAY",1,SUN)
+22 QUIT
+23 ;
SAVEPLD(OK,INFO,USER) ; from ORWTPP
+1 ; save user's clinic defaults
+2 NEW PCMM,PROV,SORT,SOURCE,SPEC,TEAM,WARD
+3 SET OK=1
+4 SET SOURCE=$PIECE(INFO,U,1)
+5 SET SORT=$PIECE(INFO,U,2)
+6 SET PROV=+$PIECE(INFO,U,3)
SET PROV=$SELECT('PROV:"@",1:"`"_PROV)
+7 SET SPEC=+$PIECE(INFO,U,4)
SET SPEC=$SELECT('SPEC:"@",1:"`"_SPEC)
+8 SET TEAM=+$PIECE(INFO,U,5)
SET TEAM=$SELECT('TEAM:"@",1:"`"_TEAM)
+9 SET WARD=+$PIECE(INFO,U,6)
SET WARD=$SELECT('WARD:"@",1:"`"_WARD)
+10 ; ajb 377
SET PCMM=+$PIECE(INFO,U,7)
SET PCMM=$SELECT('PCMM:"@",1:"`"_PCMM)
+11 DO EN^XPAR(USER_";VA(200,","ORLP DEFAULT LIST SOURCE",1,SOURCE)
+12 DO EN^XPAR(USER_";VA(200,","ORLP DEFAULT LIST ORDER",1,SORT)
+13 DO EN^XPAR(USER_";VA(200,","ORLP DEFAULT PROVIDER",1,PROV)
+14 DO EN^XPAR(USER_";VA(200,","ORLP DEFAULT SPECIALTY",1,SPEC)
+15 DO EN^XPAR(USER_";VA(200,","ORLP DEFAULT TEAM",1,TEAM)
+16 DO EN^XPAR(USER_";VA(200,","ORLP DEFAULT WARD",1,WARD)
+17 ; ajb 377
DO EN^XPAR(USER_";VA(200,","ORLP DEFAULT PCMM TEAM",1,PCMM)
+18 QUIT
