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

BSTSDTS5.m

Go to the documentation of this file. 
  1. BSTSDTS5 ;GDIT/HS/BEE-Standard Terminology DTS Calls/Processing ; 5 Nov 2012  9:53 AM
  1.  ;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
  1.  ;
  1.  Q
  1.  ;
  1. CDST ;EP - Update IHS Standard Terminology Codeset
  1.  ;
  1.  ;Tasked by BSTSVRSC, tab CCHK.  Var NMIEN should be set
  1.  ;
  1.  S NMIEN=$G(NMIEN) I NMIEN="" Q
  1.  ;
  1.  ;Lock
  1.  L +^BSTS(9002318.1,0):0 E  Q
  1.  ;
  1.  NEW BSTSWS,RESULT,NMID,STS,VRSN,BSTS,ICONC,CIEN,X1,X2,X,NVIEN,NVLCL,MFAIL,FWAIT,TRY,FCNT,ABORT,TRY
  1.  ;
  1.  ;Get ext codeset Id
  1.  S NMID=$$GET1^DIQ(9002318.1,NMIEN_",",.01,"I") I NMID="" G XCDST
  1.  ;
  1.  ;Update LAST VERSION CHECK so proc won't keep getting called
  1.  S BSTS(9002318.1,NMIEN_",",.05)=DT
  1.  D FILE^DIE("","BSTS","ERROR")
  1.  ;
  1.  ;Online?
  1.  S STS="" F TRY=1:1:60 D  I +STS=2 Q
  1.  . D RESET^BSTSWSV1  ;Reset the DTS link to on
  1.  . S STS=$$VERSIONS^BSTSAPI("VRSN") ;Try
  1.  . I +STS'=2 H TRY
  1.  I +STS'=2 G XCDST
  1.  ;
  1.  ;Reset Monitoring GBL
  1.  K ^XTMP("BSTSLCMP")
  1.  ;
  1.  ;Get later date
  1.  S X1=DT,X2=60 D C^%DTC
  1.  ;
  1.  ;Set Monitoring GBL
  1.  S ^XTMP("BSTSLCMP",0)=X_U_DT_U_"Cache refresh running for "_NMID
  1.  ;
  1.  ;Mark as OOD
  1.  S ^XTMP("BSTSLCMP","STS")="Marking entries as out of date"
  1.  S ICONC="" F  S ICONC=$O(^BSTS(9002318.4,"C",NMID,ICONC)) Q:ICONC=""  S CIEN="" F  S CIEN=$O(^BSTS(9002318.4,"C",NMID,ICONC,CIEN)) Q:CIEN=""  D
  1.  . NEW BSTS,ERR,LMOD
  1.  . ;
  1.  . ;Mark OOD
  1.  . S BSTS(9002318.4,CIEN_",",".12")=""
  1.  . D FILE^DIE("","BSTS","ERR")
  1.  ;
  1.  ;Make call to proc
  1.  S ^XTMP("BSTSLCMP","STS")="Performing Refresh from DTS"
  1.  S BSTSWS("NAMESPACEID")=NMID
  1.  S BSTSWS("REVIN")=$$FMTE^XLFDT(DT,"7")
  1.  S STS=$$CSTMCDST^BSTSWSV1("RESULT",.BSTSWS)
  1.  I +STS=0 G XCDST  ;Quit if update failed
  1.  I $D(^XTMP("BSTSLCMP","QUIT")) G XCDST
  1.  ;
  1.  ;Now refresh entries for codeset that have not been updated (to handle deletes)
  1.  S ICONC="" F  S ICONC=$O(^BSTS(9002318.4,"C",NMID,ICONC)) Q:ICONC=""  D  Q:$D(^XTMP("BSTSLCMP","QUIT"))
  1.  . S CIEN="" F  S CIEN=$O(^BSTS(9002318.4,"C",NMID,ICONC,CIEN)) Q:CIEN=""  D  Q:$D(^XTMP("BSTSLCMP","QUIT"))
  1.  .. NEW BSTS,ERR,TIEN,DA,DIK
  1.  .. ;
  1.  .. ;Quit if updated
  1.  .. I $$GET1^DIQ(9002318.4,CIEN_",",".12","I")]"" Q
  1.  .. ;
  1.  .. ;Update monitor
  1.  .. S ^XTMP("BSTSLCMP","STS")="Removing retired mapping "_CIEN
  1.  .. ;
  1.  .. ;First remove terms
  1.  .. S TIEN="" F  S TIEN=$O(^BSTS(9002318.3,"C",NMID,CIEN,TIEN)) Q:TIEN=""  D
  1.  ... NEW DA,DIK
  1.  ... S DA=TIEN,DIK="^BSTS(9002318.3," D ^DIK
  1.  .. ;
  1.  .. ;Remove concept
  1.  .. S DA=CIEN,DIK="^BSTS(9002318.4," D ^DIK
  1.  ;
  1.  ;Retrieve Failover Vars
  1.  S MFAIL=$$FPARMS^BSTSVOFL()
  1.  S FWAIT=$P(MFAIL,U,2)
  1.  S MFAIL=$P(MFAIL,U)
  1.  ;
  1.  ;Loop through, grab concept that mappings linked to
  1.  S ABORT=0,ICONC="" F  S ICONC=$O(^BSTS(9002318.4,"C",NMID,ICONC)) Q:ICONC=""  D  Q:$D(^XTMP("BSTSLCMP","QUIT"))
  1.  . NEW IEN
  1.  . S IEN="" F  S IEN=$O(^BSTS(9002318.4,"C",NMID,ICONC,IEN)) Q:IEN=""  D  Q:$D(^XTMP("BSTSLCMP","QUIT"))
  1.  .. NEW AS
  1.  .. S AS=0 F  S AS=$O(^BSTS(9002318.4,IEN,9,AS)) Q:'AS  D
  1.  ... NEW NODE,NM,DTS,VAR,FCNT,TRY
  1.  ... S NODE=$G(^BSTS(9002318.4,IEN,9,AS,0))
  1.  ... S ^XTMP("BSTSLCMP","STS")="Getting Association details for entry: "_ICONC
  1.  ... S NM=$P(NODE,U,2) Q:NM=""
  1.  ... S DTS=$P(NODE,U,3) Q:DTS=""
  1.  ... ;
  1.  ... ;Update entry-Hang max of 12 times
  1.  ... S (FCNT,STS)=0 F TRY=1:1:(12*MFAIL) D  I +STS=2!(STS="0^") Q
  1.  .... D RESET^BSTSWSV1  ;Reset the DTS link to on
  1.  .... S STS=$$DTSLKP^BSTSAPI("VAR",DTS_"^"_NM) I +STS=2!(STS="0^") Q
  1.  .... S FCNT=FCNT+1 I FCNT'<MFAIL D  ;Fail handling
  1.  ..... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"CDST^BSTSVRSC - Getting Assoc for entry: "_DTS)
  1.  ..... I ABORT=1 S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("CUSTOM CODESET REFRESH FAILED ON DETAIL ENTRY: "_DTS)
  1.  ..... S FCNT=0
  1.  ;
  1.  ;Check for failure
  1.  I +STS=0 G XCDST
  1.  I $D(^XTMP("BSTSLCMP","QUIT")) G XCDST
  1.  ;
  1.  ;Get current version from mult
  1.  S NVIEN=$O(^BSTS(9002318.1,NMIEN,1,"A"),-1)
  1.  S NVLCL="" I +NVIEN>0 D
  1.  . NEW DA,IENS
  1.  . S DA(1)=NMIEN,DA=+NVIEN,IENS=$$IENS^DILF(.DA)
  1.  . S NVLCL=$$GET1^DIQ(9002318.11,IENS,".01","I")
  1.  ;
  1.  ;Save CURRENT VERSION
  1.  I NVLCL]"" D
  1.  . NEW BSTS,ERROR
  1.  . S BSTS(9002318.1,NMIEN_",",.04)=NVLCL
  1.  . D FILE^DIE("","BSTS","ERROR")
  1.  ;
  1.  ;Reset Monitoring GBL
  1. XCDST NEW FAIL
  1.  S FAIL=$S($D(^XTMP("BSTSLCMP","QUIT")):1,1:0)
  1.  K ^XTMP("BSTSLCMP")
  1.  S:FAIL ^XTMP("BSTSLCMP","QUIT")=1
  1.  ;
  1.  ;Unlock
  1.  L -^BSTS(9002318.1,0)
  1.  ;
  1.  Q
  1.  ;
  1. CSTMCDST(RET,BSTSWS) ;Get list of custom codeset entries
  1.  ;
  1.  NEW SLIST,DLIST,CNT,NMID,MFAIL,FWAIT,TRY,FCNT,STS,ABORT,ERSLT,LENTRY,TR,NMIEN
  1.  ;
  1.  S NMID=$G(BSTSWS("NAMESPACEID")) Q:NMID="" 0
  1.  ;
  1.  S SLIST=$NA(^XTMP("BSTSLCMP")) ;Returned List
  1.  S DLIST=$NA(^TMP("BSTSCMCL",$J))
  1.  K @DLIST
  1.  ;
  1.  ;Retrieve Failover Variables
  1.  S MFAIL=$$FPARMS^BSTSVOFL()
  1.  S FWAIT=$P(MFAIL,U,2)
  1.  S MFAIL=$P(MFAIL,U)
  1.  ;
  1.  F TR=1:1:60 D  I +STS Q
  1.  . S (ABORT,FCNT,STS)=0 F TRY=1:1:(12*MFAIL) D  I +STS!(STS="0^") Q
  1.  .. D RESET^BSTSWSV1  ;Reset the DTS link to on
  1.  .. S STS=$$CSTMCDST^BSTSCMCL(.BSTSWS,.ERSLT) I +STS!(STS="0^") Q
  1.  .. S FCNT=FCNT+1 I FCNT'<MFAIL D  ;Fail handling
  1.  ... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"CSTMCDST^BSTSDTS3 - Calling CSTMCDST^BSTSCMCL")
  1.  ... I ABORT=1 S STS="0^" S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("CUSTOM CODESET "_NMID_" MAPPING LOOKUP FAILED")
  1.  ... S FCNT=0
  1.  . I '+STS H TR
  1.  ;
  1.  ;Quit on failure
  1.  I +STS=0 Q 0
  1.  ;
  1.  ;Get last entry
  1.  S LENTRY=$O(@DLIST@(""),-1)
  1.  ;
  1.  ;Move results to second scratch global
  1.  S CNT=0 F  S CNT=$O(@DLIST@(CNT)) Q:'CNT  S @SLIST@(CNT)=@DLIST@(CNT)
  1.  ;
  1.  ;Now loop through and process each entry
  1.  S (ABORT,CNT)=0 F  S CNT=$O(@SLIST@(CNT)) Q:'CNT  D  Q:$D(^XTMP("BSTSLCMP","QUIT"))
  1.  . NEW DTSID,VAR,TRY,FCNT,DTSNODE
  1.  . ;
  1.  . ;Get the DTSId
  1.  . S DTSNODE=$G(@SLIST@(CNT))
  1.  . S DTSID=$P(DTSNODE,U) Q:DTSID=""
  1.  . ;
  1.  . S ^XTMP("BSTSLCMP","STS")="Getting mapping details for DTSID: "_DTSID_" (Entry "_CNT_" of "_LENTRY_")"
  1.  . ;
  1.  . ;Pull detail from DTS - Hang max of 12 times
  1.  . S FCNT=0 F TRY=1:1:(12*MFAIL) D  I +STS=2!(STS="0^") Q
  1.  .. D RESET^BSTSWSV1  ;Reset the DTS link to on
  1.  .. D CLEAR^BSTSDTSC(DTSNODE,NMID) ;Clear existing entry
  1.  .. S STS=$$DTSLKP^BSTSAPI("VAR",DTSID_"^"_NMID_"^^^^1") I +STS=2!(STS="0^") Q
  1.  .. S FCNT=FCNT+1 I FCNT'<MFAIL D  ;Fail handling
  1.  ... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"CSTMCDST^BSTSDTS3 - Getting Update for entry: "_DTSID)
  1.  ... I ABORT=1 S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("CUSTOM CODESET "_NMID_" MAPPING FAILED ON DETAIL LOOKUP: "_DTSID)
  1.  ... S FCNT=0
  1.  . ;
  1.  . ;Remove entry
  1.  . K @SLIST@(CNT)
  1.  ;
  1.  Q STS
  1.  ;
  1. RCODE(BSTSWS,ACODE) ;Retrieve list of concepts in RxNorm subsets and refresh
  1.  ;
  1.  ;Input
  1.  ;BSTSWS - Array of connection settings
  1.  ;ACODE - If 1 do no process items here
  1.  ;
  1.  NEW SLIST,DLIST,SBCNT,MFAIL,FWAIT,TRY,FCNT,STS,ABORT,ERSLT,LENTRY,REVIN,X1,X2,X,RUNSTRT,TR
  1.  ;
  1.  S ACODE=$G(ACODE)
  1.  ;
  1.  ;Get the current date
  1.  S RUNSTRT=DT
  1.  ;
  1.  ;Get future date and set up revision in
  1.  S X1=DT,X2=2 D C^%DTC
  1.  S BSTSWS("REVIN")=$$FMTE^XLFDT(X,"7")
  1.  ;
  1.  S SLIST=$NA(^XTMP("BSTSLCMP")) ;Returned List
  1.  S DLIST=$NA(^TMP("BSTSCMCL",$J))
  1.  K @DLIST
  1.  ;
  1.  ;Retrieve Failover Variables
  1.  S MFAIL=$$FPARMS^BSTSVOFL()
  1.  S FWAIT=$P(MFAIL,U,2)
  1.  S MFAIL=$P(MFAIL,U)
  1.  ;
  1.  ;Get later date
  1.  S X1=DT,X2=60 D C^%DTC
  1.  ;
  1.  ;Set up Monitoring Global
  1.  I 'ACODE D
  1.  . S ^XTMP("BSTSLCMP",0)=X_U_DT_U_"RxNorm subset refresh update running - Getting list"
  1.  . K ^XTMP("BSTSLCMP","STS")
  1.  ;
  1.  ;Get list of concepts in subsets
  1.  S ^XTMP("BSTSLCMP","STS")="Generating a list of concepts in subsets"
  1.  ;
  1.  ;BSTS*1.0*8;Extra error handling
  1.  F TR=1:1:60 D  I +STS Q
  1.  .S (ABORT,FCNT,STS)=0 F TRY=1:1:(12*MFAIL) D  I +STS!(STS="0^") Q
  1.  .. D RESET^BSTSWSV1  ;Reset the DTS link to on
  1.  .. S STS=$$RCODE^BSTSCMCL(.BSTSWS,.ERSLT) I +STS!(STS="0^") Q
  1.  .. S FCNT=FCNT+1 I FCNT'<MFAIL H FWAIT S FCNT=0 ;Fail handling
  1.  .. S FCNT=FCNT+1 I FCNT'<MFAIL D  ;Fail handling
  1.  ... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"RCODE^BSTSDTS5 - Call to $$RCODE^BSTSCMCL")
  1.  ... I ABORT=1 S STS="0^" S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("RXNORM SUBSET REFRESH LOOKUP FAILED")
  1.  ... S FCNT=0
  1.  . I '+STS H TR
  1.  ;
  1.  ;Quit on failure
  1.  I +STS=0 Q 0
  1.  ;
  1.  ;Merge results to second scratch global
  1.  S SBCNT=0 F  S SBCNT=$O(@DLIST@(SBCNT)) Q:'SBCNT  D
  1.  . NEW DTSID,LAST
  1.  . S DTSID=$P(@DLIST@(SBCNT),U) Q:DTSID=""
  1.  . I $D(@SLIST@("DTS",DTSID)) Q
  1.  . S LAST=$O(@SLIST@("A"),-1)+1
  1.  . S @SLIST@(LAST)=@DLIST@(SBCNT)
  1.  . S @SLIST@("DTS",DTSID)=LAST
  1.  ;
  1.  ;Do not process if part of main update
  1.  I ACODE Q 1
  1.  ;
  1.  ;Get last entry
  1.  S LENTRY=$O(@SLIST@("A"),-1)
  1.  ;
  1.  ;Now process each entry
  1.  S (ABORT,SBCNT)=0 F  S SBCNT=$O(@SLIST@(SBCNT)) Q:'SBCNT  D  Q:$D(^XTMP("BSTSLCMP","QUIT"))
  1.  . NEW DTSID,VAR,TRY,FCNT,CIEN,SKIP
  1.  . ;
  1.  . ;Get DTSId
  1.  . S DTSID=$P(@SLIST@(SBCNT),U) Q:DTSID=""
  1.  . ;
  1.  . ;Check last modified - skip if today
  1.  . S CIEN=$O(^BSTS(9002318.4,"D",36,DTSID,""))
  1.  . S SKIP=0 I CIEN]"" D
  1.  .. NEW OOD,LMOD
  1.  .. ;
  1.  .. ;Force update of out of date concepts
  1.  .. S OOD=$$GET1^DIQ(9002318.4,CIEN_",",.11,"I") I OOD="Y" Q
  1.  .. S LMOD=$$GET1^DIQ(9002318.4,CIEN_",",.12,"I") I LMOD'<RUNSTRT S SKIP=1
  1.  .. I SKIP=1 S $P(@SLIST@(SBCNT),U,2)="Skipped"
  1.  . I SKIP Q
  1.  . ;
  1.  . S ^XTMP("BSTSLCMP","STS")="Getting concept details for DTSID: "_DTSID_" (Entry "_SBCNT_" of "_LENTRY_")"
  1.  . ;
  1.  . ;Pull detail from DTS - Hang max of 12 times
  1.  . S (ABORT,FCNT)=0 F TRY=1:1:(12*MFAIL) D  I +STS=2!(STS="0^") K @SLIST@(SBCNT) Q
  1.  .. D RESET^BSTSWSV1  ;Reset the DTS link to on
  1.  .. S STS=$$DTSLKP^BSTSAPI("VAR",DTSID_"^1552^^^^1") I +STS=2!(STS="0^") Q
  1.  .. S FCNT=FCNT+1 I FCNT'<MFAIL D  ;Fail handling
  1.  ... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"RCODE^BSTSDTS5 - Getting Update for entry: "_DTSID)
  1.  ... I ABORT=1 S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("RXNORM SUBSET REFRESH FAILED ON DETAIL LOOKUP: "_DTSID)
  1.  ... S FCNT=0
  1.  ;
  1.  ;Clear status
  1.  K ^XTMP("BSTSLCMP","STS")
  1.  ;
  1.  I 'STS Q 0
  1.  Q 1
  1.  ;
  1.  ;BSTS*1.0*8;Update RxNorm Subsets
  1. UPRSUB(GL,CONCDA,BSTSC) ;Update RxNorm subsets
  1.  ;
  1.  ;Save Subsets
  1.  ;
  1.  ;Clear out existing entries
  1.  NEW SB
  1.  S SB=0 F  S SB=$O(^BSTS(9002318.4,CONCDA,4,SB)) Q:'SB  D
  1.  . NEW DA,DIK
  1.  . S DA(1)=CONCDA,DA=SB
  1.  . S DIK="^BSTS(9002318.4,"_DA(1)_",4," D ^DIK
  1.  ;
  1.  I $D(@GL@("SUB"))>1 D
  1.  . ;
  1.  . NEW SB
  1.  . S SB="" F  S SB=$O(@GL@("SUB",SB)) Q:SB=""  D
  1.  .. ;
  1.  .. NEW DIC,X,Y,DA,X,Y,IENS,DLAYGO
  1.  .. S DA(1)=CONCDA
  1.  .. S DIC(0)="LX",DIC="^BSTS(9002318.4,"_DA(1)_",4,"
  1.  .. S X=$P($G(@GL@("SUB",SB)),U) Q:X=""
  1.  .. ;BSTS*1.0*8;Log ALL SNOMED
  1.  .. ;I X="IHS PROBLEM ALL SNOMED" S BSTSC(9002318.4,CONCDA_",",.15)="Y"
  1.  .. S DLAYGO=9002318.44 D ^DIC
  1.  .. I +Y<0 Q
  1.  .. S DA=+Y
  1.  .. S IENS=$$IENS^DILF(.DA)
  1.  .. S BSTSC(9002318.44,IENS,".02")=$$DTS2FMDT^BSTSUTIL($P($G(@GL@("SUB",SB)),U,2))
  1.  ;
  1.  ;Save NDC
  1.  ;
  1.  ;Clear out existing entries
  1.  D
  1.  . NEW NDC
  1.  . S NDC=0 F  S NDC=$O(^BSTS(9002318.4,CONCDA,7,NDC)) Q:'NDC  D
  1.  .. NEW DA,DIK
  1.  .. S DA(1)=CONCDA,DA=NDC
  1.  .. S DIK="^BSTS(9002318.4,"_DA(1)_",7," D ^DIK
  1.  I $D(@GL@("NDC"))>1 D
  1.  . ;
  1.  . NEW NDC
  1.  . S NDC="" F  S NDC=$O(@GL@("NDC",NDC)) Q:NDC=""  D
  1.  .. ;
  1.  .. NEW DIC,X,Y,DA,X,Y,IENS,DLAYGO
  1.  .. S DA(1)=CONCDA
  1.  .. S DIC(0)="L",DIC="^BSTS(9002318.4,"_DA(1)_",7,"
  1.  .. S X=$P($G(@GL@("NDC",NDC)),U) Q:X=""
  1.  .. S DLAYGO=9002318.47 D ^DIC
  1.  .. I +Y<0 Q
  1.  .. S DA=+Y
  1.  .. S IENS=$$IENS^DILF(.DA)
  1.  .. S BSTSC(9002318.47,IENS,".02")=$$DTS2FMDT^BSTSUTIL($P($G(@GL@("NDC",NDC)),U,2))
  1.  .. S BSTSC(9002318.47,IENS,".03")=$$DTS2FMDT^BSTSUTIL($P($G(@GL@("NDC",NDC)),U,3))
  1.  ;
  1.  ;Save VUID
  1.  ;
  1.  ;Clear out existing entries
  1.  D
  1.  . NEW VD
  1.  . S VD=0 F  S VD=$O(^BSTS(9002318.4,CONCDA,8,VD)) Q:'VD  D
  1.  .. NEW DA,DIK
  1.  .. S DA(1)=CONCDA,DA=VD
  1.  .. S DIK="^BSTS(9002318.4,"_DA(1)_",8," D ^DIK
  1.  I $D(@GL@("VUID"))>1 D
  1.  . ;
  1.  . NEW VD
  1.  . S VD="" F  S VD=$O(@GL@("VUID",VD)) Q:VD=""  D
  1.  .. ;
  1.  .. NEW DIC,X,Y,DA,X,Y,IENS,DLAYGO
  1.  .. S DA(1)=CONCDA
  1.  .. S DIC(0)="L",DIC="^BSTS(9002318.4,"_DA(1)_",8,"
  1.  .. S X=$P($G(@GL@("VUID",VD)),U) Q:X=""
  1.  .. S DLAYGO=9002318.48 D ^DIC
  1.  .. I +Y<0 Q
  1.  .. S DA=+Y
  1.  .. S IENS=$$IENS^DILF(.DA)
  1.  .. S BSTSC(9002318.48,IENS,".02")=$$DTS2FMDT^BSTSUTIL($P($G(@GL@("VUID",VD)),U,2))
  1.  .. S BSTSC(9002318.48,IENS,".03")=$$DTS2FMDT^BSTSUTIL($P($G(@GL@("VUID",VD)),U,3))
  1.  ;
  1.  ;Save TTY
  1.  ;
  1.  ;Clear out existing entries
  1.  D
  1.  . NEW TTY
  1.  . S TTY=0 F  S NDC=$O(^BSTS(9002318.4,CONCDA,12,TTY)) Q:'TTY  D
  1.  .. NEW DA,DIK
  1.  .. S DA(1)=CONCDA,DA=TTY
  1.  .. S DIK="^BSTS(9002318.4,"_DA(1)_",12," D ^DIK
  1.  I $D(@GL@("TTY"))>1 D
  1.  . ;
  1.  . NEW TTY
  1.  . S TTY="" F  S TTY=$O(@GL@("TTY",TTY)) Q:TTY=""  D
  1.  .. ;
  1.  .. NEW DIC,X,Y,DA,X,Y,IENS,DLAYGO
  1.  .. S DA(1)=CONCDA
  1.  .. S DIC(0)="L",DIC="^BSTS(9002318.4,"_DA(1)_",12,"
  1.  .. S X=$P($G(@GL@("TTY",TTY)),U) Q:X=""
  1.  .. S DLAYGO=9002318.412 D ^DIC
  1.  .. I +Y<0 Q
  1.  .. S DA=+Y
  1.  .. S IENS=$$IENS^DILF(.DA)
  1.  .. S BSTSC(9002318.412,IENS,".02")=$$DTS2FMDT^BSTSUTIL($P($G(@GL@("TTY",TTY)),U,2))
  1.  .. S BSTSC(9002318.412,IENS,".03")=$$DTS2FMDT^BSTSUTIL($P($G(@GL@("TTY",TTY)),U,3))
  1.  ;
  1.  Q