- TIUP290 ;SLC/WAT - Install SMART Titles ;05/04/20 06:49
- ;;1.0;TEXT INTEGRATION UTILITIES;**290**;Jun 20, 1997;Build 548
- ;ICR
- ;10141-^XPDUTL 2051-$$FIND1^DIC ;2053-^DIE ;2340-EN^DIK ;10103-$$FMTE^XLFDT ;4440-$$PROD^XUPROD
- Q
- MKOBJS ; install objects manually into 8925.1
- N TIUFPRIV,X,Y S TIUFPRIV=1 F X=1:1 S Y=$P($T(OBJECTS+X),";;",2) Q:Y="" D
- . N DA,TIU,TIUDA,ERR
- . S DA=+$$LU(8925.1,$P(Y,U)) I +DA D ; delete object if already exists
- . . N DIK,X,Y S DIK="^TIU(8925.1," D ^DIK
- . S TIU(8925.1,"+1,",.01)=$P(Y,U)
- . S TIU(8925.1,"+1,",.02)=$P(Y,U,2)
- . S TIU(8925.1,"+1,",.03)=$P($P(Y,U,3),";")
- . S TIU(8925.1,"+1,",.04)="O"
- . S TIU(8925.1,"+1,",.06)=$$LU(8930,"CLINICAL COORDINATOR")
- . S TIU(8925.1,"+1,",.07)=11
- . S TIU(8925.1,"+1,",.13)=1
- . S TIU(8925.1,"+1,",3.02)=1
- . S TIU(8925.1,"+1,",9)=$P(Y,";",2)
- . S TIU(8925.1,"+1,",99)=$H
- . D UPDATE^DIE("","TIU","TIUDA","ERR")
- Q
- OBJECTS ; install objects manually instead of via DD w/data screen - ajb
- ;;VA-REMINDER TEXT FOR REMINDER ORDER CHECK^^VA-REMINDER TEXT FOR REMINDER ORDER CHECK;S X=$$ROCTEXT^PXRMCWH1(DFN)
- ;;VA-SMART TEXT FOR ALERT^^VA-SMART TEXT FOR ALERT;S X=$$ALTOBJ^PXRMCALT(DFN)
- ;;VA-WH POTENTIAL TERATOGENIC ORDERS^PTO^POTENTIAL TERATOGENIC ORDERS;S X=$$GETORDRS^WVRPCPT1(DFN,"P")
- ;;VA-WH POTENTIAL UNSAFE ORDERS^PUO^POTENTIAL UNSAFE ORDERS;S X=$$GETORDRS^WVRPCPT1(DFN,"L")
- ;;VA-WH RECENT LABORATORY PREGNANCY TEST^^VA-WH RECENT LABORATORY PREGNANCY TEST;S X=$$GETPREGT^PXRMCWH1(DFN)
- ;;VA-WH RECENT LACTATION STATUS^^VA-WH RECENT LACTATION STATUS;S X=$$GETMRST^WVRPCPT1(DFN,"L")
- ;;VA-WH RECENT PREGNANT STATUS^^VA-WH RECENT PREGNANT STATUS;S X=$$GETMRST^WVRPCPT1(DFN,"P")
- ;;VA-WH SRN TEXT LACTATION^^LACTATION STATUS REVIEW NOTIFICATION TEXT;S X=$$GETSRND^WVRPCPT1(DFN,"L")
- ;;VA-WH SRN TEXT PREGNANCY^^PREGNANCY STATUS REVIEW NOTIFICATION TEXT;S X=$$GETSRND^WVRPCPT1(DFN,"P")
- ;;
- Q
- PRE ;pre-init
- D PREPARE,RMVOLD
- D MKOBJS
- Q
- ;
- POST ;post-init
- N TIUPGNTS,TIUSMTDC,TIUCLCOR,TIUSCMSG,TIUWHNDC,TIUSMTDC,TIUFPRIV,TIURET
- S TIUFPRIV=1
- S TIUPGNTS=$$LU(8925.1,"PROGRESS NOTES","X","I $P(^TIU(8925.1,+Y,0),U,4)=""CL""")
- S TIUCLCOR=$$LU(8930,"CLINICAL COORDINATOR","X")
- S TIUSCMSG=$$LU(8925.1,"SECURE MESSAGING DOCUMENTS","X","I $P(^TIU(8925.1,+Y,0),U,4)=""DC""")
- S TIUWHNDC=$$LU(8925.1,"WOMEN'S HEALTH NOTES","X","I $P(^TIU(8925.1,+Y,0),U,4)=""DC""")
- S TIUSMTDC=$$LU(8925.1,"SMART NOTES","X","I $P(^TIU(8925.1,+Y,0),U,4)=""DC""")
- D CRE8DC,CRE8TITL,MAP,REINDEX
- D BMES^XPDUTL(" Adding TIU ACTIONS RESOURCE device...")
- S TIURET=$$RES^XUDHSET("TIU ACTIONS RESOURCE",,,"Document actions notifier")
- I $P(TIURET,U)=-1 D
- . I $P(TIURET,U,2)["Device name in use" D MES^XPDUTL(" Device already exists") Q
- . D MES^XPDUTL(" FAILED: "_$P(TIURET,U,2))
- I $P(TIURET,U)>0 D MES^XPDUTL(" Device successfully added")
- D BMES^XPDUTL(" Tasking creation of new indices in file #8925 ...")
- D EN^TIUP290A
- D BMES^XPDUTL(" Tasking the indexing of new indices in file #8925 completed")
- D SETCNLK,TEMPLATE^TIUP290A
- Q
- ;
- PREPARE ; disable items from previous installs
- N TIUDA,TIUI,TITLESTR,TIUD0,TIUDC,TIUFPRIV,TIUFWHO,TIUTTL0,TTL0DA
- S TIUFPRIV=1,TIUFWHO="N"
- D BMES^XPDUTL(" Preparing TIU*1*290 Document Class & Titles for Update...")
- ;find and disable doc classes
- F TIUI=1:1 S TITLESTR=$P($T(DOCCLASS+TIUI),";",3) Q:TITLESTR="EOL" D
- .S TIUDC=$P(TITLESTR,U)
- .S TIUDA=$$LU(8925.1,TIUDC,"X","I $P(^TIU(8925.1,+Y,0),U,4)=""DC""")
- .D:+$G(TIUDA) DISABLE(TIUDA,TIUDC)
- ;find and disable titles
- F TIUI=1:1 S TITLESTR=$P($T(TITLES+TIUI),";",3) Q:TITLESTR="EOL" D
- .S TIUTTL0=$P(TITLESTR,U) Q:TIUTTL0']""
- .S TTL0DA=$O(^TIU(8925.1,"B",TIUTTL0,""))
- .D:$$LU(8925.1,TIUTTL0,"X","I $P(^TIU(8925.1,+Y,0),U,4)=""DOC""") DISABLE(TTL0DA,TIUTTL0)
- D BMES^XPDUTL("")
- Q
- RMVOLD ;Remove any old Copy/Paste related components which are no longer used
- N DA,DIK,ENT,IEN,INS,TIUIEN,TIUNMIEN,TIUP0
- D BMES^XPDUTL("REMOVING INVALID COPY/PASTE FUNCTION COMPONENTS ...")
- ;Loop through file 8925.99 and clear any field 4.3 entries
- D BMES^XPDUTL(" REMOVING FILE 8925.99 COMPONENTS ...")
- S TIUIEN=""
- F S TIUIEN=$O(^TIU(8925.99,TIUIEN)) Q:TIUIEN="" D
- . I $P($G(^TIU(8925.99,TIUIEN,4)),U,3)="" Q
- . S $P(^TIU(8925.99,TIUIEN,4),U,3)=""
- ;Now delete field 4.3 from the Data Dictionary for file 8925.99
- S DIK="^DD(8925.99,"
- S DA=4.3
- S DA(1)=8925.99
- D ^DIK
- K DA,DIK
- D MES^XPDUTL(" REMOVING FILE 8928 COMPONENTS ...")
- I $P($G(^TIUP(8928,0)),U,4)<501 D RMV8928
- I $P($G(^TIUP(8928,0)),U,4)'<501 D RMVTSK
- F DA=.13,.14 D
- . S DIK="^DD(8928,"
- . S DA(1)=8928
- . D ^DIK
- K DA,DIK
- ; Remove the parameter ORQQTIU COPY/PASTE FIND LIMIT definition and data
- S TIUNMIEN=$$FIND1^DIC(8989.51,"","X","ORQQTIU COPY/PASTE FIND LIMIT","B","","TIUERR")
- I +TIUNMIEN>0 D
- . D MES^XPDUTL(" REMOVING PARAMETER COMPONENTS ...")
- . S ENT=""
- . F S ENT=$O(^XTV(8989.5,"AC",TIUNMIEN,ENT)) Q:ENT="" D
- .. S INS=""
- .. F S INS=$O(^XTV(8989.5,"AC",TIUNMIEN,ENT,INS)) Q:INS="" D
- ... S DA=""
- ... F S DA=$O(^XTV(8989.5,"AC",TIUNMIEN,ENT,INS,DA)) Q:DA="" D
- .... S DIK="^XTV(8989.5,"
- .... D ^DIK
- . S DIK="^XTV(8989.51,"
- . S DA=TIUNMIEN
- . D ^DIK
- D BMES^XPDUTL("COMPLETED REMOVING INVALID COPY/PASTE FUNCTION COMPONENTS!")
- Q
- DISABLE(TIUDA,TIUNM) ; Disable a document definition
- N TIUREC,TIUERR
- D MES^XPDUTL(" Inactivating "_TIUNM_".")
- S TIUREC(.07)="INACTIVE"
- D UPDATE(TIUDA,.TIUREC,.TIUERR)
- I $D(TIUERR) D Q
- . D MES^XPDUTL(" Unable to Inactivate "_TIUNM_".")
- . D MES^XPDUTL(" "_$G(TIUERR("DIERR",1,"TEXT",1)))
- Q
- LU(FILE,NAME,FLAGS,SCREEN,INDEXES) ; call FileMan Finder to look up file entry
- N MSGERR
- Q $$FIND1^DIC(FILE,"",$G(FLAGS),NAME,$G(INDEXES),$G(SCREEN),"MSGERR")
- CRE8DC ;create doc class if not already on system
- N TIUI,TITLESTR,TIUDC,TIUDA,TIUERR,TIUINMSG,TIUVNAME
- F TIUI=1:1 S TITLESTR=$P($T(DOCCLASS+TIUI),";",3) Q:TITLESTR="EOL"!($D(TIUERR)) D
- .S TIUDC=$P(TITLESTR,U),TIUVNAME=$P(TITLESTR,U,2)
- .S TIUDA=$$CREATE(TIUDC,"",TIUDC,"DC","11",.TIUERR)
- .I $D(TIUERR) D Q
- ..N TIUJ
- ..D BMES^XPDUTL(" The following error message was returned:")
- ..S TIUJ="" F S TIUJ=$O(TIUERR("DIERR",1,"TEXT",TIUJ)) Q:TIUJ="" D MES^XPDUTL(" "_$G(TIUMSG("DIERR",1,"TEXT",TIUJ)))
- .S TIUINMSG=$$INSTALL(TIUDA,+$G(TIUPGNTS))
- .I +$G(TIUINMSG)'>0 D BMES^XPDUTL("Error adding "_TIUDC_" to PROGRESS NOTES") Q
- .X "S "_TIUVNAME_"=TIUDA"
- Q
- CRE8TITL(DOCLAS) ;will loop thru TITLES to Create and Install new titles
- N TIUI,TITLESTR,TIUX290,TIU01,TIU04,TIU07,TIUERR,TIU3,TIU4
- S TIU04="DOC",TIU07=13 ;titles are activated in MAP
- F TIUI=1:1 S TITLESTR=$P($T(TITLES+TIUI),";",3) Q:TITLESTR="EOL" D
- .S TIU01=$P(TITLESTR,U),TIU3=$P(TITLESTR,U,3),TIU4=$P(TITLESTR,U,4)
- .S TIUX290=$$CREATE(TIU01,"",TIU01,TIU04,TIU07,.TIUERR)
- .I $D(TIUERR) D
- ..N TIUI
- ..D BMES^XPDUTL("The following error message was returned:")
- ..S TIUI="" F S TIUI=$O(TIUERR("DIERR",1,"TEXT",TIUI)) Q:TIUI="" D MES^XPDUTL(" "_$G(TIUMSG("DIERR",1,"TEXT",TIUI)))
- .I +$G(TIUX290) D
- ..S:$G(TIU4)="R" TIUX290=$$INSTALL(+$G(TIUX290),$G(TIUSCMSG),$G(TIU3))
- ..S:$G(TIU4)="T" TIUX290=$$INSTALL(+$G(TIUX290),$G(TIUWHNDC),$G(TIU3))
- ..S:$G(TIU4)="S" TIUX290=$$INSTALL(+$G(TIUX290),$G(TIUSMTDC),$G(TIU3))
- ..D BMES^XPDUTL(TIU01_" successfully installed")
- .E D BMES^XPDUTL("Error: "_TIU01_" was not added to the document class")
- Q
- ;
- CREATE(TIUNAME,TIUABB,TIUPNAME,TIUTYPE,TIUSTAT,TIUERR) ;creates/update entry; returns IEN of entry
- N TIUREC,TIUDA,TIUFPRIV,TIUFWHO,TIUNATTL
- S TIUNATTL=1
- S TIUFPRIV=1,TIUFWHO="N"
- S TIUREC(8925.1,"?+1,",.01)=$G(TIUNAME) ;NAME
- S TIUREC(8925.1,"?+1,",.02)=$G(TIUABB) ;ABBREVIATION
- S TIUREC(8925.1,"?+1,",.03)=$G(TIUPNAME) ;PRINT NAME
- S TIUREC(8925.1,"?+1,",.04)=$G(TIUTYPE) ;TYPE
- S TIUREC(8925.1,"?+1,",.06)=$G(TIUCLCOR) ;CLASS OWNER
- S TIUREC(8925.1,"?+1,",.07)=$G(TIUSTAT) ;STATUS 11=ACTIVE, 13=INACTIVE
- S TIUREC(8925.1,"?+1,",.13)=$G(TIUNATTL) ;NAT'L STD 1=YES
- S TIUREC(8925.1,"?+1,",3.02)=1 ;OK TO DISTR=YES
- S TIUREC(8925.1,"?+1,",99)=$H ;TIMESTAMP
- D UPDATE^DIE("","TIUREC","TIUDA","TIUERR")
- Q +$G(TIUDA(1))
- ;
- INSTALL(TIUDNM,TIUPRNT,TIUMNTXT) ; Install document definition
- ;TIUDNM - title IEN, TIUPRNT - parent IEN, TIUMNTXT - menu text
- N TIU,TIUIEN,TIUMSG,TIUJ
- S TIU(8925.14,"?+1,"_TIUPRNT_",",.01)=TIUDNM
- S TIU(8925.14,"?+1,"_TIUPRNT_",",4)=$G(TIUMNTXT) ;$G b/c menu text not defined for Doc Class
- D UPDATE^DIE("","TIU","TIUIEN","TIUMSG")
- I $D(TIUMSG) D
- . D BMES^XPDUTL("The following error message was returned:")
- . S TIUJ="" F S TIUJ=$O(TIUMSG("DIERR",1,"TEXT",TIUJ)) Q:TIUJ="" D MES^XPDUTL(" "_$G(TIUMSG("DIERR",1,"TEXT",TIUJ)))
- Q +$G(TIUIEN(1))
- UPDATE(TIUDA,TIUREC,TIUERR) ; call FileMan Filer to update record
- N TIUIENS,TIUFLAGS,TIUFDA,TIUFPRIV,TIUFWHO,TIUFI
- S TIUFPRIV=1,TIUFWHO="N",TIUIENS=TIUDA_",",TIUFI=0
- F S TIUFI=$O(TIUREC(TIUFI)) Q:+TIUFI'>0 D
- . S TIUFDA(8925.1,TIUIENS,TIUFI)=$G(TIUREC(TIUFI))
- S TIUFLAGS="ET" ;External, Transaction (all or nothing)
- D FILE^DIE(TIUFLAGS,"TIUFDA","TIUERR")
- Q
- MAP ; Map HT Titles to appropriate VHA Enterprise Standard Titles
- N TIUERR,TIUIENS,TIUFLAGS,TIUFDA,TIUFPRIV,TIUFWHO,TIUPROD,TIUI,TITLESTR
- D BMES^XPDUTL("Attempting to map TIU*1*290 titles to VHA Enterprise Standard Titles...")
- S TIUPROD=$$PROD^XUPROD(1),TIUFPRIV=1,TIUFWHO="N"
- F TIUI=1:1 S TITLESTR=$P($T(TITLES+TIUI),";",3) Q:TITLESTR="EOL" D
- . N TIUDA,TIUTTL1,TIUETTL,TIUREC,TIUERR
- . S TIUTTL1=$P(TITLESTR,U) Q:TIUTTL1']""
- . S TIUDA=$$LU(8925.1,TIUTTL1,"X","I $P(^TIU(8925.1,+Y,0),U,4)=""DOC""")
- . I +TIUDA'>0 D BMES^XPDUTL(" "_TIUTTL1_" title not installed.") Q
- . S TIUIENS=TIUDA_",",TIUETTL=$P(TITLESTR,U,2)
- . S TIUFDA(8925.1,TIUIENS,1501)=TIUETTL
- . S TIUFDA(8925.1,TIUIENS,1502)=$$FMTE^XLFDT($$NOW^XLFDT)
- . S TIUFDA(8925.1,TIUIENS,1503)="`"_DUZ
- . S TIUFLAGS="ET"
- . D FILE^DIE(TIUFLAGS,"TIUFDA","TIUERR")
- . ; if filing error occurs, write message to install log & quit
- . I $D(TIUERR) D Q
- . . D:TIUPROD BMES^XPDUTL(" Unable to map "_TIUTTL1_" title") I 1
- . . D:TIUPROD MES^XPDUTL(" to "_TIUETTL_". You'll have to manually map the title.")
- . . D:TIUPROD MES^XPDUTL(" "_$G(TIUERR("DIERR",1,"TEXT",1)))
- . . K TIUFDA(8925.1,TIUIENS)
- . ; otherwise activate title
- . S TIUFDA(8925.1,TIUIENS,".07")="ACTIVE"
- . D FILE^DIE(TIUFLAGS,"TIUFDA","TIUERR")
- . ; if filing error occurs, write message to install log
- . I $D(TIUERR),TIUPROD D Q
- . . D BMES^XPDUTL(" Unable to Activate "_TIUTTL1_" TITLE.")
- . . D MES^XPDUTL(" "_$G(TIUERR("DIERR",1,"TEXT",1)))
- . . K TIUFDA(8925.1,TIUIENS)
- . ; finally, check for entry in "ACL" cross-reference and if missing, call EN^DIK
- . I +$O(^TIU(8925.1,"ACL",3,TIUTTL1,0))'>0 D
- . . N DIK,DA S DIK="^TIU(8925.1,",DIK(1)=".07^ACL07",DA=TIUDA D EN^DIK
- Q
- REINDEX ; Re-index entries
- N DIK
- D BMES^XPDUTL(" Reindexing TIU Titles")
- S DIK="^TIU(8925.1,",DIK(1)=".07^AS"
- D ENALL2^DIK
- S DIK="^TIU(8925.1,",DIK(1)=".07^AS"
- D ENALL^DIK
- Q
- RMVTSK ;Task clean-up of 8928 file if greater than 500 entries
- N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK
- S ZTRTN="RMV8928^TIUP290"
- S ZTDESC="TIU PATCH 290 COPY/PASTE 8928 CLEAN-UP"
- S ZTDTH=$H
- S ZTIO=""
- D ^%ZTLOAD
- I '$D(ZTSK) D MES^XPDUTL(" Failed to task off Copy/Paste removal of bad data in file 8928!")
- I $D(ZTSK) D MES^XPDUTL(" Task #"_ZTSK_" created to clean-up data in file 8928!!")
- Q
- RMV8928 ;Clean-up 8928 file entries in contain fields .13 or .14 data
- N TIUIEN,TIUP0
- S TIUIEN=""
- F S TIUIEN=$O(^TIUP(8928,TIUIEN)) Q:TIUIEN="" D
- . S TIUP0=$G(^TIUP(8928,TIUIEN,0))
- . I $P(TIUP0,U,13)="",$P(TIUP0,U,14)="" Q
- . S $P(^TIUP(8928,TIUIEN,0),U,12,14)=$P(TIUP0,U,12)
- Q
- ;
- SETCNLK ;set TIU TEMPLATE CONSULT LOCK param vals on post-init
- N TIUERR,SRVCNT,INDEX,TIUIEN,TIUOUT,TIU0,TIU01
- D FIND^DIC(8927,"","@;.01;IX","","NON VA CARE HCPS ","*","B","","","TIUOUT") ;get templates beginning with "NON VA CARE HCPS "
- I +$G(TIUOUT("DILIST",0))=0 D Q
- . D BMES^XPDUTL("No TIU TEMPLATES beginning with ""NON VA CARE HCPS "" were found.")
- . D MES^XPDUTL("No values have been added to the TIU TEMPLATE CONSULT LOCK parameter.")
- . D MES^XPDUTL("No consult templates have been locked as read-only.")
- . D MES^XPDUTL("Please enter a help desk ticket for assistance with TIU*1*290.")
- . D MES^XPDUTL("The ticket should request assistance with locking TIU Templates that are")
- . D MES^XPDUTL("used in NON VA CARE HCPS consults which are transmitted to RAS.")
- S SRVCNT=$P(TIUOUT("DILIST",0),U),INDEX=""
- D BMES^XPDUTL("Checking TIU TEMPLATE CONSULT LOCK parameter for existing values.")
- F S INDEX=$O(TIUOUT("DILIST",2,INDEX)) Q:INDEX="" D
- . S TIUIEN=TIUOUT("DILIST",2,INDEX)
- . S TIU0=^TIU(8927,TIUIEN,0)
- . Q:$P(TIU0,U,19)'["GMR(123.5"
- . S TIU01=$P(TIU0,U)
- . I '$$CHEKPAR(TIU01) D
- . . D BMES^XPDUTL("Setting parameter value for "_TIU01)
- . . D SETPAR(TIU01,INDEX)
- . . D SETTLOCK(TIUIEN)
- . . D SETFLOCK(TIUIEN)
- . . D BMES^XPDUTL("....done")
- . E D MES^XPDUTL("Parameter already set for "_TIU01)
- Q
- ;
- SETPAR(TIUNAME,TIUINST) ;set it
- N TIUERR
- D EN^XPAR("SYS","TIU TEMPLATE CONSULT LOCK",TIUINST,TIUNAME,.TIUERR)
- I $G(TIUERR)>0 D BMES^XPDUTL("Error setting parameter value for "_TIUNAME),ERROR Q
- Q
- ;
- ERROR ; show it
- D BMES^XPDUTL("ERROR #"_$P(TIUERR,U))
- D MES^XPDUTL("TEXT: "_$P(TIUERR,U,2))
- Q
- ;
- CHEKPAR(TIUNAME) ;check for param value
- ;return ISPAR: 1 if value exists, 0 if not
- N TIUY,TIUERR,IDX,ISPAR
- S ISPAR=0,IDX=""
- D GETLST^XPAR(.TIUY,"SYS","TIU TEMPLATE CONSULT LOCK","N")
- Q:+$G(TIUY)=0 ISPAR
- F S IDX=$O(TIUY(IDX)) Q:IDX=""!(ISPAR=1) D
- .S:$P(TIUY(IDX),U,2)=$G(TIUNAME) ISPAR=1
- Q ISPAR
- ;
- SETTLOCK(IEN) ;set template lock
- N TIUARY,TIUCNT
- D BLD(IEN,.TIUARY)
- N DIE,DA,DR S DIE="^TIU(8927,",DR=".2///YES"
- F TIUCNT=1:1 Q:'$D(TIUARY(TIUCNT)) D
- .S DA=TIUARY(TIUCNT)
- .L +^TIU(8927,DA):DILOCKTM
- .I $T D:+$G(DA)>0 ^DIE L -^TIU(8927,DA)
- Q
- ;
- SETFLOCK(IEN) ;set template field lock
- N DIE,DA,DR,TIUARY,TIUCNT
- K ^TMP("TIU F",$J)
- D BLD(IEN,.TIUARY)
- D FLD ;populates ^TMP("TIU F",$J
- S TIUCNT="",DIE="^TIU(8927.1,",DR=".17///YES"
- F S TIUCNT=$O(^TMP("TIU F",$J,TIUCNT)) Q:TIUCNT="" D
- . S DA=$O(^TIU(8927.1,"B",^TMP("TIU F",$J,TIUCNT),""))
- . L +^TIU(8927.1,DA):DILOCKTM
- . I $T D:+$G(DA)>0 ^DIE L -^TIU(8927.1,DA)
- K ^TMP("TIU F",$J)
- Q
- ;
- FLD ;build list of template fields
- ;TIUARY set in call to BLD
- K ^TMP("TIU FIELDS",$J)
- N TIUY,TIUFLD,CNT,CNT2,CNT3 S (CNT,CNT2)="",CNT3=1
- F S CNT=$O(TIUARY(CNT)) Q:CNT="" D
- . D GETBOIL^TIUSRVT(.TIUY,(TIUARY(CNT))) ;TIUY = name of ^TMP(TIU TEMPLATE,$J)
- . F S CNT2=$O(@TIUY@(CNT2)) Q:CNT2="" D
- .. S ^TMP("TIU FIELDS",$J,CNT3)=@TIUY@(CNT2),CNT3=CNT3+1 ;get every line; possible to have remnant of a wrapped field e.g. "40x2}"
- N BEG,END,FIELD,LINE,LNCNT,I,OK,LNWRAP K ^TMP("TIU F",$J) S LNCNT=1,OK=1,I="",LNWRAP=""
- F S CNT=$O(^TMP("TIU FIELDS",$J,CNT)) Q:CNT="" D
- . S LINE=^TMP("TIU FIELDS",$J,CNT)
- . I $L(LNWRAP)>0 S LINE=LNWRAP_LINE,LNWRAP="" ;if length, may need to finish building FLD from previous line of text
- . F D Q:END=0
- . . S BEG=$FIND(LINE,"{FLD:") I BEG=0 S END=0 Q ;didn't find {FLD:, possible fragmented line
- . . S END=$FIND(LINE,"}",BEG)
- . . S:END=0 LNWRAP=LINE ; assume a fragment of a FLD, concatenate and check next LINE in template.
- . . Q:END=0
- . . S FIELD=$E(LINE,BEG,(END-2))
- . . S OK=1,I=""
- . . F S I=$O(^TMP("TIU F",$J,I)) Q:I=""!(OK=0) D ;prevent dups in ^TMP("TIU F"
- . . . S:(FIELD["{FLD")!(FIELD?.E1"}") OK=0 Q ;keep out some junk that GUI editor allows
- . . . S:^TMP("TIU F",$J,I)=FIELD OK=0
- . . S:OK ^TMP("TIU F",$J,LNCNT)=FIELD,LNCNT=LNCNT+1
- . . S LINE=$E(LINE,(END),999)
- K ^TMP("TIU FIELDS",$J)
- Q
- BLD(TIUIEN,TIUARY) ; Build array of templates.
- N TIUIDX
- S TIUIDX=$O(TIUARY(" "),-1)+1
- S TIUARY(TIUIDX)=TIUIEN
- S TIUIDX=0
- F S TIUIDX=$O(^TIU(8927,TIUIEN,10,TIUIDX)) Q:'TIUIDX D
- .D BLD($P(^TIU(8927,TIUIEN,10,TIUIDX,0),U,2),.TIUARY)
- Q
- ;
- TITLES ;TITLE ^ VHA ENT STD TITLE ^ MENU TEXT ^ PARENT DOC CLASS TYPE
- ;;HEALTHELIVING ASSESSMENT SUMMARY^RISK ASSESSMENT SCREENING NOTE^Healthelvg Asmnt Sum^R
- ;;PREGNANCY STATUS UPDATE REVIEW^WOMENS HEALTH NOTE^Preg Status Upd Rev^T
- ;;LACTATION STATUS UPDATE REVIEW^WOMENS HEALTH NOTE^Lact Status Upd Rev^T
- ;;SMART BREAST IMAGING FOLLOW-UP^WOMENS HEALTH NOTE^Smart Brst Img F/u^S
- ;;SMART PATIENT NOTIFICATION^WOMENS HEALTH NOTE^Smart Patient Notif^S
- ;;SMART OUTSIDE BREAST IMAGE RESULTS^WOMENS HEALTH NOTE^Smrt Out Brst Img Rs^S
- ;;EOL
- DOCCLASS ;CLASS NAME ^ IEN VARIABLE NAME
- ;;SMART NOTES^TIUSMTDC
- ;;WOMEN'S HEALTH NOTES^TIUWHNDC
- ;;EOL
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUP290 16702 printed Feb 19, 2025@00:09:26 Page 2
- TIUP290 ;SLC/WAT - Install SMART Titles ;05/04/20 06:49
- +1 ;;1.0;TEXT INTEGRATION UTILITIES;**290**;Jun 20, 1997;Build 548
- +2 ;ICR
- +3 ;10141-^XPDUTL 2051-$$FIND1^DIC ;2053-^DIE ;2340-EN^DIK ;10103-$$FMTE^XLFDT ;4440-$$PROD^XUPROD
- +4 QUIT
- MKOBJS ; install objects manually into 8925.1
- +1 NEW TIUFPRIV,X,Y
- SET TIUFPRIV=1
- FOR X=1:1
- SET Y=$PIECE($TEXT(OBJECTS+X),";;",2)
- if Y=""
- QUIT
- Begin DoDot:1
- +2 NEW DA,TIU,TIUDA,ERR
- +3 ; delete object if already exists
- SET DA=+$$LU(8925.1,$PIECE(Y,U))
- IF +DA
- Begin DoDot:2
- +4 NEW DIK,X,Y
- SET DIK="^TIU(8925.1,"
- DO ^DIK
- End DoDot:2
- +5 SET TIU(8925.1,"+1,",.01)=$PIECE(Y,U)
- +6 SET TIU(8925.1,"+1,",.02)=$PIECE(Y,U,2)
- +7 SET TIU(8925.1,"+1,",.03)=$PIECE($PIECE(Y,U,3),";")
- +8 SET TIU(8925.1,"+1,",.04)="O"
- +9 SET TIU(8925.1,"+1,",.06)=$$LU(8930,"CLINICAL COORDINATOR")
- +10 SET TIU(8925.1,"+1,",.07)=11
- +11 SET TIU(8925.1,"+1,",.13)=1
- +12 SET TIU(8925.1,"+1,",3.02)=1
- +13 SET TIU(8925.1,"+1,",9)=$PIECE(Y,";",2)
- +14 SET TIU(8925.1,"+1,",99)=$HOROLOG
- +15 DO UPDATE^DIE("","TIU","TIUDA","ERR")
- End DoDot:1
- +16 QUIT
- OBJECTS ; install objects manually instead of via DD w/data screen - ajb
- +1 ;;VA-REMINDER TEXT FOR REMINDER ORDER CHECK^^VA-REMINDER TEXT FOR REMINDER ORDER CHECK;S X=$$ROCTEXT^PXRMCWH1(DFN)
- +2 ;;VA-SMART TEXT FOR ALERT^^VA-SMART TEXT FOR ALERT;S X=$$ALTOBJ^PXRMCALT(DFN)
- +3 ;;VA-WH POTENTIAL TERATOGENIC ORDERS^PTO^POTENTIAL TERATOGENIC ORDERS;S X=$$GETORDRS^WVRPCPT1(DFN,"P")
- +4 ;;VA-WH POTENTIAL UNSAFE ORDERS^PUO^POTENTIAL UNSAFE ORDERS;S X=$$GETORDRS^WVRPCPT1(DFN,"L")
- +5 ;;VA-WH RECENT LABORATORY PREGNANCY TEST^^VA-WH RECENT LABORATORY PREGNANCY TEST;S X=$$GETPREGT^PXRMCWH1(DFN)
- +6 ;;VA-WH RECENT LACTATION STATUS^^VA-WH RECENT LACTATION STATUS;S X=$$GETMRST^WVRPCPT1(DFN,"L")
- +7 ;;VA-WH RECENT PREGNANT STATUS^^VA-WH RECENT PREGNANT STATUS;S X=$$GETMRST^WVRPCPT1(DFN,"P")
- +8 ;;VA-WH SRN TEXT LACTATION^^LACTATION STATUS REVIEW NOTIFICATION TEXT;S X=$$GETSRND^WVRPCPT1(DFN,"L")
- +9 ;;VA-WH SRN TEXT PREGNANCY^^PREGNANCY STATUS REVIEW NOTIFICATION TEXT;S X=$$GETSRND^WVRPCPT1(DFN,"P")
- +10 ;;
- +11 QUIT
- PRE ;pre-init
- +1 DO PREPARE
- DO RMVOLD
- +2 DO MKOBJS
- +3 QUIT
- +4 ;
- POST ;post-init
- +1 NEW TIUPGNTS,TIUSMTDC,TIUCLCOR,TIUSCMSG,TIUWHNDC,TIUSMTDC,TIUFPRIV,TIURET
- +2 SET TIUFPRIV=1
- +3 SET TIUPGNTS=$$LU(8925.1,"PROGRESS NOTES","X","I $P(^TIU(8925.1,+Y,0),U,4)=""CL""")
- +4 SET TIUCLCOR=$$LU(8930,"CLINICAL COORDINATOR","X")
- +5 SET TIUSCMSG=$$LU(8925.1,"SECURE MESSAGING DOCUMENTS","X","I $P(^TIU(8925.1,+Y,0),U,4)=""DC""")
- +6 SET TIUWHNDC=$$LU(8925.1,"WOMEN'S HEALTH NOTES","X","I $P(^TIU(8925.1,+Y,0),U,4)=""DC""")
- +7 SET TIUSMTDC=$$LU(8925.1,"SMART NOTES","X","I $P(^TIU(8925.1,+Y,0),U,4)=""DC""")
- +8 DO CRE8DC
- DO CRE8TITL
- DO MAP
- DO REINDEX
- +9 DO BMES^XPDUTL(" Adding TIU ACTIONS RESOURCE device...")
- +10 SET TIURET=$$RES^XUDHSET("TIU ACTIONS RESOURCE",,,"Document actions notifier")
- +11 IF $PIECE(TIURET,U)=-1
- Begin DoDot:1
- +12 IF $PIECE(TIURET,U,2)["Device name in use"
- DO MES^XPDUTL(" Device already exists")
- QUIT
- +13 DO MES^XPDUTL(" FAILED: "_$PIECE(TIURET,U,2))
- End DoDot:1
- +14 IF $PIECE(TIURET,U)>0
- DO MES^XPDUTL(" Device successfully added")
- +15 DO BMES^XPDUTL(" Tasking creation of new indices in file #8925 ...")
- +16 DO EN^TIUP290A
- +17 DO BMES^XPDUTL(" Tasking the indexing of new indices in file #8925 completed")
- +18 DO SETCNLK
- DO TEMPLATE^TIUP290A
- +19 QUIT
- +20 ;
- PREPARE ; disable items from previous installs
- +1 NEW TIUDA,TIUI,TITLESTR,TIUD0,TIUDC,TIUFPRIV,TIUFWHO,TIUTTL0,TTL0DA
- +2 SET TIUFPRIV=1
- SET TIUFWHO="N"
- +3 DO BMES^XPDUTL(" Preparing TIU*1*290 Document Class & Titles for Update...")
- +4 ;find and disable doc classes
- +5 FOR TIUI=1:1
- SET TITLESTR=$PIECE($TEXT(DOCCLASS+TIUI),";",3)
- if TITLESTR="EOL"
- QUIT
- Begin DoDot:1
- +6 SET TIUDC=$PIECE(TITLESTR,U)
- +7 SET TIUDA=$$LU(8925.1,TIUDC,"X","I $P(^TIU(8925.1,+Y,0),U,4)=""DC""")
- +8 if +$GET(TIUDA)
- DO DISABLE(TIUDA,TIUDC)
- End DoDot:1
- +9 ;find and disable titles
- +10 FOR TIUI=1:1
- SET TITLESTR=$PIECE($TEXT(TITLES+TIUI),";",3)
- if TITLESTR="EOL"
- QUIT
- Begin DoDot:1
- +11 SET TIUTTL0=$PIECE(TITLESTR,U)
- if TIUTTL0']""
- QUIT
- +12 SET TTL0DA=$ORDER(^TIU(8925.1,"B",TIUTTL0,""))
- +13 if $$LU(8925.1,TIUTTL0,"X","I $P(^TIU(8925.1,+Y,0),U,4)=""DOC""")
- DO DISABLE(TTL0DA,TIUTTL0)
- End DoDot:1
- +14 DO BMES^XPDUTL("")
- +15 QUIT
- RMVOLD ;Remove any old Copy/Paste related components which are no longer used
- +1 NEW DA,DIK,ENT,IEN,INS,TIUIEN,TIUNMIEN,TIUP0
- +2 DO BMES^XPDUTL("REMOVING INVALID COPY/PASTE FUNCTION COMPONENTS ...")
- +3 ;Loop through file 8925.99 and clear any field 4.3 entries
- +4 DO BMES^XPDUTL(" REMOVING FILE 8925.99 COMPONENTS ...")
- +5 SET TIUIEN=""
- +6 FOR
- SET TIUIEN=$ORDER(^TIU(8925.99,TIUIEN))
- if TIUIEN=""
- QUIT
- Begin DoDot:1
- +7 IF $PIECE($GET(^TIU(8925.99,TIUIEN,4)),U,3)=""
- QUIT
- +8 SET $PIECE(^TIU(8925.99,TIUIEN,4),U,3)=""
- End DoDot:1
- +9 ;Now delete field 4.3 from the Data Dictionary for file 8925.99
- +10 SET DIK="^DD(8925.99,"
- +11 SET DA=4.3
- +12 SET DA(1)=8925.99
- +13 DO ^DIK
- +14 KILL DA,DIK
- +15 DO MES^XPDUTL(" REMOVING FILE 8928 COMPONENTS ...")
- +16 IF $PIECE($GET(^TIUP(8928,0)),U,4)<501
- DO RMV8928
- +17 IF $PIECE($GET(^TIUP(8928,0)),U,4)'<501
- DO RMVTSK
- +18 FOR DA=.13,.14
- Begin DoDot:1
- +19 SET DIK="^DD(8928,"
- +20 SET DA(1)=8928
- +21 DO ^DIK
- End DoDot:1
- +22 KILL DA,DIK
- +23 ; Remove the parameter ORQQTIU COPY/PASTE FIND LIMIT definition and data
- +24 SET TIUNMIEN=$$FIND1^DIC(8989.51,"","X","ORQQTIU COPY/PASTE FIND LIMIT","B","","TIUERR")
- +25 IF +TIUNMIEN>0
- Begin DoDot:1
- +26 DO MES^XPDUTL(" REMOVING PARAMETER COMPONENTS ...")
- +27 SET ENT=""
- +28 FOR
- SET ENT=$ORDER(^XTV(8989.5,"AC",TIUNMIEN,ENT))
- if ENT=""
- QUIT
- Begin DoDot:2
- +29 SET INS=""
- +30 FOR
- SET INS=$ORDER(^XTV(8989.5,"AC",TIUNMIEN,ENT,INS))
- if INS=""
- QUIT
- Begin DoDot:3
- +31 SET DA=""
- +32 FOR
- SET DA=$ORDER(^XTV(8989.5,"AC",TIUNMIEN,ENT,INS,DA))
- if DA=""
- QUIT
- Begin DoDot:4
- +33 SET DIK="^XTV(8989.5,"
- +34 DO ^DIK
- End DoDot:4
- End DoDot:3
- End DoDot:2
- +35 SET DIK="^XTV(8989.51,"
- +36 SET DA=TIUNMIEN
- +37 DO ^DIK
- End DoDot:1
- +38 DO BMES^XPDUTL("COMPLETED REMOVING INVALID COPY/PASTE FUNCTION COMPONENTS!")
- +39 QUIT
- DISABLE(TIUDA,TIUNM) ; Disable a document definition
- +1 NEW TIUREC,TIUERR
- +2 DO MES^XPDUTL(" Inactivating "_TIUNM_".")
- +3 SET TIUREC(.07)="INACTIVE"
- +4 DO UPDATE(TIUDA,.TIUREC,.TIUERR)
- +5 IF $DATA(TIUERR)
- Begin DoDot:1
- +6 DO MES^XPDUTL(" Unable to Inactivate "_TIUNM_".")
- +7 DO MES^XPDUTL(" "_$GET(TIUERR("DIERR",1,"TEXT",1)))
- End DoDot:1
- QUIT
- +8 QUIT
- LU(FILE,NAME,FLAGS,SCREEN,INDEXES) ; call FileMan Finder to look up file entry
- +1 NEW MSGERR
- +2 QUIT $$FIND1^DIC(FILE,"",$GET(FLAGS),NAME,$GET(INDEXES),$GET(SCREEN),"MSGERR")
- CRE8DC ;create doc class if not already on system
- +1 NEW TIUI,TITLESTR,TIUDC,TIUDA,TIUERR,TIUINMSG,TIUVNAME
- +2 FOR TIUI=1:1
- SET TITLESTR=$PIECE($TEXT(DOCCLASS+TIUI),";",3)
- if TITLESTR="EOL"!($DATA(TIUERR))
- QUIT
- Begin DoDot:1
- +3 SET TIUDC=$PIECE(TITLESTR,U)
- SET TIUVNAME=$PIECE(TITLESTR,U,2)
- +4 SET TIUDA=$$CREATE(TIUDC,"",TIUDC,"DC","11",.TIUERR)
- +5 IF $DATA(TIUERR)
- Begin DoDot:2
- +6 NEW TIUJ
- +7 DO BMES^XPDUTL(" The following error message was returned:")
- +8 SET TIUJ=""
- FOR
- SET TIUJ=$ORDER(TIUERR("DIERR",1,"TEXT",TIUJ))
- if TIUJ=""
- QUIT
- DO MES^XPDUTL(" "_$GET(TIUMSG("DIERR",1,"TEXT",TIUJ)))
- End DoDot:2
- QUIT
- +9 SET TIUINMSG=$$INSTALL(TIUDA,+$GET(TIUPGNTS))
- +10 IF +$GET(TIUINMSG)'>0
- DO BMES^XPDUTL("Error adding "_TIUDC_" to PROGRESS NOTES")
- QUIT
- +11 XECUTE "S "_TIUVNAME_"=TIUDA"
- End DoDot:1
- +12 QUIT
- CRE8TITL(DOCLAS) ;will loop thru TITLES to Create and Install new titles
- +1 NEW TIUI,TITLESTR,TIUX290,TIU01,TIU04,TIU07,TIUERR,TIU3,TIU4
- +2 ;titles are activated in MAP
- SET TIU04="DOC"
- SET TIU07=13
- +3 FOR TIUI=1:1
- SET TITLESTR=$PIECE($TEXT(TITLES+TIUI),";",3)
- if TITLESTR="EOL"
- QUIT
- Begin DoDot:1
- +4 SET TIU01=$PIECE(TITLESTR,U)
- SET TIU3=$PIECE(TITLESTR,U,3)
- SET TIU4=$PIECE(TITLESTR,U,4)
- +5 SET TIUX290=$$CREATE(TIU01,"",TIU01,TIU04,TIU07,.TIUERR)
- +6 IF $DATA(TIUERR)
- Begin DoDot:2
- +7 NEW TIUI
- +8 DO BMES^XPDUTL("The following error message was returned:")
- +9 SET TIUI=""
- FOR
- SET TIUI=$ORDER(TIUERR("DIERR",1,"TEXT",TIUI))
- if TIUI=""
- QUIT
- DO MES^XPDUTL(" "_$GET(TIUMSG("DIERR",1,"TEXT",TIUI)))
- End DoDot:2
- +10 IF +$GET(TIUX290)
- Begin DoDot:2
- +11 if $GET(TIU4)="R"
- SET TIUX290=$$INSTALL(+$GET(TIUX290),$GET(TIUSCMSG),$GET(TIU3))
- +12 if $GET(TIU4)="T"
- SET TIUX290=$$INSTALL(+$GET(TIUX290),$GET(TIUWHNDC),$GET(TIU3))
- +13 if $GET(TIU4)="S"
- SET TIUX290=$$INSTALL(+$GET(TIUX290),$GET(TIUSMTDC),$GET(TIU3))
- +14 DO BMES^XPDUTL(TIU01_" successfully installed")
- End DoDot:2
- +15 IF '$TEST
- DO BMES^XPDUTL("Error: "_TIU01_" was not added to the document class")
- End DoDot:1
- +16 QUIT
- +17 ;
- CREATE(TIUNAME,TIUABB,TIUPNAME,TIUTYPE,TIUSTAT,TIUERR) ;creates/update entry; returns IEN of entry
- +1 NEW TIUREC,TIUDA,TIUFPRIV,TIUFWHO,TIUNATTL
- +2 SET TIUNATTL=1
- +3 SET TIUFPRIV=1
- SET TIUFWHO="N"
- +4 ;NAME
- SET TIUREC(8925.1,"?+1,",.01)=$GET(TIUNAME)
- +5 ;ABBREVIATION
- SET TIUREC(8925.1,"?+1,",.02)=$GET(TIUABB)
- +6 ;PRINT NAME
- SET TIUREC(8925.1,"?+1,",.03)=$GET(TIUPNAME)
- +7 ;TYPE
- SET TIUREC(8925.1,"?+1,",.04)=$GET(TIUTYPE)
- +8 ;CLASS OWNER
- SET TIUREC(8925.1,"?+1,",.06)=$GET(TIUCLCOR)
- +9 ;STATUS 11=ACTIVE, 13=INACTIVE
- SET TIUREC(8925.1,"?+1,",.07)=$GET(TIUSTAT)
- +10 ;NAT'L STD 1=YES
- SET TIUREC(8925.1,"?+1,",.13)=$GET(TIUNATTL)
- +11 ;OK TO DISTR=YES
- SET TIUREC(8925.1,"?+1,",3.02)=1
- +12 ;TIMESTAMP
- SET TIUREC(8925.1,"?+1,",99)=$HOROLOG
- +13 DO UPDATE^DIE("","TIUREC","TIUDA","TIUERR")
- +14 QUIT +$GET(TIUDA(1))
- +15 ;
- INSTALL(TIUDNM,TIUPRNT,TIUMNTXT) ; Install document definition
- +1 ;TIUDNM - title IEN, TIUPRNT - parent IEN, TIUMNTXT - menu text
- +2 NEW TIU,TIUIEN,TIUMSG,TIUJ
- +3 SET TIU(8925.14,"?+1,"_TIUPRNT_",",.01)=TIUDNM
- +4 ;$G b/c menu text not defined for Doc Class
- SET TIU(8925.14,"?+1,"_TIUPRNT_",",4)=$GET(TIUMNTXT)
- +5 DO UPDATE^DIE("","TIU","TIUIEN","TIUMSG")
- +6 IF $DATA(TIUMSG)
- Begin DoDot:1
- +7 DO BMES^XPDUTL("The following error message was returned:")
- +8 SET TIUJ=""
- FOR
- SET TIUJ=$ORDER(TIUMSG("DIERR",1,"TEXT",TIUJ))
- if TIUJ=""
- QUIT
- DO MES^XPDUTL(" "_$GET(TIUMSG("DIERR",1,"TEXT",TIUJ)))
- End DoDot:1
- +9 QUIT +$GET(TIUIEN(1))
- UPDATE(TIUDA,TIUREC,TIUERR) ; call FileMan Filer to update record
- +1 NEW TIUIENS,TIUFLAGS,TIUFDA,TIUFPRIV,TIUFWHO,TIUFI
- +2 SET TIUFPRIV=1
- SET TIUFWHO="N"
- SET TIUIENS=TIUDA_","
- SET TIUFI=0
- +3 FOR
- SET TIUFI=$ORDER(TIUREC(TIUFI))
- if +TIUFI'>0
- QUIT
- Begin DoDot:1
- +4 SET TIUFDA(8925.1,TIUIENS,TIUFI)=$GET(TIUREC(TIUFI))
- End DoDot:1
- +5 ;External, Transaction (all or nothing)
- SET TIUFLAGS="ET"
- +6 DO FILE^DIE(TIUFLAGS,"TIUFDA","TIUERR")
- +7 QUIT
- MAP ; Map HT Titles to appropriate VHA Enterprise Standard Titles
- +1 NEW TIUERR,TIUIENS,TIUFLAGS,TIUFDA,TIUFPRIV,TIUFWHO,TIUPROD,TIUI,TITLESTR
- +2 DO BMES^XPDUTL("Attempting to map TIU*1*290 titles to VHA Enterprise Standard Titles...")
- +3 SET TIUPROD=$$PROD^XUPROD(1)
- SET TIUFPRIV=1
- SET TIUFWHO="N"
- +4 FOR TIUI=1:1
- SET TITLESTR=$PIECE($TEXT(TITLES+TIUI),";",3)
- if TITLESTR="EOL"
- QUIT
- Begin DoDot:1
- +5 NEW TIUDA,TIUTTL1,TIUETTL,TIUREC,TIUERR
- +6 SET TIUTTL1=$PIECE(TITLESTR,U)
- if TIUTTL1']""
- QUIT
- +7 SET TIUDA=$$LU(8925.1,TIUTTL1,"X","I $P(^TIU(8925.1,+Y,0),U,4)=""DOC""")
- +8 IF +TIUDA'>0
- DO BMES^XPDUTL(" "_TIUTTL1_" title not installed.")
- QUIT
- +9 SET TIUIENS=TIUDA_","
- SET TIUETTL=$PIECE(TITLESTR,U,2)
- +10 SET TIUFDA(8925.1,TIUIENS,1501)=TIUETTL
- +11 SET TIUFDA(8925.1,TIUIENS,1502)=$$FMTE^XLFDT($$NOW^XLFDT)
- +12 SET TIUFDA(8925.1,TIUIENS,1503)="`"_DUZ
- +13 SET TIUFLAGS="ET"
- +14 DO FILE^DIE(TIUFLAGS,"TIUFDA","TIUERR")
- +15 ; if filing error occurs, write message to install log & quit
- +16 IF $DATA(TIUERR)
- Begin DoDot:2
- +17 if TIUPROD
- DO BMES^XPDUTL(" Unable to map "_TIUTTL1_" title")
- IF 1
- +18 if TIUPROD
- DO MES^XPDUTL(" to "_TIUETTL_". You'll have to manually map the title.")
- +19 if TIUPROD
- DO MES^XPDUTL(" "_$GET(TIUERR("DIERR",1,"TEXT",1)))
- +20 KILL TIUFDA(8925.1,TIUIENS)
- End DoDot:2
- QUIT
- +21 ; otherwise activate title
- +22 SET TIUFDA(8925.1,TIUIENS,".07")="ACTIVE"
- +23 DO FILE^DIE(TIUFLAGS,"TIUFDA","TIUERR")
- +24 ; if filing error occurs, write message to install log
- +25 IF $DATA(TIUERR)
- IF TIUPROD
- Begin DoDot:2
- +26 DO BMES^XPDUTL(" Unable to Activate "_TIUTTL1_" TITLE.")
- +27 DO MES^XPDUTL(" "_$GET(TIUERR("DIERR",1,"TEXT",1)))
- +28 KILL TIUFDA(8925.1,TIUIENS)
- End DoDot:2
- QUIT
- +29 ; finally, check for entry in "ACL" cross-reference and if missing, call EN^DIK
- +30 IF +$ORDER(^TIU(8925.1,"ACL",3,TIUTTL1,0))'>0
- Begin DoDot:2
- +31 NEW DIK,DA
- SET DIK="^TIU(8925.1,"
- SET DIK(1)=".07^ACL07"
- SET DA=TIUDA
- DO EN^DIK
- End DoDot:2
- End DoDot:1
- +32 QUIT
- REINDEX ; Re-index entries
- +1 NEW DIK
- +2 DO BMES^XPDUTL(" Reindexing TIU Titles")
- +3 SET DIK="^TIU(8925.1,"
- SET DIK(1)=".07^AS"
- +4 DO ENALL2^DIK
- +5 SET DIK="^TIU(8925.1,"
- SET DIK(1)=".07^AS"
- +6 DO ENALL^DIK
- +7 QUIT
- RMVTSK ;Task clean-up of 8928 file if greater than 500 entries
- +1 NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK
- +2 SET ZTRTN="RMV8928^TIUP290"
- +3 SET ZTDESC="TIU PATCH 290 COPY/PASTE 8928 CLEAN-UP"
- +4 SET ZTDTH=$HOROLOG
- +5 SET ZTIO=""
- +6 DO ^%ZTLOAD
- +7 IF '$DATA(ZTSK)
- DO MES^XPDUTL(" Failed to task off Copy/Paste removal of bad data in file 8928!")
- +8 IF $DATA(ZTSK)
- DO MES^XPDUTL(" Task #"_ZTSK_" created to clean-up data in file 8928!!")
- +9 QUIT
- RMV8928 ;Clean-up 8928 file entries in contain fields .13 or .14 data
- +1 NEW TIUIEN,TIUP0
- +2 SET TIUIEN=""
- +3 FOR
- SET TIUIEN=$ORDER(^TIUP(8928,TIUIEN))
- if TIUIEN=""
- QUIT
- Begin DoDot:1
- +4 SET TIUP0=$GET(^TIUP(8928,TIUIEN,0))
- +5 IF $PIECE(TIUP0,U,13)=""
- IF $PIECE(TIUP0,U,14)=""
- QUIT
- +6 SET $PIECE(^TIUP(8928,TIUIEN,0),U,12,14)=$PIECE(TIUP0,U,12)
- End DoDot:1
- +7 QUIT
- +8 ;
- SETCNLK ;set TIU TEMPLATE CONSULT LOCK param vals on post-init
- +1 NEW TIUERR,SRVCNT,INDEX,TIUIEN,TIUOUT,TIU0,TIU01
- +2 ;get templates beginning with "NON VA CARE HCPS "
- DO FIND^DIC(8927,"","@;.01;IX","","NON VA CARE HCPS ","*","B","","","TIUOUT")
- +3 IF +$GET(TIUOUT("DILIST",0))=0
- Begin DoDot:1
- +4 DO BMES^XPDUTL("No TIU TEMPLATES beginning with ""NON VA CARE HCPS "" were found.")
- +5 DO MES^XPDUTL("No values have been added to the TIU TEMPLATE CONSULT LOCK parameter.")
- +6 DO MES^XPDUTL("No consult templates have been locked as read-only.")
- +7 DO MES^XPDUTL("Please enter a help desk ticket for assistance with TIU*1*290.")
- +8 DO MES^XPDUTL("The ticket should request assistance with locking TIU Templates that are")
- +9 DO MES^XPDUTL("used in NON VA CARE HCPS consults which are transmitted to RAS.")
- End DoDot:1
- QUIT
- +10 SET SRVCNT=$PIECE(TIUOUT("DILIST",0),U)
- SET INDEX=""
- +11 DO BMES^XPDUTL("Checking TIU TEMPLATE CONSULT LOCK parameter for existing values.")
- +12 FOR
- SET INDEX=$ORDER(TIUOUT("DILIST",2,INDEX))
- if INDEX=""
- QUIT
- Begin DoDot:1
- +13 SET TIUIEN=TIUOUT("DILIST",2,INDEX)
- +14 SET TIU0=^TIU(8927,TIUIEN,0)
- +15 if $PIECE(TIU0,U,19)'["GMR(123.5"
- QUIT
- +16 SET TIU01=$PIECE(TIU0,U)
- +17 IF '$$CHEKPAR(TIU01)
- Begin DoDot:2
- +18 DO BMES^XPDUTL("Setting parameter value for "_TIU01)
- +19 DO SETPAR(TIU01,INDEX)
- +20 DO SETTLOCK(TIUIEN)
- +21 DO SETFLOCK(TIUIEN)
- +22 DO BMES^XPDUTL("....done")
- End DoDot:2
- +23 IF '$TEST
- DO MES^XPDUTL("Parameter already set for "_TIU01)
- End DoDot:1
- +24 QUIT
- +25 ;
- SETPAR(TIUNAME,TIUINST) ;set it
- +1 NEW TIUERR
- +2 DO EN^XPAR("SYS","TIU TEMPLATE CONSULT LOCK",TIUINST,TIUNAME,.TIUERR)
- +3 IF $GET(TIUERR)>0
- DO BMES^XPDUTL("Error setting parameter value for "_TIUNAME)
- DO ERROR
- QUIT
- +4 QUIT
- +5 ;
- ERROR ; show it
- +1 DO BMES^XPDUTL("ERROR #"_$PIECE(TIUERR,U))
- +2 DO MES^XPDUTL("TEXT: "_$PIECE(TIUERR,U,2))
- +3 QUIT
- +4 ;
- CHEKPAR(TIUNAME) ;check for param value
- +1 ;return ISPAR: 1 if value exists, 0 if not
- +2 NEW TIUY,TIUERR,IDX,ISPAR
- +3 SET ISPAR=0
- SET IDX=""
- +4 DO GETLST^XPAR(.TIUY,"SYS","TIU TEMPLATE CONSULT LOCK","N")
- +5 if +$GET(TIUY)=0
- QUIT ISPAR
- +6 FOR
- SET IDX=$ORDER(TIUY(IDX))
- if IDX=""!(ISPAR=1)
- QUIT
- Begin DoDot:1
- +7 if $PIECE(TIUY(IDX),U,2)=$GET(TIUNAME)
- SET ISPAR=1
- End DoDot:1
- +8 QUIT ISPAR
- +9 ;
- SETTLOCK(IEN) ;set template lock
- +1 NEW TIUARY,TIUCNT
- +2 DO BLD(IEN,.TIUARY)
- +3 NEW DIE,DA,DR
- SET DIE="^TIU(8927,"
- SET DR=".2///YES"
- +4 FOR TIUCNT=1:1
- if '$DATA(TIUARY(TIUCNT))
- QUIT
- Begin DoDot:1
- +5 SET DA=TIUARY(TIUCNT)
- +6 LOCK +^TIU(8927,DA):DILOCKTM
- +7 IF $TEST
- if +$GET(DA)>0
- DO ^DIE
- LOCK -^TIU(8927,DA)
- End DoDot:1
- +8 QUIT
- +9 ;
- SETFLOCK(IEN) ;set template field lock
- +1 NEW DIE,DA,DR,TIUARY,TIUCNT
- +2 KILL ^TMP("TIU F",$JOB)
- +3 DO BLD(IEN,.TIUARY)
- +4 ;populates ^TMP("TIU F",$J
- DO FLD
- +5 SET TIUCNT=""
- SET DIE="^TIU(8927.1,"
- SET DR=".17///YES"
- +6 FOR
- SET TIUCNT=$ORDER(^TMP("TIU F",$JOB,TIUCNT))
- if TIUCNT=""
- QUIT
- Begin DoDot:1
- +7 SET DA=$ORDER(^TIU(8927.1,"B",^TMP("TIU F",$JOB,TIUCNT),""))
- +8 LOCK +^TIU(8927.1,DA):DILOCKTM
- +9 IF $TEST
- if +$GET(DA)>0
- DO ^DIE
- LOCK -^TIU(8927.1,DA)
- End DoDot:1
- +10 KILL ^TMP("TIU F",$JOB)
- +11 QUIT
- +12 ;
- FLD ;build list of template fields
- +1 ;TIUARY set in call to BLD
- +2 KILL ^TMP("TIU FIELDS",$JOB)
- +3 NEW TIUY,TIUFLD,CNT,CNT2,CNT3
- SET (CNT,CNT2)=""
- SET CNT3=1
- +4 FOR
- SET CNT=$ORDER(TIUARY(CNT))
- if CNT=""
- QUIT
- Begin DoDot:1
- +5 ;TIUY = name of ^TMP(TIU TEMPLATE,$J)
- DO GETBOIL^TIUSRVT(.TIUY,(TIUARY(CNT)))
- +6 FOR
- SET CNT2=$ORDER(@TIUY@(CNT2))
- if CNT2=""
- QUIT
- Begin DoDot:2
- +7 ;get every line; possible to have remnant of a wrapped field e.g. "40x2}"
- SET ^TMP("TIU FIELDS",$JOB,CNT3)=@TIUY@(CNT2)
- SET CNT3=CNT3+1
- End DoDot:2
- End DoDot:1
- +8 NEW BEG,END,FIELD,LINE,LNCNT,I,OK,LNWRAP
- KILL ^TMP("TIU F",$JOB)
- SET LNCNT=1
- SET OK=1
- SET I=""
- SET LNWRAP=""
- +9 FOR
- SET CNT=$ORDER(^TMP("TIU FIELDS",$JOB,CNT))
- if CNT=""
- QUIT
- Begin DoDot:1
- +10 SET LINE=^TMP("TIU FIELDS",$JOB,CNT)
- +11 ;if length, may need to finish building FLD from previous line of text
- IF $LENGTH(LNWRAP)>0
- SET LINE=LNWRAP_LINE
- SET LNWRAP=""
- +12 FOR
- Begin DoDot:2
- +13 ;didn't find {FLD:, possible fragmented line
- SET BEG=$FIND(LINE,"{FLD:")
- IF BEG=0
- SET END=0
- QUIT
- +14 SET END=$FIND(LINE,"}",BEG)
- +15 ; assume a fragment of a FLD, concatenate and check next LINE in template.
- if END=0
- SET LNWRAP=LINE
- +16 if END=0
- QUIT
- +17 SET FIELD=$EXTRACT(LINE,BEG,(END-2))
- +18 SET OK=1
- SET I=""
- +19 ;prevent dups in ^TMP("TIU F"
- FOR
- SET I=$ORDER(^TMP("TIU F",$JOB,I))
- if I=""!(OK=0)
- QUIT
- Begin DoDot:3
- +20 ;keep out some junk that GUI editor allows
- if (FIELD["{FLD")!(FIELD?.E1"}")
- SET OK=0
- QUIT
- +21 if ^TMP("TIU F",$JOB,I)=FIELD
- SET OK=0
- End DoDot:3
- +22 if OK
- SET ^TMP("TIU F",$JOB,LNCNT)=FIELD
- SET LNCNT=LNCNT+1
- +23 SET LINE=$EXTRACT(LINE,(END),999)
- End DoDot:2
- if END=0
- QUIT
- End DoDot:1
- +24 KILL ^TMP("TIU FIELDS",$JOB)
- +25 QUIT
- BLD(TIUIEN,TIUARY) ; Build array of templates.
- +1 NEW TIUIDX
- +2 SET TIUIDX=$ORDER(TIUARY(" "),-1)+1
- +3 SET TIUARY(TIUIDX)=TIUIEN
- +4 SET TIUIDX=0
- +5 FOR
- SET TIUIDX=$ORDER(^TIU(8927,TIUIEN,10,TIUIDX))
- if 'TIUIDX
- QUIT
- Begin DoDot:1
- +6 DO BLD($PIECE(^TIU(8927,TIUIEN,10,TIUIDX,0),U,2),.TIUARY)
- End DoDot:1
- +7 QUIT
- +8 ;
- TITLES ;TITLE ^ VHA ENT STD TITLE ^ MENU TEXT ^ PARENT DOC CLASS TYPE
- +1 ;;HEALTHELIVING ASSESSMENT SUMMARY^RISK ASSESSMENT SCREENING NOTE^Healthelvg Asmnt Sum^R
- +2 ;;PREGNANCY STATUS UPDATE REVIEW^WOMENS HEALTH NOTE^Preg Status Upd Rev^T
- +3 ;;LACTATION STATUS UPDATE REVIEW^WOMENS HEALTH NOTE^Lact Status Upd Rev^T
- +4 ;;SMART BREAST IMAGING FOLLOW-UP^WOMENS HEALTH NOTE^Smart Brst Img F/u^S
- +5 ;;SMART PATIENT NOTIFICATION^WOMENS HEALTH NOTE^Smart Patient Notif^S
- +6 ;;SMART OUTSIDE BREAST IMAGE RESULTS^WOMENS HEALTH NOTE^Smrt Out Brst Img Rs^S
- +7 ;;EOL
- DOCCLASS ;CLASS NAME ^ IEN VARIABLE NAME
- +1 ;;SMART NOTES^TIUSMTDC
- +2 ;;WOMEN'S HEALTH NOTES^TIUWHNDC
- +3 ;;EOL