TIU182DF ; SLC/MAM - Create new HP DDEFS ; 7/22/04
;;1.0;Text Integration Utilities;**182**;Jun 20, 1997
; Run this after installing patch 182.
;Use option: TIU182 DDEFS, MED CONVERSION
; External References
; DBIA 3409 ^USR(8930,"B"
BEGIN ; Create DDEFS
W !!,"This option creates Historical Procedure Document Definitions (DDEFS) for",!,"the Medicine Package conversion."
W !,"It may take one or two minutes to run. It will tell you whether or not",!,"it is successful."
W ! K IOP N %ZIS S %ZIS="Q" D ^%ZIS I POP K POP Q
I $D(IO("Q")) K IO("Q") D Q
.S ZTRTN="MAIN^TIUPS182"
.S ZTDESC="Create DDEFS for Medicine Conversion - TIU*1*182"
.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 Historical Procedure DDEFS for Medicine Conversion
N TIUDUPS,TMPCNT,TIUSTTS
; -- Set ^XTMP deletion date for about 2 years hence:
; Set it even if all are already created, in case it's in test
; for more than 2 years, so sites can reset it by running option.
S ^XTMP("TIU182",0)=$$FMADD^XLFDT(DT,730)_U_DT_U_"Tracks DDEFS created by Option TIU182 DDEFS, MED CONVERSION"
K ^TMP("TIU182MSG",$J),^TMP("TIU182ERR",$J),^TMP("TIU182",$J)
; -- Begin message array ^TMP("TIU182MSG",$J:
S TMPCNT=0
S TMPCNT=TMPCNT+1,^TMP("TIU182MSG",$J,TMPCNT)="*** Historical Procedure Document Definitions for the Medicine Conversion ***"
; -- Check if ALL done; check for Class Clinical Coord:
I $G(^XTMP("TIU182","DONE"))="ALL" D G MAINX
. S TMPCNT=TMPCNT+1,^TMP("TIU182MSG",$J,TMPCNT)="All DDEFS exported for the conversion have already been created"
. S TMPCNT=TMPCNT+1,^TMP("TIU182MSG",$J,TMPCNT)="by option TIU182 DDEFS, MED CONVERSION."
N CPCLASS S CPCLASS=$$CLASS^TIUCP I 'CPCLASS D
. S TMPCNT=TMPCNT+1,^TMP("TIU182MSG",$J,TMPCNT)="I can't find Class CLINICAL PROCEDURES, exported in patch TIU*1*109."
. S TMPCNT=TMPCNT+1,^TMP("TIU182MSG",$J,TMPCNT)="Option cannot be run without it."
. S TMPCNT=TMPCNT+1,^TMP("TIU182MSG",$J,TMPCNT)=""
I $O(^USR(8930,"B","CLINICAL COORDINATOR",""))="" D
. S TMPCNT=TMPCNT+1,^TMP("TIU182MSG",$J,TMPCNT)="I can't find User Class CLINICAL COORDINATOR. Option cannot be run without it."
. S TMPCNT=TMPCNT+1,^TMP("TIU182MSG",$J,TMPCNT)=""
; -- Set basic DDEF data into BASICS node of data array ^TMP("TIU182":
D SETBASIC^TIUEN182
; -- Check for potential DDEF duplicates at site:
D TIUDUPS^TIUEN182(.TIUDUPS,1)
; -- If potential duplicates exist, add them to message array:
I TIUDUPS D LISTDUPS^TIUEN182(.TIUDUPS,.TMPCNT,1) G MAINX
I $O(^USR(8930,"B","CLINICAL COORDINATOR",""))="" G MAINX
I 'CPCLASS G MAINX
; -- If no potential dups, User Class exists, CLINICAL PROCEDURES
; Class exists, go on:
S TMPCNT=TMPCNT+1,^TMP("TIU182MSG",$J,TMPCNT)="Environment looks OK."
; -- Check if some DDEFS done:
I $G(^XTMP("TIU182","DONE"))="SOME" D
. S TMPCNT=TMPCNT+1,^TMP("TIU182MSG",$J,TMPCNT)="Some of the DDEFS exported for the conversion have already been"
. S TMPCNT=TMPCNT+1,^TMP("TIU182MSG",$J,TMPCNT)="created by this option. I will now create the others..."
; -- If none created yet:
I '$D(^XTMP("TIU182","DONE")) D
. S TMPCNT=TMPCNT+1,^TMP("TIU182MSG",$J,TMPCNT)="Creating the Document Definitions..."
; -- Set flds for FILE call & item data into nodes FILEDATA & DATA
; of array ^TMP("TIU182":
D SETDATA^TIU182D
; -- Loop through DDEFS to create them:
N NUM
F NUM=1:1:13 D
. N TIUIEN,YDDEF,TIUDA,PIEN,ITEMDA
. ; -- If DDEF was previously created by this option,
. ; quit and get next DDEF:
. S TIUIEN=+$G(^XTMP("TIU182",NUM,"DONE")) Q:TIUIEN
. ; -- If not, create new DDEF:
. S YDDEF=$$CREATE^TIU182D1(NUM)
. ; -- If DDEF couldn't be created or was found by lookup
. ; instead of being created, quit and get next DDEF:
. I $G(^TMP("TIU182ERR",$J,NUM))="CREATE" Q
. S TIUDA=+YDDEF
. ; -- Call FILE to stuff fields from ^TMP("TIU182",$J,"FILEDATA",NUM:
. D FILE^TIU182D1(NUM,TIUDA)
. I $G(^TMP("TIU182ERR",$J,NUM))="FILE" D DELETE^TIU182D1(TIUDA) Q
. ; -- Add item to parent, stuff item data:
. S PIEN=$$PARENT^TIU182D1(NUM)
. I $G(^TMP("TIU182ERR",$J,NUM))="FINDPARENT" D DELETE^TIU182D1(TIUDA) Q
. S ITEMDA=+$$ADDITEM^TIU182D1(NUM,TIUDA,PIEN)
. I $G(^TMP("TIU182ERR",$J,NUM))="ADDITEM" D DELETE^TIU182D1(TIUDA) Q
. D FILEITEM^TIU182D1(NUM,PIEN,ITEMDA)
. I $G(^TMP("TIU182ERR",$J,NUM))="FILEITEM" D DELETE^TIU182D1(TIUDA,PIEN,ITEMDA) Q
. ; -- DDEF NUM has been created and edited successfully:
. S ^XTMP("TIU182",NUM,"DONE")=TIUDA
. S ^XTMP("TIU182","DONE")="SOME"
. Q
; -- Add results from CREATE loop to message array:
N NUM S NUM=0
I $O(^TMP("TIU182ERR",$J,NUM))="" D G MAINX
. S TMPCNT=TMPCNT+1,^TMP("TIU182MSG",$J,TMPCNT)="All Document Definitions have now been created successfully."
. S ^XTMP("TIU182","DONE")="ALL"
. ; -- Kill indiv DONE nodes:
. N NUMBER F NUMBER=1:1:13 K ^XTMP("TIU182",NUMBER)
. ; -- Edit Print Form Header,delete PF Number of Class CP:
. N FDA,TIUFPRIV S FDA(8925.1,CPCLASS_",",6.1)="CLINICAL PROCEDURES"
. S FDA(8925.1,CPCLASS_",",6.12)="@"
. S TIUFPRIV=1
. D FILE^DIE("TE","FDA")
. Q:'$D(^TMP("DIERR",$J))
. S TMPCNT=TMPCNT+1,^TMP("TIU182MSG",$J,TMPCNT)="Couldn't update CP Print Fields. See patch description or contact EVS."
S TMPCNT=TMPCNT+1,^TMP("TIU182MSG",$J,TMPCNT)=""
S TMPCNT=TMPCNT+1,^TMP("TIU182MSG",$J,TMPCNT)="Problems were encountered creating the following Document Definitions:"
F S NUM=$O(^TMP("TIU182ERR",$J,NUM)) Q:NUM="" D
. N PROB S PROB=^TMP("TIU182ERR",$J,NUM)
. D
. . I PROB="CREATE" S PROB="Couldn't create DDEF." Q
. . I PROB="FILE" S PROB="Couldn't file fields. DDEF deleted." Q
. . I PROB="FINDPARENT" S PROB="Couldn't find parent. DDEF deleted." Q
. . I PROB="ADDITEM" S PROB="Couldn't add DDEF to parent. DDEF deleted."
. . I PROB="FILEITEM" S PROB="Couldn't file Menu Text. DDEF deleted."
. S TMPCNT=TMPCNT+1,^TMP("TIU182MSG",$J,TMPCNT)=$S(NUM=1:"Document Class ",1:"Title ")_^TMP("TIU182",$J,"BASICS",NUM,"NAME")_": "
. S TMPCNT=TMPCNT+1,^TMP("TIU182MSG",$J,TMPCNT)=" "_PROB
S TMPCNT=TMPCNT+1,^TMP("TIU182MSG",$J,TMPCNT)=""
S TMPCNT=TMPCNT+1,^TMP("TIU182MSG",$J,TMPCNT)="Please contact Enterprise VistA Support. When problems have been resolved,"
S TMPCNT=TMPCNT+1,^TMP("TIU182MSG",$J,TMPCNT)="come back and rerun the option."
MAINX ; Exit
; -- Leave latest error arrays ^TMP("DIERR",$J) & TIUIERR around until
; now in case modules are run separately for debugging:
K TIUIERR,^TMP("DIERR",$J)
; -- Finish message array ^TMP("TIU182MSG",$J and print it:
S TMPCNT=TMPCNT+1,^TMP("TIU182MSG",$J,TMPCNT)=""
S TMPCNT=TMPCNT+1,^TMP("TIU182MSG",$J,TMPCNT)=" *************"
D PRINT^TIU182D
K ^TMP("TIU182MSG",$J),^TMP("TIU182ERR",$J),^TMP("TIU182",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIU182DF 6926 printed Sep 23, 2025@20:14:40 Page 2
TIU182DF ; SLC/MAM - Create new HP DDEFS ; 7/22/04
+1 ;;1.0;Text Integration Utilities;**182**;Jun 20, 1997
+2 ; Run this after installing patch 182.
+3 ;Use option: TIU182 DDEFS, MED CONVERSION
+4 ; External References
+5 ; DBIA 3409 ^USR(8930,"B"
BEGIN ; Create DDEFS
+1 WRITE !!,"This option creates Historical Procedure Document Definitions (DDEFS) for",!,"the Medicine Package conversion."
+2 WRITE !,"It may take one or two minutes to run. It will tell you whether or not",!,"it is successful."
+3 WRITE !
KILL IOP
NEW %ZIS
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^TIUPS182"
+6 SET ZTDESC="Create DDEFS for Medicine Conversion - TIU*1*182"
+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 Historical Procedure DDEFS for Medicine Conversion
+1 NEW TIUDUPS,TMPCNT,TIUSTTS
+2 ; -- Set ^XTMP deletion date for about 2 years hence:
+3 ; Set it even if all are already created, in case it's in test
+4 ; for more than 2 years, so sites can reset it by running option.
+5 SET ^XTMP("TIU182",0)=$$FMADD^XLFDT(DT,730)_U_DT_U_"Tracks DDEFS created by Option TIU182 DDEFS, MED CONVERSION"
+6 KILL ^TMP("TIU182MSG",$JOB),^TMP("TIU182ERR",$JOB),^TMP("TIU182",$JOB)
+7 ; -- Begin message array ^TMP("TIU182MSG",$J:
+8 SET TMPCNT=0
+9 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU182MSG",$JOB,TMPCNT)="*** Historical Procedure Document Definitions for the Medicine Conversion ***"
+10 ; -- Check if ALL done; check for Class Clinical Coord:
+11 IF $GET(^XTMP("TIU182","DONE"))="ALL"
Begin DoDot:1
+12 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU182MSG",$JOB,TMPCNT)="All DDEFS exported for the conversion have already been created"
+13 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU182MSG",$JOB,TMPCNT)="by option TIU182 DDEFS, MED CONVERSION."
End DoDot:1
GOTO MAINX
+14 NEW CPCLASS
SET CPCLASS=$$CLASS^TIUCP
IF 'CPCLASS
Begin DoDot:1
+15 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU182MSG",$JOB,TMPCNT)="I can't find Class CLINICAL PROCEDURES, exported in patch TIU*1*109."
+16 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU182MSG",$JOB,TMPCNT)="Option cannot be run without it."
+17 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU182MSG",$JOB,TMPCNT)=""
End DoDot:1
+18 IF $ORDER(^USR(8930,"B","CLINICAL COORDINATOR",""))=""
Begin DoDot:1
+19 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU182MSG",$JOB,TMPCNT)="I can't find User Class CLINICAL COORDINATOR. Option cannot be run without it."
+20 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU182MSG",$JOB,TMPCNT)=""
End DoDot:1
+21 ; -- Set basic DDEF data into BASICS node of data array ^TMP("TIU182":
+22 DO SETBASIC^TIUEN182
+23 ; -- Check for potential DDEF duplicates at site:
+24 DO TIUDUPS^TIUEN182(.TIUDUPS,1)
+25 ; -- If potential duplicates exist, add them to message array:
+26 IF TIUDUPS
DO LISTDUPS^TIUEN182(.TIUDUPS,.TMPCNT,1)
GOTO MAINX
+27 IF $ORDER(^USR(8930,"B","CLINICAL COORDINATOR",""))=""
GOTO MAINX
+28 IF 'CPCLASS
GOTO MAINX
+29 ; -- If no potential dups, User Class exists, CLINICAL PROCEDURES
+30 ; Class exists, go on:
+31 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU182MSG",$JOB,TMPCNT)="Environment looks OK."
+32 ; -- Check if some DDEFS done:
+33 IF $GET(^XTMP("TIU182","DONE"))="SOME"
Begin DoDot:1
+34 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU182MSG",$JOB,TMPCNT)="Some of the DDEFS exported for the conversion have already been"
+35 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU182MSG",$JOB,TMPCNT)="created by this option. I will now create the others..."
End DoDot:1
+36 ; -- If none created yet:
+37 IF '$DATA(^XTMP("TIU182","DONE"))
Begin DoDot:1
+38 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU182MSG",$JOB,TMPCNT)="Creating the Document Definitions..."
End DoDot:1
+39 ; -- Set flds for FILE call & item data into nodes FILEDATA & DATA
+40 ; of array ^TMP("TIU182":
+41 DO SETDATA^TIU182D
+42 ; -- Loop through DDEFS to create them:
+43 NEW NUM
+44 FOR NUM=1:1:13
Begin DoDot:1
+45 NEW TIUIEN,YDDEF,TIUDA,PIEN,ITEMDA
+46 ; -- If DDEF was previously created by this option,
+47 ; quit and get next DDEF:
+48 SET TIUIEN=+$GET(^XTMP("TIU182",NUM,"DONE"))
if TIUIEN
QUIT
+49 ; -- If not, create new DDEF:
+50 SET YDDEF=$$CREATE^TIU182D1(NUM)
+51 ; -- If DDEF couldn't be created or was found by lookup
+52 ; instead of being created, quit and get next DDEF:
+53 IF $GET(^TMP("TIU182ERR",$JOB,NUM))="CREATE"
QUIT
+54 SET TIUDA=+YDDEF
+55 ; -- Call FILE to stuff fields from ^TMP("TIU182",$J,"FILEDATA",NUM:
+56 DO FILE^TIU182D1(NUM,TIUDA)
+57 IF $GET(^TMP("TIU182ERR",$JOB,NUM))="FILE"
DO DELETE^TIU182D1(TIUDA)
QUIT
+58 ; -- Add item to parent, stuff item data:
+59 SET PIEN=$$PARENT^TIU182D1(NUM)
+60 IF $GET(^TMP("TIU182ERR",$JOB,NUM))="FINDPARENT"
DO DELETE^TIU182D1(TIUDA)
QUIT
+61 SET ITEMDA=+$$ADDITEM^TIU182D1(NUM,TIUDA,PIEN)
+62 IF $GET(^TMP("TIU182ERR",$JOB,NUM))="ADDITEM"
DO DELETE^TIU182D1(TIUDA)
QUIT
+63 DO FILEITEM^TIU182D1(NUM,PIEN,ITEMDA)
+64 IF $GET(^TMP("TIU182ERR",$JOB,NUM))="FILEITEM"
DO DELETE^TIU182D1(TIUDA,PIEN,ITEMDA)
QUIT
+65 ; -- DDEF NUM has been created and edited successfully:
+66 SET ^XTMP("TIU182",NUM,"DONE")=TIUDA
+67 SET ^XTMP("TIU182","DONE")="SOME"
+68 QUIT
End DoDot:1
+69 ; -- Add results from CREATE loop to message array:
+70 NEW NUM
SET NUM=0
+71 IF $ORDER(^TMP("TIU182ERR",$JOB,NUM))=""
Begin DoDot:1
+72 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU182MSG",$JOB,TMPCNT)="All Document Definitions have now been created successfully."
+73 SET ^XTMP("TIU182","DONE")="ALL"
+74 ; -- Kill indiv DONE nodes:
+75 NEW NUMBER
FOR NUMBER=1:1:13
KILL ^XTMP("TIU182",NUMBER)
+76 ; -- Edit Print Form Header,delete PF Number of Class CP:
+77 NEW FDA,TIUFPRIV
SET FDA(8925.1,CPCLASS_",",6.1)="CLINICAL PROCEDURES"
+78 SET FDA(8925.1,CPCLASS_",",6.12)="@"
+79 SET TIUFPRIV=1
+80 DO FILE^DIE("TE","FDA")
+81 if '$DATA(^TMP("DIERR",$JOB))
QUIT
+82 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU182MSG",$JOB,TMPCNT)="Couldn't update CP Print Fields. See patch description or contact EVS."
End DoDot:1
GOTO MAINX
+83 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU182MSG",$JOB,TMPCNT)=""
+84 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU182MSG",$JOB,TMPCNT)="Problems were encountered creating the following Document Definitions:"
+85 FOR
SET NUM=$ORDER(^TMP("TIU182ERR",$JOB,NUM))
if NUM=""
QUIT
Begin DoDot:1
+86 NEW PROB
SET PROB=^TMP("TIU182ERR",$JOB,NUM)
+87 Begin DoDot:2
+88 IF PROB="CREATE"
SET PROB="Couldn't create DDEF."
QUIT
+89 IF PROB="FILE"
SET PROB="Couldn't file fields. DDEF deleted."
QUIT
+90 IF PROB="FINDPARENT"
SET PROB="Couldn't find parent. DDEF deleted."
QUIT
+91 IF PROB="ADDITEM"
SET PROB="Couldn't add DDEF to parent. DDEF deleted."
+92 IF PROB="FILEITEM"
SET PROB="Couldn't file Menu Text. DDEF deleted."
End DoDot:2
+93 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU182MSG",$JOB,TMPCNT)=$SELECT(NUM=1:"Document Class ",1:"Title ")_^TMP("TIU182",$JOB,"BASICS",NUM,"NAME")_": "
+94 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU182MSG",$JOB,TMPCNT)=" "_PROB
End DoDot:1
+95 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU182MSG",$JOB,TMPCNT)=""
+96 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU182MSG",$JOB,TMPCNT)="Please contact Enterprise VistA Support. When problems have been resolved,"
+97 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU182MSG",$JOB,TMPCNT)="come back and rerun the option."
MAINX ; Exit
+1 ; -- Leave latest error arrays ^TMP("DIERR",$J) & TIUIERR around until
+2 ; now in case modules are run separately for debugging:
+3 KILL TIUIERR,^TMP("DIERR",$JOB)
+4 ; -- Finish message array ^TMP("TIU182MSG",$J and print it:
+5 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU182MSG",$JOB,TMPCNT)=""
+6 SET TMPCNT=TMPCNT+1
SET ^TMP("TIU182MSG",$JOB,TMPCNT)=" *************"
+7 DO PRINT^TIU182D
+8 KILL ^TMP("TIU182MSG",$JOB),^TMP("TIU182ERR",$JOB),^TMP("TIU182",$JOB)
+9 QUIT
