- 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 Feb 19, 2025@00:07:36 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 ;