TIUPREF.m

TIUPREF ; SLC/JER - Enter/edit personal preferences ; 19-AUG-2002 13:10:05

 ;;1.0;TEXT INTEGRATION UTILITIES;**10,91,103,111,141**;Jun 20, 1997

 ;

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(^("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"

 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

TIUPREF   ; SLC/JER - Enter/edit personal preferences ; 19-AUG-2002 13:10:05

 +1       ;;1.0;TEXT INTEGRATION UTILITIES;**10,91,103,111,141**;Jun 20, 1997

 +2       ;

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(^("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"

 +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