- 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
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUFLF1 7521 printed Feb 19, 2025@00:07:33 Page 2
- 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 ;