TIUPS165 ; SLC/MAM - After installing TIU*1*165;6/26/03
;;1.0;Text Integration Utilities;**165**;Jun 20, 1997
; Run this after installing patch 165.
;Use option: TIU165 DDEFS & RULES, PRF
; External References
; DBIA 4127 MAIN^USRPS24
BEGIN ; Create DDEFS
W !!,"This option creates Document Definitions, a User Class, and"
W !,"a Business Rule for Patient Record Flags."
W ! K IOP S %ZIS="Q" D ^%ZIS I POP K POP Q
I $D(IO("Q")) K IO("Q") D Q
.S ZTRTN="MAIN^TIUPS165"
.S ZTDESC="Create DDefs, User Class, Rules for Patient Record Flags - TIU*1*165"
.D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued!",1:"Request Canceled!")
.K ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
.D HOME^%ZIS
U IO D MAIN,^%ZISC
Q
;
MAIN ; Create DDEFS for Patient Record Flags
; -- Check for dups created after the install but before this option:
K ^XTMP("TIU165","DUPS"),^TMP("TIU165",$J)
D SETXTMP^TIUEN165
N TIUDUPS,TMPCNT,SILENT S TMPCNT=0
S TMPCNT=TMPCNT+1,^TMP("TIU165",$J,TMPCNT)=""
S TMPCNT=1,^TMP("TIU165",$J,TMPCNT)=" ***** Document Definitions for PATIENT RECORD FLAGS *****"
S TMPCNT=TMPCNT+1,^TMP("TIU165",$J,TMPCNT)=""
S SILENT=1
D TIUDUPS^TIUEN165(.TIUDUPS,SILENT)
; -- If potential duplicates exist, quit:
I $G(TIUDUPS) D G MAINX
. S ^XTMP("TIU165","DUPS")=1
. S TMPCNT=TMPCNT+1,^TMP("TIU165",$J,TMPCNT)="Duplicate problem. See description for patch TIU*1*165,"
. S TMPCNT=TMPCNT+1,^TMP("TIU165",$J,TMPCNT)="in the National Patch Module."
; -- Set file data, other data for DDEFS:
D SETDATA^TIU165D
N NUM S NUM=0
F S NUM=$O(^XTMP("TIU165","BASICS",NUM)) Q:'NUM D
. N IEN,YDDEF,TIUDA
. ; -- If DDEF was previously created by this patch,
. ; say so and quit:
. S IEN=+$G(^XTMP("TIU165","BASICS",NUM,"DONE"))
. I IEN D Q
. . S TMPCNT=TMPCNT+1,^TMP("TIU165",$J,TMPCNT)=^XTMP("TIU165","FILEDATA",NUM,.04)_" "_^XTMP("TIU165","BASICS",NUM,"NAME")
. . S TMPCNT=TMPCNT+1,^TMP("TIU165",$J,TMPCNT)=" was already created in a previous install."
. . K ^XTMP("TIU165","FILEDATA",NUM)
. . K ^XTMP("TIU165","DATA",NUM)
. ; -- If not, create new DDEF:
. S YDDEF=$$CREATE(NUM)
. I +YDDEF'>0!($P(YDDEF,U,3)'=1) D Q
. . S TMPCNT=TMPCNT+1,^TMP("TIU165",$J,TMPCNT)="Couldn't create a "_^XTMP("TIU165","FILEDATA",NUM,.04)_" named "_^XTMP("TIU165","BASICS",NUM,"NAME")_".",TMPCNT=TMPCNT+1
. . S TMPCNT=TMPCNT+1,^TMP("TIU165",$J,TMPCNT)=" Please contact National VistA Support for help."
. S TMPCNT=TMPCNT+1,^TMP("TIU165",$J,TMPCNT)=^XTMP("TIU165","FILEDATA",NUM,.04)_" named "_^XTMP("TIU165","BASICS",NUM,"NAME")
. S TMPCNT=TMPCNT+1,^TMP("TIU165",$J,TMPCNT)=" created successfully."
. S TIUDA=+YDDEF
. ; -- File field data:
. D FILE(NUM,TIUDA,.TMPCNT)
. K ^XTMP("TIU165","FILEDATA",NUM)
. ; -- Add item to parent:
. D ADDITEM(NUM,TIUDA,.TMPCNT)
. K ^XTMP("TIU165","DATA",NUM)
MAINX ;Exit
S TMPCNT=TMPCNT+1,^TMP("TIU165",$J,TMPCNT)=""
S TMPCNT=TMPCNT+1,^TMP("TIU165",$J,TMPCNT)=" *************"
I '$G(^XTMP("TIU165","DUPS")) D MAIN^USRPS24
D PRINT
K ^TMP("TIU165",$J),^TMP("USR24",$J)
Q
;
PRINT ; Print out results
N TIUCNT,TIUCONT
I $D(ZTQUEUED) S ZTREQ="@" ; Tell TaskMan to delete Task log entry
I $E(IOST)="C" W @IOF,!
S TIUCNT="",TIUCONT=1
F S TIUCNT=$O(^TMP("TIU165",$J,TIUCNT)) Q:TIUCNT="" D Q:'TIUCONT
. S TIUCONT=$$SETCONT Q:'TIUCONT
. W ^TMP("TIU165",$J,TIUCNT),!
Q:'TIUCONT
S TIUCNT=""
F S TIUCNT=$O(^TMP("USR24",$J,TIUCNT)) Q:TIUCNT="" D Q:'TIUCONT
. S TIUCONT=$$SETCONT Q:'TIUCONT
. W ^TMP("USR24",$J,TIUCNT),!
PRINTX Q
;
STOP() ;on screen paging check
; quits TIUCONT=1 if cont. ELSE quits TIUCONT=0
N DIR,Y,TIUCONT
S DIR(0)="E" D ^DIR
S TIUCONT=Y
I TIUCONT W @IOF,!
Q TIUCONT
;
SETCONT() ; D form feed, Set TIUCONT
N TIUCONT
S TIUCONT=1
I $E(IOST)="C" G SETX:$Y+5<IOSL
I $E(IOST)="C" S TIUCONT=$$STOP G SETX
G:$Y+8<IOSL SETX
W @IOF
SETX Q TIUCONT
;
PARENT(NUM) ; Return IEN of parent new DDEF should be added to
N PIEN,PNUM
; Parent node has form:
; -- PIEN node = IEN of parent if known, or if not,
; PNUM node = DDEF# of parent
S PIEN=$G(^XTMP("TIU165","DATA",NUM,"PIEN"))
; -- If parent IEN is known, we're done:
I +PIEN G PARENTX
; -- If not, get DDEF# of parent
S PNUM=$G(^XTMP("TIU165","DATA",NUM,"PNUM"))
I 'PNUM Q 0
; -- Get Parent IEN from "DONE" node, which was set
; when parent was created:
S PIEN=+$G(^XTMP("TIU165","BASICS",PNUM,"DONE"))
PARENTX Q PIEN
;
ADDITEM(NUM,TIUDA,TMPCNT) ; Add DDEF to Parent; Set item fields
N PIEN,MENUTXT,TIUFPRIV,TIUFISCR
N DIE,DR
S TIUFPRIV=1
S PIEN=$$PARENT(NUM)
I 'PIEN!'$D(^TIU(8925.1,PIEN,0))!'$D(^TIU(8925.1,TIUDA,0)) K PIEN G ADDX
N DA,DIC,DLAYGO,X,Y
N I,DIY
S DA(1)=PIEN
S DIC="^TIU(8925.1,"_DA(1)_",10,",DIC(0)="LX"
S DLAYGO=8925.14
;S X="`"_TIUDA
; -- If TIUDA is say, x, and Parent has x as IFN in Item subfile,
; code finds item x under parent instead of creating a new item,
; so don't use "`"_TIUDA:
S X=^XTMP("TIU165","BASICS",NUM,"NAME")
; -- Make sure the DDEF it adds is TIUDA and not another w same name:
S TIUFISCR=TIUDA ; activates screen on fld 10, Subfld .01 in DD
D ^DIC I Y'>0!($P(Y,U,3)'=1) K PIEN G ADDX
; -- Set Menu Text:
S MENUTXT=$G(^XTMP("TIU165","DATA",NUM,"MENUTXT"))
I $L(MENUTXT) D
. N DA,DIE,DR
. N D,D0,DI,DQ
. S DA(1)=PIEN
. S DA=+Y,DIE=DIC
. S DR="4////^S X=MENUTXT"
. D ^DIE
ADDX ; -- Tell user about adding to parent:
I '$G(PIEN) D
. S TMPCNT=TMPCNT+1,^TMP("TIU165",$J,TMPCNT)=" Couldn't add entry to parent. Please contact National VistA Support"
. S TMPCNT=TMPCNT+1,^TMP("TIU165",$J,TMPCNT)=" for help."
E S TMPCNT=TMPCNT+1,^TMP("TIU165",$J,TMPCNT)=" Entry added to parent."
Q
;
FILE(NUM,TIUDA,TMPCNT) ; File fields for new entry TIUDA
; Files ALL FIELDS set in "FILEDATA" nodes of ^XTMP:
; ^XTMP("TIU165","FILEDATA",NUM,Field#)
N TIUFPRIV,FDA,TIUERR
S TIUFPRIV=1
M FDA(8925.1,TIUDA_",")=^XTMP("TIU165","FILEDATA",NUM)
D FILE^DIE("TE","FDA","TIUERR")
I $D(TIUERR) S TMPCNT=TMPCNT+1,^TMP("TIU165",$J,TMPCNT)=" Problem filing data for entry. Please contact National VistA Support."
E S TMPCNT=TMPCNT+1,^TMP("TIU165",$J,TMPCNT)=" Data for entry filed successfully."
Q
;
CREATE(NUM) ; Create new DDEF entry
N DIC,DLAYGO,DA,X,Y,TIUFPRIV
S TIUFPRIV=1
;S (DIC,DLAYGO)="^TIU(8925.1,"
;CACHE won't take global root for DLAYGO; use file number:
S DIC="^TIU(8925.1,",DLAYGO=8925.1
S DIC(0)="LX",X=^XTMP("TIU165","BASICS",NUM,"NAME")
S DIC("S")="I $P(^(0),U,4)="_""""_^XTMP("TIU165","BASICS",NUM,"INTTYPE")_""""
D ^DIC
; -- If DDEF was just created, set "DONE" node = IEN
I $P(Y,U,3)=1 S ^XTMP("TIU165","BASICS",NUM,"DONE")=+$G(Y)
Q $G(Y)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUPS165 6804 printed Oct 16, 2024@18:44:42 Page 2
TIUPS165 ; SLC/MAM - After installing TIU*1*165;6/26/03
+1 ;;1.0;Text Integration Utilities;**165**;Jun 20, 1997
+2 ; Run this after installing patch 165.
+3 ;Use option: TIU165 DDEFS & RULES, PRF
+4 ; External References
+5 ; DBIA 4127 MAIN^USRPS24
BEGIN ; Create DDEFS
+1 WRITE !!,"This option creates Document Definitions, a User Class, and"
+2 WRITE !,"a Business Rule for Patient Record Flags."
+3 WRITE !
KILL IOP
SET %ZIS="Q"
DO ^%ZIS
IF POP
KILL POP
QUIT
+4 IF $DATA(IO("Q"))
KILL IO("Q")
Begin DoDot:1
+5 SET ZTRTN="MAIN^TIUPS165"
+6 SET ZTDESC="Create DDefs, User Class, Rules for Patient Record Flags - TIU*1*165"
+7 DO ^%ZTLOAD
WRITE !,$SELECT($DATA(ZTSK):"Request Queued!",1:"Request Canceled!")
+8 KILL ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+9 DO HOME^%ZIS
End DoDot:1
QUIT
+10 USE IO
DO MAIN
DO ^%ZISC
+11 QUIT
+12 ;
MAIN ; Create DDEFS for Patient Record Flags
+1 ; -- Check for dups created after the install but before this option:
+2 KILL ^XTMP("TIU165","DUPS"),^TMP("TIU165",$JOB)
+3 DO SETXTMP^TIUEN165
+4 NEW TIUDUPS,TMPCNT,SILENT
SET TMPCNT=0
+5 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU165",$JOB,TMPCNT)=""
+6 SET TMPCNT=1
SET ^TMP("TIU165",$JOB,TMPCNT)=" ***** Document Definitions for PATIENT RECORD FLAGS *****"
+7 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU165",$JOB,TMPCNT)=""
+8 SET SILENT=1
+9 DO TIUDUPS^TIUEN165(.TIUDUPS,SILENT)
+10 ; -- If potential duplicates exist, quit:
+11 IF $GET(TIUDUPS)
Begin DoDot:1
+12 SET ^XTMP("TIU165","DUPS")=1
+13 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU165",$JOB,TMPCNT)="Duplicate problem. See description for patch TIU*1*165,"
+14 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU165",$JOB,TMPCNT)="in the National Patch Module."
End DoDot:1
GOTO MAINX
+15 ; -- Set file data, other data for DDEFS:
+16 DO SETDATA^TIU165D
+17 NEW NUM
SET NUM=0
+18 FOR
SET NUM=$ORDER(^XTMP("TIU165","BASICS",NUM))
if 'NUM
QUIT
Begin DoDot:1
+19 NEW IEN,YDDEF,TIUDA
+20 ; -- If DDEF was previously created by this patch,
+21 ; say so and quit:
+22 SET IEN=+$GET(^XTMP("TIU165","BASICS",NUM,"DONE"))
+23 IF IEN
Begin DoDot:2
+24 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU165",$JOB,TMPCNT)=^XTMP("TIU165","FILEDATA",NUM,.04)_" "_^XTMP("TIU165","BASICS",NUM,"NAME")
+25 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU165",$JOB,TMPCNT)=" was already created in a previous install."
+26 KILL ^XTMP("TIU165","FILEDATA",NUM)
+27 KILL ^XTMP("TIU165","DATA",NUM)
End DoDot:2
QUIT
+28 ; -- If not, create new DDEF:
+29 SET YDDEF=$$CREATE(NUM)
+30 IF +YDDEF'>0!($PIECE(YDDEF,U,3)'=1)
Begin DoDot:2
+31 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU165",$JOB,TMPCNT)="Couldn't create a "_^XTMP("TIU165","FILEDATA",NUM,.04)_" named "_^XTMP("TIU165","BASICS",NUM,"NAME")_"."
SET TMPCNT=TMPCNT+1
+32 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU165",$JOB,TMPCNT)=" Please contact National VistA Support for help."
End DoDot:2
QUIT
+33 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU165",$JOB,TMPCNT)=^XTMP("TIU165","FILEDATA",NUM,.04)_" named "_^XTMP("TIU165","BASICS",NUM,"NAME")
+34 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU165",$JOB,TMPCNT)=" created successfully."
+35 SET TIUDA=+YDDEF
+36 ; -- File field data:
+37 DO FILE(NUM,TIUDA,.TMPCNT)
+38 KILL ^XTMP("TIU165","FILEDATA",NUM)
+39 ; -- Add item to parent:
+40 DO ADDITEM(NUM,TIUDA,.TMPCNT)
+41 KILL ^XTMP("TIU165","DATA",NUM)
End DoDot:1
MAINX ;Exit
+1 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU165",$JOB,TMPCNT)=""
+2 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU165",$JOB,TMPCNT)=" *************"
+3 IF '$GET(^XTMP("TIU165","DUPS"))
DO MAIN^USRPS24
+4 DO PRINT
+5 KILL ^TMP("TIU165",$JOB),^TMP("USR24",$JOB)
+6 QUIT
+7 ;
PRINT ; Print out results
+1 NEW TIUCNT,TIUCONT
+2 ; Tell TaskMan to delete Task log entry
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 IF $EXTRACT(IOST)="C"
WRITE @IOF,!
+4 SET TIUCNT=""
SET TIUCONT=1
+5 FOR
SET TIUCNT=$ORDER(^TMP("TIU165",$JOB,TIUCNT))
if TIUCNT=""
QUIT
Begin DoDot:1
+6 SET TIUCONT=$$SETCONT
if 'TIUCONT
QUIT
+7 WRITE ^TMP("TIU165",$JOB,TIUCNT),!
End DoDot:1
if 'TIUCONT
QUIT
+8 if 'TIUCONT
QUIT
+9 SET TIUCNT=""
+10 FOR
SET TIUCNT=$ORDER(^TMP("USR24",$JOB,TIUCNT))
if TIUCNT=""
QUIT
Begin DoDot:1
+11 SET TIUCONT=$$SETCONT
if 'TIUCONT
QUIT
+12 WRITE ^TMP("USR24",$JOB,TIUCNT),!
End DoDot:1
if 'TIUCONT
QUIT
PRINTX QUIT
+1 ;
STOP() ;on screen paging check
+1 ; quits TIUCONT=1 if cont. ELSE quits TIUCONT=0
+2 NEW DIR,Y,TIUCONT
+3 SET DIR(0)="E"
DO ^DIR
+4 SET TIUCONT=Y
+5 IF TIUCONT
WRITE @IOF,!
+6 QUIT TIUCONT
+7 ;
SETCONT() ; D form feed, Set TIUCONT
+1 NEW TIUCONT
+2 SET TIUCONT=1
+3 IF $EXTRACT(IOST)="C"
if $Y+5<IOSL
GOTO SETX
+4 IF $EXTRACT(IOST)="C"
SET TIUCONT=$$STOP
GOTO SETX
+5 if $Y+8<IOSL
GOTO SETX
+6 WRITE @IOF
SETX QUIT TIUCONT
+1 ;
PARENT(NUM) ; Return IEN of parent new DDEF should be added to
+1 NEW PIEN,PNUM
+2 ; Parent node has form:
+3 ; -- PIEN node = IEN of parent if known, or if not,
+4 ; PNUM node = DDEF# of parent
+5 SET PIEN=$GET(^XTMP("TIU165","DATA",NUM,"PIEN"))
+6 ; -- If parent IEN is known, we're done:
+7 IF +PIEN
GOTO PARENTX
+8 ; -- If not, get DDEF# of parent
+9 SET PNUM=$GET(^XTMP("TIU165","DATA",NUM,"PNUM"))
+10 IF 'PNUM
QUIT 0
+11 ; -- Get Parent IEN from "DONE" node, which was set
+12 ; when parent was created:
+13 SET PIEN=+$GET(^XTMP("TIU165","BASICS",PNUM,"DONE"))
PARENTX QUIT PIEN
+1 ;
ADDITEM(NUM,TIUDA,TMPCNT) ; Add DDEF to Parent; Set item fields
+1 NEW PIEN,MENUTXT,TIUFPRIV,TIUFISCR
+2 NEW DIE,DR
+3 SET TIUFPRIV=1
+4 SET PIEN=$$PARENT(NUM)
+5 IF 'PIEN!'$DATA(^TIU(8925.1,PIEN,0))!'$DATA(^TIU(8925.1,TIUDA,0))
KILL PIEN
GOTO ADDX
+6 NEW DA,DIC,DLAYGO,X,Y
+7 NEW I,DIY
+8 SET DA(1)=PIEN
+9 SET DIC="^TIU(8925.1,"_DA(1)_",10,"
SET DIC(0)="LX"
+10 SET DLAYGO=8925.14
+11 ;S X="`"_TIUDA
+12 ; -- If TIUDA is say, x, and Parent has x as IFN in Item subfile,
+13 ; code finds item x under parent instead of creating a new item,
+14 ; so don't use "`"_TIUDA:
+15 SET X=^XTMP("TIU165","BASICS",NUM,"NAME")
+16 ; -- Make sure the DDEF it adds is TIUDA and not another w same name:
+17 ; activates screen on fld 10, Subfld .01 in DD
SET TIUFISCR=TIUDA
+18 DO ^DIC
IF Y'>0!($PIECE(Y,U,3)'=1)
KILL PIEN
GOTO ADDX
+19 ; -- Set Menu Text:
+20 SET MENUTXT=$GET(^XTMP("TIU165","DATA",NUM,"MENUTXT"))
+21 IF $LENGTH(MENUTXT)
Begin DoDot:1
+22 NEW DA,DIE,DR
+23 NEW D,D0,DI,DQ
+24 SET DA(1)=PIEN
+25 SET DA=+Y
SET DIE=DIC
+26 SET DR="4////^S X=MENUTXT"
+27 DO ^DIE
End DoDot:1
ADDX ; -- Tell user about adding to parent:
+1 IF '$GET(PIEN)
Begin DoDot:1
+2 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU165",$JOB,TMPCNT)=" Couldn't add entry to parent. Please contact National VistA Support"
+3 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU165",$JOB,TMPCNT)=" for help."
End DoDot:1
+4 IF '$TEST
SET TMPCNT=TMPCNT+1
SET ^TMP("TIU165",$JOB,TMPCNT)=" Entry added to parent."
+5 QUIT
+6 ;
FILE(NUM,TIUDA,TMPCNT) ; File fields for new entry TIUDA
+1 ; Files ALL FIELDS set in "FILEDATA" nodes of ^XTMP:
+2 ; ^XTMP("TIU165","FILEDATA",NUM,Field#)
+3 NEW TIUFPRIV,FDA,TIUERR
+4 SET TIUFPRIV=1
+5 MERGE FDA(8925.1,TIUDA_",")=^XTMP("TIU165","FILEDATA",NUM)
+6 DO FILE^DIE("TE","FDA","TIUERR")
+7 IF $DATA(TIUERR)
SET TMPCNT=TMPCNT+1
SET ^TMP("TIU165",$JOB,TMPCNT)=" Problem filing data for entry. Please contact National VistA Support."
+8 IF '$TEST
SET TMPCNT=TMPCNT+1
SET ^TMP("TIU165",$JOB,TMPCNT)=" Data for entry filed successfully."
+9 QUIT
+10 ;
CREATE(NUM) ; Create new DDEF entry
+1 NEW DIC,DLAYGO,DA,X,Y,TIUFPRIV
+2 SET TIUFPRIV=1
+3 ;S (DIC,DLAYGO)="^TIU(8925.1,"
+4 ;CACHE won't take global root for DLAYGO; use file number:
+5 SET DIC="^TIU(8925.1,"
SET DLAYGO=8925.1
+6 SET DIC(0)="LX"
SET X=^XTMP("TIU165","BASICS",NUM,"NAME")
+7 SET DIC("S")="I $P(^(0),U,4)="_""""_^XTMP("TIU165","BASICS",NUM,"INTTYPE")_""""
+8 DO ^DIC
+9 ; -- If DDEF was just created, set "DONE" node = IEN
+10 IF $PIECE(Y,U,3)=1
SET ^XTMP("TIU165","BASICS",NUM,"DONE")=+$GET(Y)
+11 QUIT $GET(Y)
