TIUFLF4 ; SLC/MAM - Lib; ANCESTOR(FILEDA,NODE0,ANCESTOR,DOCFLAG), ORPHAN(FILEDA,NODE0,ANCESTOR), STUFFLDS(FILEDA,PFILEDA), ADDTEN(PFILEDA,FILEDA,NODE0,TENDA),NUMITEMS(FILEDA), MISSITEM(FILEDA) ;4/23/97 11:02
;;1.0;TEXT INTEGRATION UTILITIES;**11,43,236,232**;Jun 20, 1997;Build 19
;
NUMITEMS(FILEDA) ; Function returns Number of Items of FILEDA; Possibly 0
N ITEMSANS,TIUFI
S (ITEMSANS,TIUFI)=0
F S TIUFI=$O(^TIU(8925.1,FILEDA,10,TIUFI)) G:'TIUFI NUMIX S ITEMSANS=ITEMSANS+1
NUMIX Q ITEMSANS
;
MISSITEM(FILEDA) ; Function Checks FILEDA Items (doesn't check subitems etc.) for existence only. Returns IFN of first missing item it finds, else 0.
; Requires FILEDA.
N TIUI,IFILEDA,MISSANS
S TIUI=0,MISSANS=0
F S TIUI=$O(^TIU(8925.1,FILEDA,10,TIUI)) Q:'TIUI!MISSANS D
. S IFILEDA=+^TIU(8925.1,FILEDA,10,TIUI,0)
. I '$D(^TIU(8925.1,IFILEDA,0)) S MISSANS=IFILEDA
Q MISSANS
;
ANCESTOR(FILEDA,NODE0,ANCESTOR,DOCFLAG) ; Module traces ancestors of FILEDA,
;creates array ANCESTOR,
; where ANCESTOR(0)=FILEDA,
; where ANCESTOR(1)=Parent IFN of FILEDA,
; ANCESTOR(2)=Parent IFN of ANCESTOR(1)
; ...
; ANCESTOR(last subscript)=IFN of oldest ancestor of FILEDA if
; '$G(DOCFLAG)
; OR
; IFN of oldest ancestor of FILEDA NOT
; OF TYPE DC OR CL if $G(DOCFLAG)
; Don't stop the array for problems like bad type, no type, type object.
; If DOCFLAG, DON'T GET DC or CL; don't want array to mistakenly
;go all the way to CLinical Documents.
; Array may not EXIST if DOCFLAG
; Requires FILEDA, NODE0= 0 Node;
; DOCFLAG optional, 0 or 1
N TIUI,QUIT,ANODE0
S DOCFLAG=+$G(DOCFLAG)
I DOCFLAG,($P(NODE0,U,4)="DC")!($P(NODE0,U,4)="CL") G ANCEX
S TIUI=0,ANCESTOR(0)=FILEDA
F D Q:$G(QUIT)
. S ANCESTOR(TIUI+1)=$O(^TIU(8925.1,"AD",ANCESTOR(TIUI),0))
. I 'ANCESTOR(TIUI+1) K ANCESTOR(TIUI+1) S QUIT=1 Q
. I DOCFLAG S ANODE0=^TIU(8925.1,ANCESTOR(TIUI+1),0) I ($P(ANODE0,U,4)="DC")!($P(ANODE0,U,4)="CL") K ANCESTOR(TIUI+1) S QUIT=1 Q
. S TIUI=TIUI+1
ANCEX Q
;
ORPHAN(FILEDA,NODE0,ANCESTOR) ; Function traces ancestors of FILEDA,
; Returns NA if FILEDA is Object or Shared Component,
; NO if NOT NA AND FILEDA belongs to Clinical Docmts Hierarchy,
; YES if NOT NA, AND doesn't belong.
; Requires FILEDA, NODE0= 0 Node;
N ORPHAN,LAST
I $P(NODE0,U,4)="O" S ORPHAN="NA" G ORPHX
I '$D(ANCESTOR) D ANCESTOR(FILEDA,NODE0,.ANCESTOR)
I '$D(^TMP("TIUF",$J,"CLINDOC")) D G:Y=-1 ORPHX
. N DIC,X,Y
. S DIC=8925.1,DIC(0)="X",X="CLINICAL DOCUMENTS" D ^DIC
. I Y=-1 S ORPHAN="UNKNOWN" Q
. S ^TMP("TIUF",$J,"CLINDOC")=+Y
S LAST=$O(ANCESTOR(100),-1) I ANCESTOR(LAST)=^TMP("TIUF",$J,"CLINDOC") S ORPHAN="NO" G ORPHX
S ORPHAN="YES"
ORPHX Q ORPHAN
;
STUFFLDS(FILEDA,PFILEDA) ; Stuff fields .03, .04 (tries), .07, [.1]
;for 8925.1 entry FILEDA.
; Requires FILEDA.
; Requires TIUFTLST as set in TYPELIST^TIUFLF7
; Requires PFILEDA if entry has prospective (as in Create and Add Item)
;or actual parent in order to try to stuff Type.
; Stuffs .03 Print Name = First 60 chars of .01 Name if not from copy
;action.
; Stuffs .04 Type if only 1 possible type in TIUFTLST (because of parent
;or duplicates or option e.g. create objects).
; Stuffs .07 Status = Inactive.
; If receives parent PFILEDA, parent is Shared, then
;stuffs .1 Shared = 1
; Should Lock FILEDA before calling STUFFLDS.
N DIE,DA,DR,Y,NAME,PRINTDR,TYPEDR,STATUSDR,SHAREDR
N NATL,NATLDR,NODE0,TYPE
I '$G(PFILEDA) S PFILEDA=0
S DIE=8925.1,DA=FILEDA
S NODE0=^TIU(8925.1,FILEDA,0),NAME=$P(NODE0,U),PRINTDR=".03///^S X=NAME"
I $L(TIUFTLST,U)=3 S TYPE=$P(TIUFTLST,U,2),TYPEDR=".04////^S X=TYPE"
S STATUSDR=".07///INACTIVE"
S SHAREDR=".1////1"
I $G(XQORNOD(0))'["Copy" S DR=PRINTDR
;VMP/ELR P232. On a copy set print name equal title if not an object menu.
I $G(TIUFXNOD)["Copy",$G(ACTION)="C",$P($G(NODE0),U,4)'="O" S DR=PRINTDR
I $G(TYPEDR) S DR=$S($D(DR):DR_";"_TYPEDR,1:TYPEDR)
S DR=$S($D(DR):DR_";"_STATUSDR,1:STATUSDR)
I $P($G(^TIU(8925.1,PFILEDA,0)),U,10) S DR=DR_";"_SHAREDR
D ^DIE
STUFFX Q
;
ADDTEN(PFILEDA,FILEDA,NODE0,TENDA) ; Add item FILEDA to 10 NODE of
;File 8925.1 entry PFILEDA. Stuff item Menu Text
; Requires PFILEDA = 8925.1 IFN of parent of FILEDA.
; Requires FILEDA, Requires NODE0 = ^TIU(8925.1,FILEDA,0)
; Returns TENDA = 10 node DA of new item.
; Returns TENDA="" if fails lookup. Screen on fld 10, subfld .01
;prevents lookup failure due to duplicate names by allowing only
;FILEDA to pass screen.
;Should Lock PFILEDA before calling ADDTEN.
N X,Y,DIE,DR,NAME,DA,DIC,DLAYGO,TIUFISCR,MSG,DUPITEM
S TENDA=""
I ('$G(PFILEDA))!('$G(FILEDA)) G ADDTX
S NAME=$P(NODE0,U)
I '$D(TIUFTLST) S DUPITEM=0,DUPITEM=$$DUPITEM^TIUFLF7(NAME,PFILEDA) I DUPITEM S MSG=" Can't add Item; Parent already has Item with the same Name" W !!,MSG,! G ADDTX ; possibly needed when called from TIU rather than from TIUF.
S X=""""_NAME_""""
S DA(1)=PFILEDA,DLAYGO=8925.1
S TIUFISCR=FILEDA ; activates screen on fld 10, Subfld .01 in DD
S DIC="^TIU(8925.1,DA(1),10,",DIC(0)="L",DIC("P")=$P(^DD(8925.1,10,0),U,2)
D ^DIC S TENDA=+Y I Y=-1 S TENDA="" G ADDTX
K DIC
S DA=TENDA,DA(1)=PFILEDA D MTXTCHEC^TIUFT1(.DA,FILEDA,1)
ADDTX Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUFLF4 5423 printed Dec 13, 2024@02:41:07 Page 2
TIUFLF4 ; SLC/MAM - Lib; ANCESTOR(FILEDA,NODE0,ANCESTOR,DOCFLAG), ORPHAN(FILEDA,NODE0,ANCESTOR), STUFFLDS(FILEDA,PFILEDA), ADDTEN(PFILEDA,FILEDA,NODE0,TENDA),NUMITEMS(FILEDA), MISSITEM(FILEDA) ;4/23/97 11:02
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**11,43,236,232**;Jun 20, 1997;Build 19
+2 ;
NUMITEMS(FILEDA) ; Function returns Number of Items of FILEDA; Possibly 0
+1 NEW ITEMSANS,TIUFI
+2 SET (ITEMSANS,TIUFI)=0
+3 FOR
SET TIUFI=$ORDER(^TIU(8925.1,FILEDA,10,TIUFI))
if 'TIUFI
GOTO NUMIX
SET ITEMSANS=ITEMSANS+1
NUMIX QUIT ITEMSANS
+1 ;
MISSITEM(FILEDA) ; Function Checks FILEDA Items (doesn't check subitems etc.) for existence only. Returns IFN of first missing item it finds, else 0.
+1 ; Requires FILEDA.
+2 NEW TIUI,IFILEDA,MISSANS
+3 SET TIUI=0
SET MISSANS=0
+4 FOR
SET TIUI=$ORDER(^TIU(8925.1,FILEDA,10,TIUI))
if 'TIUI!MISSANS
QUIT
Begin DoDot:1
+5 SET IFILEDA=+^TIU(8925.1,FILEDA,10,TIUI,0)
+6 IF '$DATA(^TIU(8925.1,IFILEDA,0))
SET MISSANS=IFILEDA
End DoDot:1
+7 QUIT MISSANS
+8 ;
ANCESTOR(FILEDA,NODE0,ANCESTOR,DOCFLAG) ; Module traces ancestors of FILEDA,
+1 ;creates array ANCESTOR,
+2 ; where ANCESTOR(0)=FILEDA,
+3 ; where ANCESTOR(1)=Parent IFN of FILEDA,
+4 ; ANCESTOR(2)=Parent IFN of ANCESTOR(1)
+5 ; ...
+6 ; ANCESTOR(last subscript)=IFN of oldest ancestor of FILEDA if
+7 ; '$G(DOCFLAG)
+8 ; OR
+9 ; IFN of oldest ancestor of FILEDA NOT
+10 ; OF TYPE DC OR CL if $G(DOCFLAG)
+11 ; Don't stop the array for problems like bad type, no type, type object.
+12 ; If DOCFLAG, DON'T GET DC or CL; don't want array to mistakenly
+13 ;go all the way to CLinical Documents.
+14 ; Array may not EXIST if DOCFLAG
+15 ; Requires FILEDA, NODE0= 0 Node;
+16 ; DOCFLAG optional, 0 or 1
+17 NEW TIUI,QUIT,ANODE0
+18 SET DOCFLAG=+$GET(DOCFLAG)
+19 IF DOCFLAG
IF ($PIECE(NODE0,U,4)="DC")!($PIECE(NODE0,U,4)="CL")
GOTO ANCEX
+20 SET TIUI=0
SET ANCESTOR(0)=FILEDA
+21 FOR
Begin DoDot:1
+22 SET ANCESTOR(TIUI+1)=$ORDER(^TIU(8925.1,"AD",ANCESTOR(TIUI),0))
+23 IF 'ANCESTOR(TIUI+1)
KILL ANCESTOR(TIUI+1)
SET QUIT=1
QUIT
+24 IF DOCFLAG
SET ANODE0=^TIU(8925.1,ANCESTOR(TIUI+1),0)
IF ($PIECE(ANODE0,U,4)="DC")!($PIECE(ANODE0,U,4)="CL")
KILL ANCESTOR(TIUI+1)
SET QUIT=1
QUIT
+25 SET TIUI=TIUI+1
End DoDot:1
if $GET(QUIT)
QUIT
ANCEX QUIT
+1 ;
ORPHAN(FILEDA,NODE0,ANCESTOR) ; Function traces ancestors of FILEDA,
+1 ; Returns NA if FILEDA is Object or Shared Component,
+2 ; NO if NOT NA AND FILEDA belongs to Clinical Docmts Hierarchy,
+3 ; YES if NOT NA, AND doesn't belong.
+4 ; Requires FILEDA, NODE0= 0 Node;
+5 NEW ORPHAN,LAST
+6 IF $PIECE(NODE0,U,4)="O"
SET ORPHAN="NA"
GOTO ORPHX
+7 IF '$DATA(ANCESTOR)
DO ANCESTOR(FILEDA,NODE0,.ANCESTOR)
+8 IF '$DATA(^TMP("TIUF",$JOB,"CLINDOC"))
Begin DoDot:1
+9 NEW DIC,X,Y
+10 SET DIC=8925.1
SET DIC(0)="X"
SET X="CLINICAL DOCUMENTS"
DO ^DIC
+11 IF Y=-1
SET ORPHAN="UNKNOWN"
QUIT
+12 SET ^TMP("TIUF",$JOB,"CLINDOC")=+Y
End DoDot:1
if Y=-1
GOTO ORPHX
+13 SET LAST=$ORDER(ANCESTOR(100),-1)
IF ANCESTOR(LAST)=^TMP("TIUF",$JOB,"CLINDOC")
SET ORPHAN="NO"
GOTO ORPHX
+14 SET ORPHAN="YES"
ORPHX QUIT ORPHAN
+1 ;
STUFFLDS(FILEDA,PFILEDA) ; Stuff fields .03, .04 (tries), .07, [.1]
+1 ;for 8925.1 entry FILEDA.
+2 ; Requires FILEDA.
+3 ; Requires TIUFTLST as set in TYPELIST^TIUFLF7
+4 ; Requires PFILEDA if entry has prospective (as in Create and Add Item)
+5 ;or actual parent in order to try to stuff Type.
+6 ; Stuffs .03 Print Name = First 60 chars of .01 Name if not from copy
+7 ;action.
+8 ; Stuffs .04 Type if only 1 possible type in TIUFTLST (because of parent
+9 ;or duplicates or option e.g. create objects).
+10 ; Stuffs .07 Status = Inactive.
+11 ; If receives parent PFILEDA, parent is Shared, then
+12 ;stuffs .1 Shared = 1
+13 ; Should Lock FILEDA before calling STUFFLDS.
+14 NEW DIE,DA,DR,Y,NAME,PRINTDR,TYPEDR,STATUSDR,SHAREDR
+15 NEW NATL,NATLDR,NODE0,TYPE
+16 IF '$GET(PFILEDA)
SET PFILEDA=0
+17 SET DIE=8925.1
SET DA=FILEDA
+18 SET NODE0=^TIU(8925.1,FILEDA,0)
SET NAME=$PIECE(NODE0,U)
SET PRINTDR=".03///^S X=NAME"
+19 IF $LENGTH(TIUFTLST,U)=3
SET TYPE=$PIECE(TIUFTLST,U,2)
SET TYPEDR=".04////^S X=TYPE"
+20 SET STATUSDR=".07///INACTIVE"
+21 SET SHAREDR=".1////1"
+22 IF $GET(XQORNOD(0))'["Copy"
SET DR=PRINTDR
+23 ;VMP/ELR P232. On a copy set print name equal title if not an object menu.
+24 IF $GET(TIUFXNOD)["Copy"
IF $GET(ACTION)="C"
IF $PIECE($GET(NODE0),U,4)'="O"
SET DR=PRINTDR
+25 IF $GET(TYPEDR)
SET DR=$SELECT($DATA(DR):DR_";"_TYPEDR,1:TYPEDR)
+26 SET DR=$SELECT($DATA(DR):DR_";"_STATUSDR,1:STATUSDR)
+27 IF $PIECE($GET(^TIU(8925.1,PFILEDA,0)),U,10)
SET DR=DR_";"_SHAREDR
+28 DO ^DIE
STUFFX QUIT
+1 ;
ADDTEN(PFILEDA,FILEDA,NODE0,TENDA) ; Add item FILEDA to 10 NODE of
+1 ;File 8925.1 entry PFILEDA. Stuff item Menu Text
+2 ; Requires PFILEDA = 8925.1 IFN of parent of FILEDA.
+3 ; Requires FILEDA, Requires NODE0 = ^TIU(8925.1,FILEDA,0)
+4 ; Returns TENDA = 10 node DA of new item.
+5 ; Returns TENDA="" if fails lookup. Screen on fld 10, subfld .01
+6 ;prevents lookup failure due to duplicate names by allowing only
+7 ;FILEDA to pass screen.
+8 ;Should Lock PFILEDA before calling ADDTEN.
+9 NEW X,Y,DIE,DR,NAME,DA,DIC,DLAYGO,TIUFISCR,MSG,DUPITEM
+10 SET TENDA=""
+11 IF ('$GET(PFILEDA))!('$GET(FILEDA))
GOTO ADDTX
+12 SET NAME=$PIECE(NODE0,U)
+13 ; possibly needed when called from TIU rather than from TIUF.
IF '$DATA(TIUFTLST)
SET DUPITEM=0
SET DUPITEM=$$DUPITEM^TIUFLF7(NAME,PFILEDA)
IF DUPITEM
SET MSG=" Can't add Item; Parent already has Item with the same Name"
WRITE !!,MSG,!
GOTO ADDTX
+14 SET X=""""_NAME_""""
+15 SET DA(1)=PFILEDA
SET DLAYGO=8925.1
+16 ; activates screen on fld 10, Subfld .01 in DD
SET TIUFISCR=FILEDA
+17 SET DIC="^TIU(8925.1,DA(1),10,"
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(8925.1,10,0),U,2)
+18 DO ^DIC
SET TENDA=+Y
IF Y=-1
SET TENDA=""
GOTO ADDTX
+19 KILL DIC
+20 SET DA=TENDA
SET DA(1)=PFILEDA
DO MTXTCHEC^TIUFT1(.DA,FILEDA,1)
ADDTX QUIT
+1 ;
