TIUEN169 ; SLC/MAM - Environment Check Rtn for TIU*1*169 ; 7/28/2004
;;1.0;Text Integration Utilities;**169**;Jun 20, 1997
; External References
; DBIA 3409 ^USR(8930,"B"
MAIN ; Check environment. If problems found, warn but do not abort install.
; -- Check if done:
I $G(^XTMP("TIU169","DONE"))="ALL" W !,"All Document Definitions for C&P Worksheets have already been",!," created. You won't need to rerun the option." Q
I $O(^USR(8930,"B","CLINICAL COORDINATOR",""))="" W !,"I can't find User Class CLINICAL COORDINATOR. You won't be able to run",!,"the option that creates the Document Definitions without this class. See",!,"patch description.",!
W !,"Remember to run option TIU169 DDEFS, C&P WORKSHEETS",!,"after installing the patch."
Q
;
SETBASIC ; Set up basic data in ^TMP("TIU169",$J,"BASICS")
N NUMBER
; -- Set ^TMP("TIU169",$J,"BASICS",[NUMBER],["INTTYPE" or "NAME"])
; -- Set basic data NAME and interior TYPE for new DDEFS into TMP.
; Reference DDEFS by NUMBER.
; Number parent-to-be BEFORE child.
; Name MUST be upper case or ADDITEM fails
S ^TMP("TIU169",$J,"BASICS",1,"INTTYPE")="DC"
F NUMBER=2:1:58 S ^TMP("TIU169",$J,"BASICS",NUMBER,"INTTYPE")="DOC"
F NUMBER=1:1:58 S ^TMP("TIU169",$J,"BASICS",NUMBER,"NAME")=$P($T(NAME+NUMBER),";;",2,99)
Q
;
TIUDUPS(TIUDUPS,TIUDCDA) ; Set array TIUDUPS of potential duplicate DDEFS
; TIUDCDA = IEN of designated DC or 0 if none desig.
; Checks for Titles;
; If no DC designated, checks for DC too.
N NUM
S (TIUDUPS("INDC"),TIUDUPS("NOTINDC"))=0
I $G(^XTMP("TIU169","DONE"))="ALL" Q
F NUM=1:1:58 Q:'NUM D
. ; -- When looking for duplicates, ignore DDEF if
. ; previously created, designated,or skipped by this patch:
. I $G(^XTMP("TIU169",NUM,"DONE")) Q
. ; -- If site already has DDEF w/ same Name & Type as one
. ; we are exporting, set its number into array TIUDUPS:
. N NAME,TYPE,TIUDA S TIUDA=0
. S NAME=^TMP("TIU169",$J,"BASICS",NUM,"NAME")
. S TYPE=^TMP("TIU169",$J,"BASICS",NUM,"INTTYPE")
. F S TIUDA=$O(^TIU(8925.1,"B",NAME,TIUDA)) Q:+TIUDA'>0 D
. . Q:$P($G(^TIU(8925.1,+TIUDA,0)),U,4)'=TYPE
. . I $$ISA^TIULX(+TIUDA,TIUDCDA) S TIUDUPS("INDC",NUM)=+TIUDA,TIUDUPS("INDC")=TIUDUPS("INDC")+1 I 1
. . E I TIUDA'=+DESDC S TIUDUPS("NOTINDC",NUM)=+TIUDA,TIUDUPS("NOTINDC")=TIUDUPS("NOTINDC")+1
Q
;
LISTDUPS(TIUDUPS,INDCFLG) ; List duplicates by name
; TIUDUPS = array as set in TIUDUPS. Required.
; INDCFLG = 1: List dups in designated DC for skipping over
; INDCFLG '= 1: List dups not in designated DC - Quit
N NUM,SUBSCPT,TIUCNT
I '$G(INDCFLG),$G(TIUDUPS("NOTINDC",1)) D Q
. W !!,"You already have the Document Class exported by this patch, C&P EXAMINATION"
. W !,"REPORTS. Please designate it or change its name (and print name)."
I '$G(INDCFLG),$G(TIUDUPS("NOTINDC")) D
. S SUBSCPT="NOTINDC"
. W !!,"You already have the following DDEFS exported by this patch. I cannot create"
. W !,"duplicates. Please change their names so they no longer match exported DDEFS,"
. W !,"or if you are not using them, delete them. If you change the name of a DDEF"
. W !,"you plan to continue using, remember to update its Print Name as well."
. W !,"For help, contact Enterprise VistA Support."
. W !!,"You may not run this option until these matches are eliminated."
I $G(INDCFLG),$G(TIUDUPS("INDC")) D
. S SUBSCPT="INDC"
. W !!,"Your designated C&P Document Class already has matching Titles:"
Q:'$D(SUBSCPT)
S NUM=0
F TIUCNT=1:1:10 S NUM=$O(TIUDUPS(SUBSCPT,NUM)) Q:'NUM D
. W !," "_^TMP("TIU169",$J,"BASICS",NUM,"NAME")
I TIUDUPS(SUBSCPT)>8 W !,"... and more; ",TIUDUPS(SUBSCPT)," in all."
Q
;
DESGNATE() ; Get Designated DC to create C&P titles under
; Returns:
; -1 - timeout, ^, lookup failed
; 0 - none designated; create new DC
; DCIFN^DCNAME in 8925.1 - designated DC
N TIUY,DTOUT,DUOUT,DIRUT,DIROUT
W !,"I can create a new C&P Document Class or you can designate an existing one."
W !,"If you designate an existing one, I will change its name to C&P EXAMINATION REPORTS. I will create the new C&P Titles under it, skipping any you already have."
S TIUY=$$READ^TIUU("YO","Do you want to designate a Document Class","YES")
I $D(DIRUT) Q -1
I +TIUY'=1 Q 0
N Y,DIC,DTOUT,DUOUT
S DIC=8925.1,DIC(0)="ABEFQ",DIC("S")="I $P(^(0),U,4)=""DC"",$D(^TIU(8925.1,3,10,""B"",Y))"
D ^DIC
Q Y
;
NAME ; Names of DDEFS in order from 1 to 58
;;C&P EXAMINATION REPORTS
;;C&P EXAMINATION
;;C&P MULTIPLE EXAM
;;C&P ACROMEGALY
;;C&P AID AND ATTENDANCE OR HOUSEBOUND EXAM
;;C&P ARRHYTHMIAS
;;C&P ARTERIES, VEINS AND MISC
;;C&P AUDIO
;;C&P BONES
;;C&P BRAIN AND SPINAL CORD
;;C&P CHRONIC FATIGUE SYNDROME
;;C&P COLD INJURY PROTOCOL
;;C&P CRANIAL NERVES
;;C&P CUSHING'S SYNDROME
;;C&P DENTAL AND ORAL
;;C&P DIABETES MELLITUS
;;C&P DIGESTIVE CONDITIONS
;;C&P EAR DISEASE
;;C&P EATING DISORDERS
;;C&P ENDOCRINE DISEASES
;;C&P EPILEPSY AND NARCOLEPSY
;;C&P ESOPHAGUS AND HIATAL HERNIA
;;C&P EYE
;;C&P FEET
;;C&P FIBROMYALGIA
;;C&P GENERAL MEDICAL
;;C&P GENITOURINARY
;;C&P GULF WAR PROTOCOL
;;C&P GYNECOLOGICAL CONDITIONS AND DISORDERS OF THE BREAST
;;C&P HAND, THUMB AND FINGERS
;;C&P HEART
;;C&P HEMIC DISORDERS
;;C&P HIV-RELATED ILLNESS
;;C&P HYPERTENSION
;;C&P INFECTIOUS, IMMUNE AND NUTRITIONAL DISABILITIES
;;C&P INTESTINES
;;C&P JOINTS (SHOULDER, ELBOW, WRIST, HIP, KNEE, ANKLE)
;;C&P LIVER, GALL BLADDER, AND PANCREAS
;;C&P LYMPHATIC DISORDERS
;;C&P MENTAL DISORDERS
;;C&P MOUTH, LIPS, AND TONGUE
;;C&P MUSCLES
;;C&P NEUROLOGICAL DISORDERS
;;C&P NOSE, SINUS, LARYNX, AND PHARYNX
;;C&P PERIPHERAL NERVES
;;C&P PRISONER OF WAR PROTOCOL
;;C&P PTSD, INITIAL EVALUATION
;;C&P PTSD, REVIEW
;;C&P PULMONARY TUBERCULOSIS AND MYCOBACTERIAL DISEASES
;;C&P RECTUM AND ANUS
;;C&P RESIDUALS OF AMPUTATIONS
;;C&P RESPIRATORY
;;C&P SCARS
;;C&P SENSE OF SMELL AND TASTE
;;C&P SKIN DISEASES
;;C&P SPINE
;;C&P STOMACH, DUODENUM, AND PERITONEAL ADHESIONS
;;C&P THYROID AND PARATHYROID DISEASES
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUEN169 6126 printed Dec 13, 2024@02:40:13 Page 2
TIUEN169 ; SLC/MAM - Environment Check Rtn for TIU*1*169 ; 7/28/2004
+1 ;;1.0;Text Integration Utilities;**169**;Jun 20, 1997
+2 ; External References
+3 ; DBIA 3409 ^USR(8930,"B"
MAIN ; Check environment. If problems found, warn but do not abort install.
+1 ; -- Check if done:
+2 IF $GET(^XTMP("TIU169","DONE"))="ALL"
WRITE !,"All Document Definitions for C&P Worksheets have already been",!," created. You won't need to rerun the option."
QUIT
+3 IF $ORDER(^USR(8930,"B","CLINICAL COORDINATOR",""))=""
WRITE !,"I can't find User Class CLINICAL COORDINATOR. You won't be able to run",!,"the option that creates the Document Definitions without this class. See",!,"patch description.",!
+4 WRITE !,"Remember to run option TIU169 DDEFS, C&P WORKSHEETS",!,"after installing the patch."
+5 QUIT
+6 ;
SETBASIC ; Set up basic data in ^TMP("TIU169",$J,"BASICS")
+1 NEW NUMBER
+2 ; -- Set ^TMP("TIU169",$J,"BASICS",[NUMBER],["INTTYPE" or "NAME"])
+3 ; -- Set basic data NAME and interior TYPE for new DDEFS into TMP.
+4 ; Reference DDEFS by NUMBER.
+5 ; Number parent-to-be BEFORE child.
+6 ; Name MUST be upper case or ADDITEM fails
+7 SET ^TMP("TIU169",$JOB,"BASICS",1,"INTTYPE")="DC"
+8 FOR NUMBER=2:1:58
SET ^TMP("TIU169",$JOB,"BASICS",NUMBER,"INTTYPE")="DOC"
+9 FOR NUMBER=1:1:58
SET ^TMP("TIU169",$JOB,"BASICS",NUMBER,"NAME")=$PIECE($TEXT(NAME+NUMBER),";;",2,99)
+10 QUIT
+11 ;
TIUDUPS(TIUDUPS,TIUDCDA) ; Set array TIUDUPS of potential duplicate DDEFS
+1 ; TIUDCDA = IEN of designated DC or 0 if none desig.
+2 ; Checks for Titles;
+3 ; If no DC designated, checks for DC too.
+4 NEW NUM
+5 SET (TIUDUPS("INDC"),TIUDUPS("NOTINDC"))=0
+6 IF $GET(^XTMP("TIU169","DONE"))="ALL"
QUIT
+7 FOR NUM=1:1:58
if 'NUM
QUIT
Begin DoDot:1
+8 ; -- When looking for duplicates, ignore DDEF if
+9 ; previously created, designated,or skipped by this patch:
+10 IF $GET(^XTMP("TIU169",NUM,"DONE"))
QUIT
+11 ; -- If site already has DDEF w/ same Name & Type as one
+12 ; we are exporting, set its number into array TIUDUPS:
+13 NEW NAME,TYPE,TIUDA
SET TIUDA=0
+14 SET NAME=^TMP("TIU169",$JOB,"BASICS",NUM,"NAME")
+15 SET TYPE=^TMP("TIU169",$JOB,"BASICS",NUM,"INTTYPE")
+16 FOR
SET TIUDA=$ORDER(^TIU(8925.1,"B",NAME,TIUDA))
if +TIUDA'>0
QUIT
Begin DoDot:2
+17 if $PIECE($GET(^TIU(8925.1,+TIUDA,0)),U,4)'=TYPE
QUIT
+18 IF $$ISA^TIULX(+TIUDA,TIUDCDA)
SET TIUDUPS("INDC",NUM)=+TIUDA
SET TIUDUPS("INDC")=TIUDUPS("INDC")+1
IF 1
+19 IF '$TEST
IF TIUDA'=+DESDC
SET TIUDUPS("NOTINDC",NUM)=+TIUDA
SET TIUDUPS("NOTINDC")=TIUDUPS("NOTINDC")+1
End DoDot:2
End DoDot:1
+20 QUIT
+21 ;
LISTDUPS(TIUDUPS,INDCFLG) ; List duplicates by name
+1 ; TIUDUPS = array as set in TIUDUPS. Required.
+2 ; INDCFLG = 1: List dups in designated DC for skipping over
+3 ; INDCFLG '= 1: List dups not in designated DC - Quit
+4 NEW NUM,SUBSCPT,TIUCNT
+5 IF '$GET(INDCFLG)
IF $GET(TIUDUPS("NOTINDC",1))
Begin DoDot:1
+6 WRITE !!,"You already have the Document Class exported by this patch, C&P EXAMINATION"
+7 WRITE !,"REPORTS. Please designate it or change its name (and print name)."
End DoDot:1
QUIT
+8 IF '$GET(INDCFLG)
IF $GET(TIUDUPS("NOTINDC"))
Begin DoDot:1
+9 SET SUBSCPT="NOTINDC"
+10 WRITE !!,"You already have the following DDEFS exported by this patch. I cannot create"
+11 WRITE !,"duplicates. Please change their names so they no longer match exported DDEFS,"
+12 WRITE !,"or if you are not using them, delete them. If you change the name of a DDEF"
+13 WRITE !,"you plan to continue using, remember to update its Print Name as well."
+14 WRITE !,"For help, contact Enterprise VistA Support."
+15 WRITE !!,"You may not run this option until these matches are eliminated."
End DoDot:1
+16 IF $GET(INDCFLG)
IF $GET(TIUDUPS("INDC"))
Begin DoDot:1
+17 SET SUBSCPT="INDC"
+18 WRITE !!,"Your designated C&P Document Class already has matching Titles:"
End DoDot:1
+19 if '$DATA(SUBSCPT)
QUIT
+20 SET NUM=0
+21 FOR TIUCNT=1:1:10
SET NUM=$ORDER(TIUDUPS(SUBSCPT,NUM))
if 'NUM
QUIT
Begin DoDot:1
+22 WRITE !," "_^TMP("TIU169",$JOB,"BASICS",NUM,"NAME")
End DoDot:1
+23 IF TIUDUPS(SUBSCPT)>8
WRITE !,"... and more; ",TIUDUPS(SUBSCPT)," in all."
+24 QUIT
+25 ;
DESGNATE() ; Get Designated DC to create C&P titles under
+1 ; Returns:
+2 ; -1 - timeout, ^, lookup failed
+3 ; 0 - none designated; create new DC
+4 ; DCIFN^DCNAME in 8925.1 - designated DC
+5 NEW TIUY,DTOUT,DUOUT,DIRUT,DIROUT
+6 WRITE !,"I can create a new C&P Document Class or you can designate an existing one."
+7 WRITE !,"If you designate an existing one, I will change its name to C&P EXAMINATION REPORTS. I will create the new C&P Titles under it, skipping any you already have."
+8 SET TIUY=$$READ^TIUU("YO","Do you want to designate a Document Class","YES")
+9 IF $DATA(DIRUT)
QUIT -1
+10 IF +TIUY'=1
QUIT 0
+11 NEW Y,DIC,DTOUT,DUOUT
+12 SET DIC=8925.1
SET DIC(0)="ABEFQ"
SET DIC("S")="I $P(^(0),U,4)=""DC"",$D(^TIU(8925.1,3,10,""B"",Y))"
+13 DO ^DIC
+14 QUIT Y
+15 ;
NAME ; Names of DDEFS in order from 1 to 58
+1 ;;C&P EXAMINATION REPORTS
+2 ;;C&P EXAMINATION
+3 ;;C&P MULTIPLE EXAM
+4 ;;C&P ACROMEGALY
+5 ;;C&P AID AND ATTENDANCE OR HOUSEBOUND EXAM
+6 ;;C&P ARRHYTHMIAS
+7 ;;C&P ARTERIES, VEINS AND MISC
+8 ;;C&P AUDIO
+9 ;;C&P BONES
+10 ;;C&P BRAIN AND SPINAL CORD
+11 ;;C&P CHRONIC FATIGUE SYNDROME
+12 ;;C&P COLD INJURY PROTOCOL
+13 ;;C&P CRANIAL NERVES
+14 ;;C&P CUSHING'S SYNDROME
+15 ;;C&P DENTAL AND ORAL
+16 ;;C&P DIABETES MELLITUS
+17 ;;C&P DIGESTIVE CONDITIONS
+18 ;;C&P EAR DISEASE
+19 ;;C&P EATING DISORDERS
+20 ;;C&P ENDOCRINE DISEASES
+21 ;;C&P EPILEPSY AND NARCOLEPSY
+22 ;;C&P ESOPHAGUS AND HIATAL HERNIA
+23 ;;C&P EYE
+24 ;;C&P FEET
+25 ;;C&P FIBROMYALGIA
+26 ;;C&P GENERAL MEDICAL
+27 ;;C&P GENITOURINARY
+28 ;;C&P GULF WAR PROTOCOL
+29 ;;C&P GYNECOLOGICAL CONDITIONS AND DISORDERS OF THE BREAST
+30 ;;C&P HAND, THUMB AND FINGERS
+31 ;;C&P HEART
+32 ;;C&P HEMIC DISORDERS
+33 ;;C&P HIV-RELATED ILLNESS
+34 ;;C&P HYPERTENSION
+35 ;;C&P INFECTIOUS, IMMUNE AND NUTRITIONAL DISABILITIES
+36 ;;C&P INTESTINES
+37 ;;C&P JOINTS (SHOULDER, ELBOW, WRIST, HIP, KNEE, ANKLE)
+38 ;;C&P LIVER, GALL BLADDER, AND PANCREAS
+39 ;;C&P LYMPHATIC DISORDERS
+40 ;;C&P MENTAL DISORDERS
+41 ;;C&P MOUTH, LIPS, AND TONGUE
+42 ;;C&P MUSCLES
+43 ;;C&P NEUROLOGICAL DISORDERS
+44 ;;C&P NOSE, SINUS, LARYNX, AND PHARYNX
+45 ;;C&P PERIPHERAL NERVES
+46 ;;C&P PRISONER OF WAR PROTOCOL
+47 ;;C&P PTSD, INITIAL EVALUATION
+48 ;;C&P PTSD, REVIEW
+49 ;;C&P PULMONARY TUBERCULOSIS AND MYCOBACTERIAL DISEASES
+50 ;;C&P RECTUM AND ANUS
+51 ;;C&P RESIDUALS OF AMPUTATIONS
+52 ;;C&P RESPIRATORY
+53 ;;C&P SCARS
+54 ;;C&P SENSE OF SMELL AND TASTE
+55 ;;C&P SKIN DISEASES
+56 ;;C&P SPINE
+57 ;;C&P STOMACH, DUODENUM, AND PERITONEAL ADHESIONS
+58 ;;C&P THYROID AND PARATHYROID DISEASES
+59 QUIT
