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

TIUCOPUT.m

Go to the documentation of this file.
  1. TIUCOPUT ;SLC/TDP - Copy/Paste API and RPC utilities ;03/22/2016 10:31
  1. ;;1.0;TEXT INTEGRATION UTILITIES;**290**;Jun 20, 1997;Build 548
  1. ;
  1. ; DBIA 10006 ^DIC
  1. ; DBIA 2051 $$FIND1^DIC
  1. ; DBIA 2056 $$GET1^DIQ
  1. ; DBIA 10103 $$FMADD^XLFDT
  1. ;
  1. DFNCHK(DFN) ;Verify user is valid
  1. N ERR
  1. Q $S(+$$FIND1^DIC(200,"","","`"_DFN,"","","ERR")>0:1,1:0)
  1. ;
  1. DTCHK(DT) ;Verify date is valid
  1. N BDD,CDTM,DD,MM,TM,VLD,X,YY,%,%H,%I
  1. I DT'?7N1"."1.6N Q 0
  1. S YY=+$E(DT,1,3)
  1. S MM=+$E(DT,4,5) I ((MM<1)!(MM>12)) Q 0
  1. S DD=+$E(DT,6,7) D Q:BDD=1 0
  1. . S BDD=0
  1. . I $S(((YY#4=0)&(MM=2)&(DD>29)):1,((YY#4'=0)&(MM=2)&(DD>28)):1,1:0) S BDD=1 Q
  1. . I $S((((MM=1)!(MM=3)!(MM=5)!(MM=7)!(MM=8)!(MM=10)!(MM=12))&(DD>31)):1,(((MM=4)!(MM=6)!(MM=9)!(MM=11))&(DD>30)):1,1:0) S BDD=1 Q
  1. . I DD<1 S BDD=1 Q
  1. S TM=+$P(DT,".",2) I (TM<0)!(TM>235959) Q 0
  1. Q 1
  1. ;
  1. UNQDT(TIUDT) ;Make sure paste date is unique
  1. N X,UNIQ
  1. S UNIQ=0
  1. I '$D(^TIU(8925.04,"B",TIUDT)) Q
  1. F X=1:1 Q:UNIQ=1 D
  1. . S TIUDT=$$FMADD^XLFDT(TIUDT,0,0,0,X)
  1. . I '$D(^TIU(8925.04,"B",TIUDT)) S UNIQ=1
  1. Q
  1. ;
  1. GDPKG(IEN,PKG,SRC) ; Package and ien are valid
  1. ; GMRC = Consults (#123)
  1. ; TIU = Text Integration Utilities (#8925)
  1. ; OR = CPRS (#100)
  1. N FILE,GBL,SRCPKG
  1. I IEN="" Q 0
  1. I PKG="" S PKG="TIU"
  1. I SRC'="P",SRC'="C" S SRC="P"
  1. ;Possibly use a parameter to get package/global list for next 2 lines.
  1. ;Can also set up file structure information if needed.
  1. I SRC="P" S SRCPKG="GMRC,TIU,OR"
  1. I SRC="C" S SRCPKG="GMRC,TIU,OR,OUT"
  1. I SRCPKG'[PKG Q 0
  1. I PKG="GMRC" S PKG="GMR",FILE=123
  1. I PKG="OR" S FILE=100
  1. I PKG="TIU" S FILE=8925
  1. S GBL="^"_PKG
  1. I '$D(@GBL@(FILE,IEN,0)) Q 0
  1. Q 1
  1. ;
  1. GDFIL(IEN,FILE,FILNM) ; File and ien are valid
  1. N GBL,DIC,ENTRY,FILIEN,X,Y
  1. I IEN="" Q 0
  1. I FILE="" S FILE="8925" ;Default to TIU DOCUMENT (#8925) file
  1. S DIC="^DIC(",DIC(0)="NOX"
  1. S X=FILE
  1. D ^DIC I (Y=-1)!(Y="") Q 0
  1. S FILIEN=$P(Y,U,1)
  1. S FILNM=$P(Y,U,2)
  1. S GBL=$$GET1^DIQ(1,FILIEN_",",1)
  1. S ENTRY=GBL_IEN_",0)"
  1. I '$D(@ENTRY) Q 0
  1. I FILE'=FILIEN S FILE=FILIEN
  1. Q 1
  1. ;
  1. VROOT(ERARY) ;Check for invalid error array
  1. I ERARY'["(" Q 0
  1. I $E(ERARY,$L(ERARY))=")",$F(ERARY,")")>($F(ERARY,"(")+1) Q 0
  1. Q 1
  1. ;
  1. ERMSG(TYPE) ;Send an error message to TIU CACS mail group
  1. ;
  1. Q
  1. ;
  1. CPYTXT(PSTXT,TIUCPRCD,C) ;FORMAT COPIED TEXT
  1. N CTMP,LN,SMPST,TXT,X
  1. S SMPST=0
  1. S X=""
  1. F S X=$O(PSTXT(TIUCPRCD,0,X)) Q:X="" D
  1. . S CTMP(TIUCPRCD,0,X)=$G(PSTXT(TIUCPRCD,0,X))
  1. S (TXT,X)=0
  1. F S X=$O(CTMP(TIUCPRCD,0,X)) Q:X="" D Q:TXT=1 ;Remove leading blank lines
  1. . I $TR($G(CTMP(TIUCPRCD,0,X))," ")]"" S TXT=1 Q
  1. . K CTMP(TIUCPRCD,0,X)
  1. S TXT=0
  1. S X=999999999
  1. F S X=$O(CTMP(TIUCPRCD,0,X),-1) Q:X=0 Q:X="" D Q:TXT=1 ;Remove trailing blank lines
  1. . I $TR($G(CTMP(TIUCPRCD,0,X))," ")]"" S TXT=1 Q
  1. . K CTMP(TIUCPRCD,0,X)
  1. S LN=0
  1. F S LN=$O(PSTXT(TIUCPRCD,0,LN)) Q:LN="" D
  1. . S C(LN)=$G(PSTXT(TIUCPRCD,0,LN))
  1. I +$O(C(0))>0 S SMPST=1
  1. Q SMPST
  1. ;
  1. RBLDARY(PSTXT,TIUCPRCD,CRGLN,PCT) ;Save new array values
  1. N ENT,ETXT,EXT,LN,LNCNT,NTXT,NOTXT,PARNT,TEXT,TIUCNT,TIULN,TIULNG
  1. N TMPARY,TXTDATA,X,CNTR,Y,SUB
  1. S (CNTR,X)=0
  1. ;F S X=$O(FSD(X)) Q:X="" D
  1. F S X=$O(PSTXT(TIUCPRCD,"Paste",X)) Q:X="" D
  1. . S CNTR=CNTR+1
  1. . I CNTR=1 S PARNT=TIUCPRCD
  1. . S ENT=($O(PSTXT(""),-1)+1)
  1. . S PSTXT(ENT,0)=$G(PSTXT(TIUCPRCD,0))
  1. . S $P(PSTXT(ENT,0),U,7)=-1
  1. . S $P(PSTXT(ENT,0),U,9)=PARNT
  1. . S Y=0
  1. . ;F S Y=$O(FSD(X,Y)) Q:Y="" D
  1. . F S Y=$O(PSTXT(TIUCPRCD,"Paste",X,Y)) Q:Y="" D
  1. .. S TXTDATA=$G(PSTXT(TIUCPRCD,"Paste",X,Y))
  1. .. ;S TIULNG=$L($G(FSD(X,Y)),CRGLN)
  1. .. S TIULNG=$L(TXTDATA,CRGLN)
  1. .. ;S TXTDATA=$G(FSD(X,Y))
  1. .. F TIULN=1:1:TIULNG D
  1. ... S SUB=$$SUB^TIUCOPSU("T",X)
  1. ... S TMPARY(X,SUB)=$P(TXTDATA,CRGLN,TIULN)
  1. . S LN=0,LNCNT=0,NOTXT=0
  1. . F S LN=$O(TMPARY(X,LN)) Q:LN="" D
  1. .. S TEXT=$G(TMPARY(X,LN))
  1. .. I TEXT="" S TEXT=" "
  1. .. I LN=1,$$TRIM^TIUCOPSU($G(TEXT),0)="" K TMPARY(X,LN) Q
  1. .. I LN>1 D
  1. ... S NOTXT=1
  1. ... S NTXT=""
  1. ... I $$TRIM^TIUCOPSU($G(TEXT),0)'="" S NOTXT=0
  1. ... I $$TRIM^TIUCOPSU($G(TEXT),0)="" D
  1. .... F NTXT=LN-1:-1:1 I $D(PSTXT(ENT,NTXT)),$$TRIM^TIUCOPSU($G(PSTXT(ENT,(NTXT))),0)'="" S NOTXT=0
  1. .... I NOTXT=1 K TMPARY(X,LN) Q
  1. .. I NOTXT=0 S LNCNT=LNCNT+1 S PSTXT(ENT,LNCNT)=$G(TMPARY(X,LN))
  1. . S ETXT=""
  1. . S LN=999999999
  1. . F S LN=$O(PSTXT(ENT,LN),-1) D Q:ETXT'=""
  1. .. S ETXT=$$TRIM^TIUCOPSU($G(PSTXT(ENT,LN)),0)
  1. .. I ((ETXT="")!(LN=0)) K PSTXT(ENT,LN)
  1. . K TMPARY
  1. Q
  1. ;