TIUFLF1 ; SLC/MAM - Library; File 8925.1 Related: HASITEMS(FILEDA), ASKFLDS(FILEDA,FIELDS,PFILEDA,NEWSFLG,XFLG), BADNAP(NAP,FILEDA,OBJFLG) ; 03/16/2007
;;1.0;TEXT INTEGRATION UTILITIES;**2,12,17,64,211,225**;Jun 20, 1997;Build 13
;
;
;*** INCLUDES JOEL'S MODS FOR VUID PATCH ***
;
BADNAP(NAP,FILEDA,OBJFLG) ; Function returns 1 if NAP is ambiguous as a
;name, abbrev or print name for FILEDA AND such ambiguity is a problem.
;Else 0. Used when editing entries, or when finding permitted types.
; Ambiguity is a problem if OBJFLG=1. OBJFLG=1 if FILEDA is an object,
;or FILEDA WILL BE an object since we're in Create Objects, or we are
;deciding whether to include type O as a permitted type
;in TYPELIST^TIUFLF7.
; TYPELIST, NAME of object in ASKFLDS must SEND OBJFLG=1. Others are SET here.
N NAPANS,XREF,OFILEDA
S NAPANS=0 I NAP="" G BADNX
I $D(^TIU(8925.1,"AT","O",FILEDA)) S OBJFLG=1
I $G(TIUFTMPL)="J" S OBJFLG=1
I $G(TIUFXNOD)["Copy",$P($G(NODE0),U,4)="O" S OBJFLG=1
S OBJFLG=+$G(OBJFLG)
I 'OBJFLG G BADNX
F XREF="B","C","D" D Q:NAPANS
. S OFILEDA=0 F S OFILEDA=$O(^TIU(8925.1,XREF,NAP,OFILEDA)) Q:'OFILEDA D Q:NAPANS
. . I OFILEDA'=FILEDA,$D(^TIU(8925.1,"AT","O",OFILEDA)) S NAPANS=1
BADNX Q NAPANS
;
HASITEMS(FILEDA) ; Function returns 0 if FILEDA has no items, else returns 1.
Q $O(^TIU(8925.1,+FILEDA,10,0))
;
ASKFLDS(FILEDA,FIELDS,PFILEDA,NEWSFLG,XFLG) ; Ask FIELDS (String subset of: ;.01;.02;.03;.04;.05;.06;.07;.1;.13;3.03) w ;'s on ends as well as between numbers for file entry FILEDA.
; Requires FILEDA, FIELDS.
; If field is determined, correct, and exists, module doesn't ask even if it is contained in FIELDS.
; Returns NEWSFLG=1 if ASKFIELDS has changed Status of FILEDA, else 0
; Returns XFLG=1 if user ^exited, else 0.
; Requires PFILEDA (= Actual/Anticipated parent) if FIELDS [ .04 Type
;or .07 Status. If no such parent, send PFILEDA=0.
; Should Lock FILEDA before calling ASKFLDS.
; After calling ASKFLDS, Set back to screen mode if nec, set VALMBCK = "R" if necessary.
N DIE,DA,X,Y,NODE0,DR,PFDA,TYPEDR,USED,ITEMIFN,DIR,NAME,ANS
N TIUFQUIT,TIUFY,SIGNERS,TIUFTLST,TIUFTMSG,TIUFIMSG,DEFLT,CONTINUE
N SUPVISIT
S NEWSFLG=0,XFLG=0,NODE0=^TIU(8925.1,FILEDA,0)
S USED=$S($P(NODE0,U,4)="O":1,1:$$DDEFUSED^TIUFLF(FILEDA))
S DIE=8925.1,DA=FILEDA,TIUFQUIT=0
S PFILEDA=+$G(PFILEDA) K DIRUT
D FULL^VALM1 S TIUFFULL=1
I FIELDS'[";.01;" G ABBREV
I $P(NODE0,U,4)="O" S CONTINUE=$$WARNOBJ^TIUFLJ("N",FILEDA,NODE0) G:$D(DIRUT) ASKFX G:'CONTINUE ABBREV
NAME S DEFLT=$P(NODE0,U) K DIRUT S NAME=$$SELNAME^TIUFLF2(DEFLT) G:$D(DIRUT) ASKFX
I PFILEDA,$$DUPITEM^TIUFLF7(NAME,PFILEDA,FILEDA) W !!,"Please enter a different Name; Parent already has Item with that Name",! G NAME
D TYPELIST^TIUFLF7(NAME,FILEDA,PFILEDA,.TIUFTMSG,.TIUFTLST) G:$D(DTOUT) ASKFX
I $D(TIUFTMSG("T")) W !!,TIUFTMSG("T"),!,"Can't edit Entry",! D PAUSE^TIUFXHLX G ASKFX
I TIUFTLST="" W !!," Please enter a different Name; File already has entries of every permitted Type",!,"with that Name",! G NAME
I $P(NODE0,U,4)'="",TIUFTLST'[(U_$P(NODE0,U,4)_U) W !!,"Please enter a different Name; File already has entry of this Type",!,"with that Name",! G NAME
I $P(NODE0,U,4)="O",$$BADNAP^TIUFLF1(NAME,FILEDA,1) W " ??",!,"Object Name must be unique among all object Names, Abbreviations,",!,"and Print Names." G NAME
S DR=".01///^S X=NAME" D ^DIE S NODE0=^TIU(8925.1,FILEDA,0)
I $D(DIRUT)!$D(Y)!$D(DTOUT) S DUOUT=1 G ASKFX
ABBREV I FIELDS'[";.02;" G PRINTN
I $P(NODE0,U,4)="O" S CONTINUE=$$WARNOBJ^TIUFLJ("A",FILEDA,NODE0) G:$D(DIRUT) ASKFX G:'CONTINUE PRINTN
ABBREV1 S DR=".02" D ^DIE S NODE0=^TIU(8925.1,FILEDA,0)
I $D(DIRUT)!$D(Y)!$D(DTOUT) S DUOUT=1 G ASKFX
PRINTN I FIELDS'[";.03;" G LOINC
I $P(NODE0,U,4)="O" S CONTINUE=$$WARNOBJ^TIUFLJ("P",FILEDA,NODE0) G:$D(DIRUT) ASKFX G:'CONTINUE LOINC
PRINTN1 N TIUFUPP S DR=".03" D ^DIE S NODE0=^TIU(8925.1,FILEDA,0)
I $D(DIRUT)!$D(Y)!$D(DTOUT) S DUOUT=1 G ASKFX
; <VUID PATCH>
LOINC I FIELDS'[";1501;"!($P(NODE0,U,4)'="DOC") G NATL
N TIUOUT S TIUOUT=0
W !!,"EVERY Local Title must be mapped to a VHA Enterprise Standard Title.",!
S DR="1501" D DIRECT^TIUMAP2(FILEDA) S NODE0=^TIU(8925.1,FILEDA,0)
I $D(DIRUT)!+$G(TIUOUT)!$D(DTOUT) S DUOUT=1 G ASKFX
; </VUID PATCH>
NATL I FIELDS[";.13;",TIUFWHO="N" D G:XFLG ASKFX S NODE0=^TIU(8925.1,FILEDA,0)
. S DIR("B")=$S($P(NODE0,U,13):"YES",1:"NO")
. D
. . S DIR(0)="YO",(DIR("?"),DIR("??"))="^D HELP2^TIUFXHLX(.13)"
. . S DIR("A")="NATIONAL"
. . D ^DIR I $D(DUOUT)!$D(DTOUT) S XFLG=1 Q
. . S ANS=Y,DR=".13////^S X=ANS" D ^DIE
TYPE I FIELDS[";.04;" K DIRUT D EDTYPE^TIUFLF7(FILEDA,.NODE0,PFILEDA,.XFLG,USED) G:$D(DIRUT) ASKFX
SHARE G:FIELDS'[";.1;" OWNER
N PARENT1,PARENT2,SHARE,STATUS,DIR
I "NM"'[TIUFWHO G OWNER
I $P(NODE0,U,4)'="CO" G OWNER
I '$$PERSOWNS^TIUFLF2(FILEDA,DUZ) W !!,"SHARED: Only an Owner can edit SHARED",! G OWNER
S SHARE=$P(NODE0,U,10)
; If not presently SHARED set default=NO:
I 'SHARE S DIR("B")="NO"
; If presently SHARED but only used once, set default=YES:
S PARENT1=$O(^TIU(8925.1,"AD",FILEDA,0)),PARENT2=$S('PARENT1:0,1:$O(^TIU(8925.1,"AD",FILEDA,PARENT1)))
I SHARE,'PARENT2 S DIR("B")="YES" I $P($G(^TIU(8925.1,+PARENT1,0)),U,10) W !!,"SHARED: Subcomponent of Shared Component; Must remain Shared",! G OWNER
I 'SHARE,$P($G(^TIU(8925.1,+PARENT1,0)),U,10) S DIR("B")="YES"
N Y
I $D(DIR("B")) D G:XFLG ASKFX S NODE0=^TIU(8925.1,FILEDA,0)
. S DIR(0)="YO",(DIR("?"),DIR("??"))="^D HELP2^TIUFXHLX(.1)"
. S DIR("A")="SHARED"
. D ^DIR I $D(DUOUT)!$D(DTOUT) S XFLG=1 Q
. S ANS=Y,DR=".1////^S X=ANS" D ^DIE
I 'SHARE,$G(ANS),$$HASITEMS^TIUFLF1(FILEDA) D DSETSHAR^TIUFLD1(FILEDA) G OWNER
I SHARE,PARENT2 W !!,"SHARED: Entry is SHARED with multiple parents; Can't edit SHARED"
OWNER I FIELDS[";.05;" D EDOWN^TIUFLF8(FILEDA,.XFLG) G:XFLG ASKFX
OKDIST I FIELDS[";3.02;",TIUFWHO="N" S DR="3.02//NO" D ^DIE I $D(Y)!$D(DTOUT) S DUOUT=1 G ASKFX
SUPVISIT I FIELDS[";3.03;",$P(NODE0,U,4)="CL"!($P(NODE0,U,4)="DC")!($P(NODE0,U,4)="DOC") D G:$D(DUOUT) ASKFX
. S SUPVISIT=$P($G(^TIU(8925.1,FILEDA,3)),U,3)
. S SUPVISIT=$S(SUPVISIT=0:"NO",SUPVISIT=1:"YES",1:"")
. I SUPVISIT="" D INHERIT^TIUFLD(FILEDA,0,3.03,"E","","",.SUPVISIT) S SUPVISIT=SUPVISIT("E")
. S DR="3.03//^S X=SUPVISIT" D ^DIE I $D(Y)!$D(DTOUT) S DUOUT=1 Q
. I SUPVISIT="NO",$P($G(^TIU(8925.1,FILEDA,3)),U,3) S CONTINUE=$$WARNSUP D
. . I 'CONTINUE S DR="3.03///^S X=SUPVISIT" D ^DIE W " NOT"
. . W " Suppressed" H 1
STATUS I FIELDS'[";.07;" G ASKFX
I $P(NODE0,U,4)="CO",$P(NODE0,U,10) W !,"STATUS: Shared Components have no Status; Can't Edit Status" H:TIUFXNOD["Basics"!(TIUFXNOD["Boil") 2 G ASKFX ;P64 add msg and hang
I TIUFTMPL="A",$G(TIUFSTMP)="",($P(NODE0,U,4)="CL")!($P(NODE0,U,4)="DC")!($P(NODE0,U,4)="DOC")!($P(NODE0,U,4)="CO") W !,"STATUS: Orphans are Inactive; Can't Edit Status" H 2 G ASKFX
I $P(NODE0,U,4)="CO" W !,"STATUS: Components get their Status from their Parent; Can't Edit Status" H:TIUFXNOD["Basics"!(TIUFXNOD["Boil") 2 G ASKFX
D ASKSTAT^TIUFLF6(FILEDA,.NODE0,PFILEDA,.NEWSFLG,.XFLG)
ASKFX S:$D(DTOUT)!$D(DUOUT) XFLG=1
Q
;
WARNSUP() ; Function Warns user who asks to Suppress Visit, Returns 1 to Suppress, 0 to not Suppress.
N DIR,X,Y
S DIR(0)="Y",DIR("B")="NO",DIR("A",1)=" Warning: You will NOT GET WORKLOAD CREDIT if you Suppress Visit Selection."
S DIR("A")=" Sure you want to Suppress Visit Selection"
W ! D ^DIR W " ... "
Q Y
;
TIUFLF1 ; SLC/MAM - Library; File 8925.1 Related: HASITEMS(FILEDA), ASKFLDS(FILEDA,FIELDS,PFILEDA,NEWSFLG,XFLG), BADNAP(NAP,FILEDA,OBJFLG) ; 03/16/2007
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**2,12,17,64,211,225**;Jun 20, 1997;Build 13
+2 ;
+3 ;
+4 ;*** INCLUDES JOEL'S MODS FOR VUID PATCH ***
+5 ;
BADNAP(NAP,FILEDA,OBJFLG) ; Function returns 1 if NAP is ambiguous as a
+1 ;name, abbrev or print name for FILEDA AND such ambiguity is a problem.
+2 ;Else 0. Used when editing entries, or when finding permitted types.
+3 ; Ambiguity is a problem if OBJFLG=1. OBJFLG=1 if FILEDA is an object,
+4 ;or FILEDA WILL BE an object since we're in Create Objects, or we are
+5 ;deciding whether to include type O as a permitted type
+6 ;in TYPELIST^TIUFLF7.
+7 ; TYPELIST, NAME of object in ASKFLDS must SEND OBJFLG=1. Others are SET here.
+8 NEW NAPANS,XREF,OFILEDA
+9 SET NAPANS=0
IF NAP=""
GOTO BADNX
+10 IF $DATA(^TIU(8925.1,"AT","O",FILEDA))
SET OBJFLG=1
+11 IF $GET(TIUFTMPL)="J"
SET OBJFLG=1
+12 IF $GET(TIUFXNOD)["Copy"
IF $PIECE($GET(NODE0),U,4)="O"
SET OBJFLG=1
+13 SET OBJFLG=+$GET(OBJFLG)
+14 IF 'OBJFLG
GOTO BADNX
+15 FOR XREF="B","C","D"
Begin DoDot:1
+16 SET OFILEDA=0
FOR
SET OFILEDA=$ORDER(^TIU(8925.1,XREF,NAP,OFILEDA))
IF 'OFILEDA
QUIT
Begin DoDot:2
+17 IF OFILEDA'=FILEDA
IF $DATA(^TIU(8925.1,"AT","O",OFILEDA))
SET NAPANS=1
End DoDot:2
IF NAPANS
QUIT
End DoDot:1
IF NAPANS
QUIT
BADNX QUIT NAPANS
+1 ;
HASITEMS(FILEDA) ; Function returns 0 if FILEDA has no items, else returns 1.
+1 QUIT $ORDER(^TIU(8925.1,+FILEDA,10,0))
+2 ;
ASKFLDS(FILEDA,FIELDS,PFILEDA,NEWSFLG,XFLG) ; Ask FIELDS (String subset of: ;.01;.02;.03;.04;.05;.06;.07;.1;.13;3.03) w ;'s on ends as well as between numbers for file entry FILEDA.
+1 ; Requires FILEDA, FIELDS.
+2 ; If field is determined, correct, and exists, module doesn't ask even if it is contained in FIELDS.
+3 ; Returns NEWSFLG=1 if ASKFIELDS has changed Status of FILEDA, else 0
+4 ; Returns XFLG=1 if user ^exited, else 0.
+5 ; Requires PFILEDA (= Actual/Anticipated parent) if FIELDS [ .04 Type
+6 ;or .07 Status. If no such parent, send PFILEDA=0.
+7 ; Should Lock FILEDA before calling ASKFLDS.
+8 ; After calling ASKFLDS, Set back to screen mode if nec, set VALMBCK = "R" if necessary.
+9 NEW DIE,DA,X,Y,NODE0,DR,PFDA,TYPEDR,USED,ITEMIFN,DIR,NAME,ANS
+10 NEW TIUFQUIT,TIUFY,SIGNERS,TIUFTLST,TIUFTMSG,TIUFIMSG,DEFLT,CONTINUE
+11 NEW SUPVISIT
+12 SET NEWSFLG=0
SET XFLG=0
SET NODE0=^TIU(8925.1,FILEDA,0)
+13 SET USED=$SELECT($PIECE(NODE0,U,4)="O":1,1:$$DDEFUSED^TIUFLF(FILEDA))
+14 SET DIE=8925.1
SET DA=FILEDA
SET TIUFQUIT=0
+15 SET PFILEDA=+$GET(PFILEDA)
KILL DIRUT
+16 DO FULL^VALM1
SET TIUFFULL=1
+17 IF FIELDS'[";.01;"
GOTO ABBREV
+18 IF $PIECE(NODE0,U,4)="O"
SET CONTINUE=$$WARNOBJ^TIUFLJ("N",FILEDA,NODE0)
IF $DATA(DIRUT)
GOTO ASKFX
IF 'CONTINUE
GOTO ABBREV
NAME SET DEFLT=$PIECE(NODE0,U)
KILL DIRUT
SET NAME=$$SELNAME^TIUFLF2(DEFLT)
IF $DATA(DIRUT)
GOTO ASKFX
+1 IF PFILEDA
IF $$DUPITEM^TIUFLF7(NAME,PFILEDA,FILEDA)
WRITE !!,"Please enter a different Name; Parent already has Item with that Name",!
GOTO NAME
+2 DO TYPELIST^TIUFLF7(NAME,FILEDA,PFILEDA,.TIUFTMSG,.TIUFTLST)
IF $DATA(DTOUT)
GOTO ASKFX
+3 IF $DATA(TIUFTMSG("T"))
WRITE !!,TIUFTMSG("T"),!,"Can't edit Entry",!
DO PAUSE^TIUFXHLX
GOTO ASKFX
+4 IF TIUFTLST=""
WRITE !!," Please enter a different Name; File already has entries of every permitted Type",!,"with that Name",!
GOTO NAME
+5 IF $PIECE(NODE0,U,4)'=""
IF TIUFTLST'[(U_$PIECE(NODE0,U,4)_U)
WRITE !!,"Please enter a different Name; File already has entry of this Type",!,"with that Name",!
GOTO NAME
+6 IF $PIECE(NODE0,U,4)="O"
IF $$BADNAP^TIUFLF1(NAME,FILEDA,1)
WRITE " ??",!,"Object Name must be unique among all object Names, Abbreviations,",!,"and Print Names."
GOTO NAME
+7 SET DR=".01///^S X=NAME"
DO ^DIE
SET NODE0=^TIU(8925.1,FILEDA,0)
+8 IF $DATA(DIRUT)!$DATA(Y)!$DATA(DTOUT)
SET DUOUT=1
GOTO ASKFX
ABBREV IF FIELDS'[";.02;"
GOTO PRINTN
+1 IF $PIECE(NODE0,U,4)="O"
SET CONTINUE=$$WARNOBJ^TIUFLJ("A",FILEDA,NODE0)
IF $DATA(DIRUT)
GOTO ASKFX
IF 'CONTINUE
GOTO PRINTN
ABBREV1 SET DR=".02"
DO ^DIE
SET NODE0=^TIU(8925.1,FILEDA,0)
+1 IF $DATA(DIRUT)!$DATA(Y)!$DATA(DTOUT)
SET DUOUT=1
GOTO ASKFX
PRINTN IF FIELDS'[";.03;"
GOTO LOINC
+1 IF $PIECE(NODE0,U,4)="O"
SET CONTINUE=$$WARNOBJ^TIUFLJ("P",FILEDA,NODE0)
IF $DATA(DIRUT)
GOTO ASKFX
IF 'CONTINUE
GOTO LOINC
PRINTN1 NEW TIUFUPP
SET DR=".03"
DO ^DIE
SET NODE0=^TIU(8925.1,FILEDA,0)
+1 IF $DATA(DIRUT)!$DATA(Y)!$DATA(DTOUT)
SET DUOUT=1
GOTO ASKFX
+2 ; <VUID PATCH>
LOINC IF FIELDS'[";1501;"!($PIECE(NODE0,U,4)'="DOC")
GOTO NATL
+1 NEW TIUOUT
SET TIUOUT=0
+2 WRITE !!,"EVERY Local Title must be mapped to a VHA Enterprise Standard Title.",!
+3 SET DR="1501"
DO DIRECT^TIUMAP2(FILEDA)
SET NODE0=^TIU(8925.1,FILEDA,0)
+4 IF $DATA(DIRUT)!+$GET(TIUOUT)!$DATA(DTOUT)
SET DUOUT=1
GOTO ASKFX
+5 ; </VUID PATCH>
NATL IF FIELDS[";.13;"
IF TIUFWHO="N"
Begin DoDot:1
+1 SET DIR("B")=$SELECT($PIECE(NODE0,U,13):"YES",1:"NO")
+2 Begin DoDot:2
+3 SET DIR(0)="YO"
SET (DIR("?"),DIR("??"))="^D HELP2^TIUFXHLX(.13)"
+4 SET DIR("A")="NATIONAL"
+5 DO ^DIR
IF $DATA(DUOUT)!$DATA(DTOUT)
SET XFLG=1
QUIT
+6 SET ANS=Y
SET DR=".13////^S X=ANS"
DO ^DIE
End DoDot:2
End DoDot:1
IF XFLG
GOTO ASKFX
SET NODE0=^TIU(8925.1,FILEDA,0)
TYPE IF FIELDS[";.04;"
KILL DIRUT
DO EDTYPE^TIUFLF7(FILEDA,.NODE0,PFILEDA,.XFLG,USED)
IF $DATA(DIRUT)
GOTO ASKFX
SHARE IF FIELDS'[";.1;"
GOTO OWNER
+1 NEW PARENT1,PARENT2,SHARE,STATUS,DIR
+2 IF "NM"'[TIUFWHO
GOTO OWNER
+3 IF $PIECE(NODE0,U,4)'="CO"
GOTO OWNER
+4 IF '$$PERSOWNS^TIUFLF2(FILEDA,DUZ)
WRITE !!,"SHARED: Only an Owner can edit SHARED",!
GOTO OWNER
+5 SET SHARE=$PIECE(NODE0,U,10)
+6 ; If not presently SHARED set default=NO:
+7 IF 'SHARE
SET DIR("B")="NO"
+8 ; If presently SHARED but only used once, set default=YES:
+9 SET PARENT1=$ORDER(^TIU(8925.1,"AD",FILEDA,0))
SET PARENT2=$SELECT('PARENT1:0,1:$ORDER(^TIU(8925.1,"AD",FILEDA,PARENT1)))
+10 IF SHARE
IF 'PARENT2
SET DIR("B")="YES"
IF $PIECE($GET(^TIU(8925.1,+PARENT1,0)),U,10)
WRITE !!,"SHARED: Subcomponent of Shared Component; Must remain Shared",!
GOTO OWNER
+11 IF 'SHARE
IF $PIECE($GET(^TIU(8925.1,+PARENT1,0)),U,10)
SET DIR("B")="YES"
+12 NEW Y
+13 IF $DATA(DIR("B"))
Begin DoDot:1
+14 SET DIR(0)="YO"
SET (DIR("?"),DIR("??"))="^D HELP2^TIUFXHLX(.1)"
+15 SET DIR("A")="SHARED"
+16 DO ^DIR
IF $DATA(DUOUT)!$DATA(DTOUT)
SET XFLG=1
QUIT
+17 SET ANS=Y
SET DR=".1////^S X=ANS"
DO ^DIE
End DoDot:1
IF XFLG
GOTO ASKFX
SET NODE0=^TIU(8925.1,FILEDA,0)
+18 IF 'SHARE
IF $GET(ANS)
IF $$HASITEMS^TIUFLF1(FILEDA)
DO DSETSHAR^TIUFLD1(FILEDA)
GOTO OWNER
+19 IF SHARE
IF PARENT2
WRITE !!,"SHARED: Entry is SHARED with multiple parents; Can't edit SHARED"
OWNER IF FIELDS[";.05;"
DO EDOWN^TIUFLF8(FILEDA,.XFLG)
IF XFLG
GOTO ASKFX
OKDIST IF FIELDS[";3.02;"
IF TIUFWHO="N"
SET DR="3.02//NO"
DO ^DIE
IF $DATA(Y)!$DATA(DTOUT)
SET DUOUT=1
GOTO ASKFX
SUPVISIT IF FIELDS[";3.03;"
IF $PIECE(NODE0,U,4)="CL"!($PIECE(NODE0,U,4)="DC")!($PIECE(NODE0,U,4)="DOC")
Begin DoDot:1
+1 SET SUPVISIT=$PIECE($GET(^TIU(8925.1,FILEDA,3)),U,3)
+2 SET SUPVISIT=$SELECT(SUPVISIT=0:"NO",SUPVISIT=1:"YES",1:"")
+3 IF SUPVISIT=""
DO INHERIT^TIUFLD(FILEDA,0,3.03,"E","","",.SUPVISIT)
SET SUPVISIT=SUPVISIT("E")
+4 SET DR="3.03//^S X=SUPVISIT"
DO ^DIE
IF $DATA(Y)!$DATA(DTOUT)
SET DUOUT=1
QUIT
+5 IF SUPVISIT="NO"
IF $PIECE($GET(^TIU(8925.1,FILEDA,3)),U,3)
SET CONTINUE=$$WARNSUP
Begin DoDot:2
+6 IF 'CONTINUE
SET DR="3.03///^S X=SUPVISIT"
DO ^DIE
WRITE " NOT"
+7 WRITE " Suppressed"
HANG 1
End DoDot:2
End DoDot:1
IF $DATA(DUOUT)
GOTO ASKFX
STATUS IF FIELDS'[";.07;"
GOTO ASKFX
+1 ;P64 add msg and hang
IF $PIECE(NODE0,U,4)="CO"
IF $PIECE(NODE0,U,10)
WRITE !,"STATUS: Shared Components have no Status; Can't Edit Status"
IF TIUFXNOD["Basics"!(TIUFXNOD["Boil")
HANG 2
GOTO ASKFX
+2 IF TIUFTMPL="A"
IF $GET(TIUFSTMP)=""
IF ($PIECE(NODE0,U,4)="CL")!($PIECE(NODE0,U,4)="DC")!($PIECE(NODE0,U,4)="DOC")!($PIECE(NODE0,U,4)="CO")
WRITE !,"STATUS: Orphans are Inactive; Can't Edit Status"
HANG 2
GOTO ASKFX
+3 IF $PIECE(NODE0,U,4)="CO"
WRITE !,"STATUS: Components get their Status from their Parent; Can't Edit Status"
IF TIUFXNOD["Basics"!(TIUFXNOD["Boil")
HANG 2
GOTO ASKFX
+4 DO ASKSTAT^TIUFLF6(FILEDA,.NODE0,PFILEDA,.NEWSFLG,.XFLG)
ASKFX IF $DATA(DTOUT)!$DATA(DUOUT)
SET XFLG=1
+1 QUIT
+2 ;
WARNSUP() ; Function Warns user who asks to Suppress Visit, Returns 1 to Suppress, 0 to not Suppress.
+1 NEW DIR,X,Y
+2 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A",1)=" Warning: You will NOT GET WORKLOAD CREDIT if you Suppress Visit Selection."
+3 SET DIR("A")=" Sure you want to Suppress Visit Selection"
+4 WRITE !
DO ^DIR
WRITE " ... "
+5 QUIT Y
+6 ;
