Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: TIUP290

TIUP290.m

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