TIUPREF ;SLC/JER - Enter/edit personal preferences ;Apr 06, 2021@09:31:02
;;1.0;TEXT INTEGRATION UTILITIES;**10,91,103,111,141,339**;Jun 20, 1997;Build 39
;
; $$ISA^USRLM DBIA #1544
;
GOODLOC(LOC) ; Returns 1 if ^SC hospital location IFN LOC is good, else 0
; Used in TIUVSIT, in DDs for LOCATION field of 8926
N GOODLOC,INACTIVE,OOS,CLINIC S (GOODLOC,INACTIVE)=0
I +$G(^SC(LOC,"I"))>0,(+$G(^("I"))'>DT) D
. S INACTIVE=1
. ; check if reactivated:
. I +$P($G(^SC(LOC,"I")),U,2)>0,$P($G(^("I")),U,2)'>DT S INACTIVE=0
S OOS=+$D(^SC(LOC,"OOS")) ; Occasion of service
S CLINIC=+($P(^SC(LOC,0),U,3)="C")
I 'INACTIVE,'OOS,CLINIC S GOODLOC=1
Q GOODLOC
;
MAIN ; Control branching
N DA
S DA=+$$GETREC
I +DA'>0 Q
D EDIT(DA)
Q
GETREC() ; Get record in picklist file
N DIC,DLAYGO,TIUNM,X,Y,ASKNEW
S (DIC,DLAYGO)=8926,DIC(0)="NXLZ"
S DIC("S")="I $P(^(0),U)=DUZ" ;TIU*1*91 If user already in file but has same name as another entry, select user
S X="`"_DUZ,TIUNM=$P(^VA(200,+$G(DUZ),0),U)
W !," Enter/edit Personal Preferences"
W !!?5,TIUNM
D ^DIC
;TIU*1*91 If DIC adds new entry, can get anyone w/ same name:
I Y>0,+Y(0)'=DUZ N DA,DIK D
. W !!," Sorry, you can edit preferences for YOURSELF only. Please try again."
. I $P(Y,U,3)=1 S DA=+Y,DIK="^TIU(8926," D ^DIK S Y=-1
Q +$G(Y)
EDIT(DA) ; Call ^DIE to edit the record
N DIE,DR,TIUCLASS,TIUREQCS,LOC
S DIE=8926,TIUREQCS=+$$REQCOS(DUZ)
S LOC=+$P(^TIU(8926,DA,0),U,2)
I LOC>0,'$$GOODLOC(LOC) W !," Your default location is no longer valid and has been deleted.",!," Please choose a new one." S DR=".02///@" D ^DIE
S DR=".02:.08;.1;.11;I +TIUREQCS'>0 S Y=""@1"";.09;@1;1;.21;I +X=0 S Y=""@2"";.22;@2;.23"
S DR(2,8926.01)=".01;.02;.03" D ^DIE
Q
REQCOS(DUZ) ; Does user require cosignature for any documents
N TIUI,TIUJ,TIUC,TIUY S (TIUI,TIUY)=0
; Is the user required to have a cosignature on any document?
F S TIUI=$O(^TIU(8925.95,TIUI)) Q:+TIUI'>0!+TIUY D
. S TIUJ=0
. F S TIUJ=$O(^TIU(8925.95,TIUI,5,TIUJ)) Q:+TIUJ'>0!+TIUY D
. . S TIUC=+$G(^TIU(8925.95,TIUI,5,TIUJ,0)) Q:+TIUC'>0
. . S TIUY=+$$ISA^USRLM(DUZ,TIUC)
Q TIUY
REQDFLD(VAL,ACTION,INPUT) ;Load or Save Template Required Fields Preferences
N COLOR,DA,HILITEON,NAVLOC
S VAL=0
I DUZ'>0 S VAL="-1^Invalid user" Q
I ACTION="SVPREF" D Q
. N HILITEON,COLOR,NAVLOC
. I INPUT="" S VAL="-1^Save data not received" Q
. S HILITEON=$P(INPUT,U,1)
. I HILITEON'=0,HILITEON'=1 S HILITEON=0 ;Default to Highligh Off if bad data received
. S COLOR=$P(INPUT,U,2)
. S NAVLOC=$P(INPUT,U,3)
. I ((+NAVLOC<0)!(+NAVLOC>3)) S NAVLOC=0 ;Default to Navigation bar at top if bad data received
. S DA=+$O(^TIU(8926,"B",DUZ,""))
. I DA>0,$D(^TIU(8926,DA)) D Q
.. N DIE,DR
.. I COLOR="" S COLOR="@"
.. S DIE="^TIU(8926,"
.. S DR=".21////^S X=HILITEON;.22////^S X=COLOR;.23////^S X=NAVLOC"
.. D ^DIE
.. S VAL=1
. I ((DA=0)!('$D(^TIU(8926,DA)))) D Q
.. N D0,DIC,X,Y
.. S DIC="^TIU(8926,"
.. S DIC(0)=""
.. S DIC("DR")=".21////^S X=HILITEON;.22////^S X=COLOR;.23////^S X=NAVLOC"
.. S X=DUZ
.. D FILE^DICN
.. I +Y>0 S VAL=1 Q
.. S VAL="-1^Save Failed"
. S VAL="-1^Save Failed"
I ACTION="LDPREF" D Q
. N DATA,IEN
. S IEN=+$O(^TIU(8926,"B",DUZ,""))
. I IEN>0 D
.. S DATA=$G(^TIU(8926,IEN,2))
.. S HILITEON=$P(DATA,U,1)
.. S COLOR=$P(DATA,U,2)
.. S NAVLOC=$P(DATA,U,3)
. S VAL=$S($G(HILITEON)="":1,1:HILITEON)_U_$G(COLOR)_U_$S($G(NAVLOC)="":0,1:NAVLOC)
S VAL="-1^Invalid Action parameter"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUPREF 3554 printed Oct 16, 2024@18:44:13 Page 2
TIUPREF ;SLC/JER - Enter/edit personal preferences ;Apr 06, 2021@09:31:02
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**10,91,103,111,141,339**;Jun 20, 1997;Build 39
+2 ;
+3 ; $$ISA^USRLM DBIA #1544
+4 ;
GOODLOC(LOC) ; Returns 1 if ^SC hospital location IFN LOC is good, else 0
+1 ; Used in TIUVSIT, in DDs for LOCATION field of 8926
+2 NEW GOODLOC,INACTIVE,OOS,CLINIC
SET (GOODLOC,INACTIVE)=0
+3 IF +$GET(^SC(LOC,"I"))>0
IF (+$GET(^("I"))'>DT)
Begin DoDot:1
+4 SET INACTIVE=1
+5 ; check if reactivated:
+6 IF +$PIECE($GET(^SC(LOC,"I")),U,2)>0
IF $PIECE($GET(^("I")),U,2)'>DT
SET INACTIVE=0
End DoDot:1
+7 ; Occasion of service
SET OOS=+$DATA(^SC(LOC,"OOS"))
+8 SET CLINIC=+($PIECE(^SC(LOC,0),U,3)="C")
+9 IF 'INACTIVE
IF 'OOS
IF CLINIC
SET GOODLOC=1
+10 QUIT GOODLOC
+11 ;
MAIN ; Control branching
+1 NEW DA
+2 SET DA=+$$GETREC
+3 IF +DA'>0
QUIT
+4 DO EDIT(DA)
+5 QUIT
GETREC() ; Get record in picklist file
+1 NEW DIC,DLAYGO,TIUNM,X,Y,ASKNEW
+2 SET (DIC,DLAYGO)=8926
SET DIC(0)="NXLZ"
+3 ;TIU*1*91 If user already in file but has same name as another entry, select user
SET DIC("S")="I $P(^(0),U)=DUZ"
+4 SET X="`"_DUZ
SET TIUNM=$PIECE(^VA(200,+$GET(DUZ),0),U)
+5 WRITE !," Enter/edit Personal Preferences"
+6 WRITE !!?5,TIUNM
+7 DO ^DIC
+8 ;TIU*1*91 If DIC adds new entry, can get anyone w/ same name:
+9 IF Y>0
IF +Y(0)'=DUZ
NEW DA,DIK
Begin DoDot:1
+10 WRITE !!," Sorry, you can edit preferences for YOURSELF only. Please try again."
+11 IF $PIECE(Y,U,3)=1
SET DA=+Y
SET DIK="^TIU(8926,"
DO ^DIK
SET Y=-1
End DoDot:1
+12 QUIT +$GET(Y)
EDIT(DA) ; Call ^DIE to edit the record
+1 NEW DIE,DR,TIUCLASS,TIUREQCS,LOC
+2 SET DIE=8926
SET TIUREQCS=+$$REQCOS(DUZ)
+3 SET LOC=+$PIECE(^TIU(8926,DA,0),U,2)
+4 IF LOC>0
IF '$$GOODLOC(LOC)
WRITE !," Your default location is no longer valid and has been deleted.",!," Please choose a new one."
SET DR=".02///@"
DO ^DIE
+5 SET DR=".02:.08;.1;.11;I +TIUREQCS'>0 S Y=""@1"";.09;@1;1;.21;I +X=0 S Y=""@2"";.22;@2;.23"
+6 SET DR(2,8926.01)=".01;.02;.03"
DO ^DIE
+7 QUIT
REQCOS(DUZ) ; Does user require cosignature for any documents
+1 NEW TIUI,TIUJ,TIUC,TIUY
SET (TIUI,TIUY)=0
+2 ; Is the user required to have a cosignature on any document?
+3 FOR
SET TIUI=$ORDER(^TIU(8925.95,TIUI))
if +TIUI'>0!+TIUY
QUIT
Begin DoDot:1
+4 SET TIUJ=0
+5 FOR
SET TIUJ=$ORDER(^TIU(8925.95,TIUI,5,TIUJ))
if +TIUJ'>0!+TIUY
QUIT
Begin DoDot:2
+6 SET TIUC=+$GET(^TIU(8925.95,TIUI,5,TIUJ,0))
if +TIUC'>0
QUIT
+7 SET TIUY=+$$ISA^USRLM(DUZ,TIUC)
End DoDot:2
End DoDot:1
+8 QUIT TIUY
REQDFLD(VAL,ACTION,INPUT) ;Load or Save Template Required Fields Preferences
+1 NEW COLOR,DA,HILITEON,NAVLOC
+2 SET VAL=0
+3 IF DUZ'>0
SET VAL="-1^Invalid user"
QUIT
+4 IF ACTION="SVPREF"
Begin DoDot:1
+5 NEW HILITEON,COLOR,NAVLOC
+6 IF INPUT=""
SET VAL="-1^Save data not received"
QUIT
+7 SET HILITEON=$PIECE(INPUT,U,1)
+8 ;Default to Highligh Off if bad data received
IF HILITEON'=0
IF HILITEON'=1
SET HILITEON=0
+9 SET COLOR=$PIECE(INPUT,U,2)
+10 SET NAVLOC=$PIECE(INPUT,U,3)
+11 ;Default to Navigation bar at top if bad data received
IF ((+NAVLOC<0)!(+NAVLOC>3))
SET NAVLOC=0
+12 SET DA=+$ORDER(^TIU(8926,"B",DUZ,""))
+13 IF DA>0
IF $DATA(^TIU(8926,DA))
Begin DoDot:2
+14 NEW DIE,DR
+15 IF COLOR=""
SET COLOR="@"
+16 SET DIE="^TIU(8926,"
+17 SET DR=".21////^S X=HILITEON;.22////^S X=COLOR;.23////^S X=NAVLOC"
+18 DO ^DIE
+19 SET VAL=1
End DoDot:2
QUIT
+20 IF ((DA=0)!('$DATA(^TIU(8926,DA))))
Begin DoDot:2
+21 NEW D0,DIC,X,Y
+22 SET DIC="^TIU(8926,"
+23 SET DIC(0)=""
+24 SET DIC("DR")=".21////^S X=HILITEON;.22////^S X=COLOR;.23////^S X=NAVLOC"
+25 SET X=DUZ
+26 DO FILE^DICN
+27 IF +Y>0
SET VAL=1
QUIT
+28 SET VAL="-1^Save Failed"
End DoDot:2
QUIT
+29 SET VAL="-1^Save Failed"
End DoDot:1
QUIT
+30 IF ACTION="LDPREF"
Begin DoDot:1
+31 NEW DATA,IEN
+32 SET IEN=+$ORDER(^TIU(8926,"B",DUZ,""))
+33 IF IEN>0
Begin DoDot:2
+34 SET DATA=$GET(^TIU(8926,IEN,2))
+35 SET HILITEON=$PIECE(DATA,U,1)
+36 SET COLOR=$PIECE(DATA,U,2)
+37 SET NAVLOC=$PIECE(DATA,U,3)
End DoDot:2
+38 SET VAL=$SELECT($GET(HILITEON)="":1,1:HILITEON)_U_$GET(COLOR)_U_$SELECT($GET(NAVLOC)="":0,1:NAVLOC)
End DoDot:1
QUIT
+39 SET VAL="-1^Invalid Action parameter"
+40 QUIT
