TIUCOPUT ;SLC/TDP - Copy/Paste API and RPC utilities ;03/22/2016 10:31
;;1.0;TEXT INTEGRATION UTILITIES;**290**;Jun 20, 1997;Build 548
;
; DBIA 10006 ^DIC
; DBIA 2051 $$FIND1^DIC
; DBIA 2056 $$GET1^DIQ
; DBIA 10103 $$FMADD^XLFDT
;
DFNCHK(DFN) ;Verify user is valid
N ERR
Q $S(+$$FIND1^DIC(200,"","","`"_DFN,"","","ERR")>0:1,1:0)
;
DTCHK(DT) ;Verify date is valid
N BDD,CDTM,DD,MM,TM,VLD,X,YY,%,%H,%I
I DT'?7N1"."1.6N Q 0
S YY=+$E(DT,1,3)
S MM=+$E(DT,4,5) I ((MM<1)!(MM>12)) Q 0
S DD=+$E(DT,6,7) D Q:BDD=1 0
. S BDD=0
. I $S(((YY#4=0)&(MM=2)&(DD>29)):1,((YY#4'=0)&(MM=2)&(DD>28)):1,1:0) S BDD=1 Q
. 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
. I DD<1 S BDD=1 Q
S TM=+$P(DT,".",2) I (TM<0)!(TM>235959) Q 0
Q 1
;
UNQDT(TIUDT) ;Make sure paste date is unique
N X,UNIQ
S UNIQ=0
I '$D(^TIU(8925.04,"B",TIUDT)) Q
F X=1:1 Q:UNIQ=1 D
. S TIUDT=$$FMADD^XLFDT(TIUDT,0,0,0,X)
. I '$D(^TIU(8925.04,"B",TIUDT)) S UNIQ=1
Q
;
GDPKG(IEN,PKG,SRC) ; Package and ien are valid
; GMRC = Consults (#123)
; TIU = Text Integration Utilities (#8925)
; OR = CPRS (#100)
N FILE,GBL,SRCPKG
I IEN="" Q 0
I PKG="" S PKG="TIU"
I SRC'="P",SRC'="C" S SRC="P"
;Possibly use a parameter to get package/global list for next 2 lines.
;Can also set up file structure information if needed.
I SRC="P" S SRCPKG="GMRC,TIU,OR"
I SRC="C" S SRCPKG="GMRC,TIU,OR,OUT"
I SRCPKG'[PKG Q 0
I PKG="GMRC" S PKG="GMR",FILE=123
I PKG="OR" S FILE=100
I PKG="TIU" S FILE=8925
S GBL="^"_PKG
I '$D(@GBL@(FILE,IEN,0)) Q 0
Q 1
;
GDFIL(IEN,FILE,FILNM) ; File and ien are valid
N GBL,DIC,ENTRY,FILIEN,X,Y
I IEN="" Q 0
I FILE="" S FILE="8925" ;Default to TIU DOCUMENT (#8925) file
S DIC="^DIC(",DIC(0)="NOX"
S X=FILE
D ^DIC I (Y=-1)!(Y="") Q 0
S FILIEN=$P(Y,U,1)
S FILNM=$P(Y,U,2)
S GBL=$$GET1^DIQ(1,FILIEN_",",1)
S ENTRY=GBL_IEN_",0)"
I '$D(@ENTRY) Q 0
I FILE'=FILIEN S FILE=FILIEN
Q 1
;
VROOT(ERARY) ;Check for invalid error array
I ERARY'["(" Q 0
I $E(ERARY,$L(ERARY))=")",$F(ERARY,")")>($F(ERARY,"(")+1) Q 0
Q 1
;
ERMSG(TYPE) ;Send an error message to TIU CACS mail group
;
Q
;
CPYTXT(PSTXT,TIUCPRCD,C) ;FORMAT COPIED TEXT
N CTMP,LN,SMPST,TXT,X
S SMPST=0
S X=""
F S X=$O(PSTXT(TIUCPRCD,0,X)) Q:X="" D
. S CTMP(TIUCPRCD,0,X)=$G(PSTXT(TIUCPRCD,0,X))
S (TXT,X)=0
F S X=$O(CTMP(TIUCPRCD,0,X)) Q:X="" D Q:TXT=1 ;Remove leading blank lines
. I $TR($G(CTMP(TIUCPRCD,0,X))," ")]"" S TXT=1 Q
. K CTMP(TIUCPRCD,0,X)
S TXT=0
S X=999999999
F S X=$O(CTMP(TIUCPRCD,0,X),-1) Q:X=0 Q:X="" D Q:TXT=1 ;Remove trailing blank lines
. I $TR($G(CTMP(TIUCPRCD,0,X))," ")]"" S TXT=1 Q
. K CTMP(TIUCPRCD,0,X)
S LN=0
F S LN=$O(PSTXT(TIUCPRCD,0,LN)) Q:LN="" D
. S C(LN)=$G(PSTXT(TIUCPRCD,0,LN))
I +$O(C(0))>0 S SMPST=1
Q SMPST
;
RBLDARY(PSTXT,TIUCPRCD,CRGLN,PCT) ;Save new array values
N ENT,ETXT,EXT,LN,LNCNT,NTXT,NOTXT,PARNT,TEXT,TIUCNT,TIULN,TIULNG
N TMPARY,TXTDATA,X,CNTR,Y,SUB
S (CNTR,X)=0
;F S X=$O(FSD(X)) Q:X="" D
F S X=$O(PSTXT(TIUCPRCD,"Paste",X)) Q:X="" D
. S CNTR=CNTR+1
. I CNTR=1 S PARNT=TIUCPRCD
. S ENT=($O(PSTXT(""),-1)+1)
. S PSTXT(ENT,0)=$G(PSTXT(TIUCPRCD,0))
. S $P(PSTXT(ENT,0),U,7)=-1
. S $P(PSTXT(ENT,0),U,9)=PARNT
. S Y=0
. ;F S Y=$O(FSD(X,Y)) Q:Y="" D
. F S Y=$O(PSTXT(TIUCPRCD,"Paste",X,Y)) Q:Y="" D
.. S TXTDATA=$G(PSTXT(TIUCPRCD,"Paste",X,Y))
.. ;S TIULNG=$L($G(FSD(X,Y)),CRGLN)
.. S TIULNG=$L(TXTDATA,CRGLN)
.. ;S TXTDATA=$G(FSD(X,Y))
.. F TIULN=1:1:TIULNG D
... S SUB=$$SUB^TIUCOPSU("T",X)
... S TMPARY(X,SUB)=$P(TXTDATA,CRGLN,TIULN)
. S LN=0,LNCNT=0,NOTXT=0
. F S LN=$O(TMPARY(X,LN)) Q:LN="" D
.. S TEXT=$G(TMPARY(X,LN))
.. I TEXT="" S TEXT=" "
.. I LN=1,$$TRIM^TIUCOPSU($G(TEXT),0)="" K TMPARY(X,LN) Q
.. I LN>1 D
... S NOTXT=1
... S NTXT=""
... I $$TRIM^TIUCOPSU($G(TEXT),0)'="" S NOTXT=0
... I $$TRIM^TIUCOPSU($G(TEXT),0)="" D
.... F NTXT=LN-1:-1:1 I $D(PSTXT(ENT,NTXT)),$$TRIM^TIUCOPSU($G(PSTXT(ENT,(NTXT))),0)'="" S NOTXT=0
.... I NOTXT=1 K TMPARY(X,LN) Q
.. I NOTXT=0 S LNCNT=LNCNT+1 S PSTXT(ENT,LNCNT)=$G(TMPARY(X,LN))
. S ETXT=""
. S LN=999999999
. F S LN=$O(PSTXT(ENT,LN),-1) D Q:ETXT'=""
.. S ETXT=$$TRIM^TIUCOPSU($G(PSTXT(ENT,LN)),0)
.. I ((ETXT="")!(LN=0)) K PSTXT(ENT,LN)
. K TMPARY
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUCOPUT 4482 printed Apr 09, 2024@21:42:04 Page 2
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
+2 ;
+3 ; DBIA 10006 ^DIC
+4 ; DBIA 2051 $$FIND1^DIC
+5 ; DBIA 2056 $$GET1^DIQ
+6 ; DBIA 10103 $$FMADD^XLFDT
+7 ;
DFNCHK(DFN) ;Verify user is valid
+1 NEW ERR
+2 QUIT $SELECT(+$$FIND1^DIC(200,"","","`"_DFN,"","","ERR")>0:1,1:0)
+3 ;
DTCHK(DT) ;Verify date is valid
+1 NEW BDD,CDTM,DD,MM,TM,VLD,X,YY,%,%H,%I
+2 IF DT'?7N1"."1.6N
QUIT 0
+3 SET YY=+$EXTRACT(DT,1,3)
+4 SET MM=+$EXTRACT(DT,4,5)
IF ((MM<1)!(MM>12))
QUIT 0
+5 SET DD=+$EXTRACT(DT,6,7)
Begin DoDot:1
+6 SET BDD=0
+7 IF $SELECT(((YY#4=0)&(MM=2)&(DD>29)):1,((YY#4'=0)&(MM=2)&(DD>28)):1,1:0)
SET BDD=1
QUIT
+8 IF $SELECT((((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)
SET BDD=1
QUIT
+9 IF DD<1
SET BDD=1
QUIT
End DoDot:1
if BDD=1
QUIT 0
+10 SET TM=+$PIECE(DT,".",2)
IF (TM<0)!(TM>235959)
QUIT 0
+11 QUIT 1
+12 ;
UNQDT(TIUDT) ;Make sure paste date is unique
+1 NEW X,UNIQ
+2 SET UNIQ=0
+3 IF '$DATA(^TIU(8925.04,"B",TIUDT))
QUIT
+4 FOR X=1:1
if UNIQ=1
QUIT
Begin DoDot:1
+5 SET TIUDT=$$FMADD^XLFDT(TIUDT,0,0,0,X)
+6 IF '$DATA(^TIU(8925.04,"B",TIUDT))
SET UNIQ=1
End DoDot:1
+7 QUIT
+8 ;
GDPKG(IEN,PKG,SRC) ; Package and ien are valid
+1 ; GMRC = Consults (#123)
+2 ; TIU = Text Integration Utilities (#8925)
+3 ; OR = CPRS (#100)
+4 NEW FILE,GBL,SRCPKG
+5 IF IEN=""
QUIT 0
+6 IF PKG=""
SET PKG="TIU"
+7 IF SRC'="P"
IF SRC'="C"
SET SRC="P"
+8 ;Possibly use a parameter to get package/global list for next 2 lines.
+9 ;Can also set up file structure information if needed.
+10 IF SRC="P"
SET SRCPKG="GMRC,TIU,OR"
+11 IF SRC="C"
SET SRCPKG="GMRC,TIU,OR,OUT"
+12 IF SRCPKG'[PKG
QUIT 0
+13 IF PKG="GMRC"
SET PKG="GMR"
SET FILE=123
+14 IF PKG="OR"
SET FILE=100
+15 IF PKG="TIU"
SET FILE=8925
+16 SET GBL="^"_PKG
+17 IF '$DATA(@GBL@(FILE,IEN,0))
QUIT 0
+18 QUIT 1
+19 ;
GDFIL(IEN,FILE,FILNM) ; File and ien are valid
+1 NEW GBL,DIC,ENTRY,FILIEN,X,Y
+2 IF IEN=""
QUIT 0
+3 ;Default to TIU DOCUMENT (#8925) file
IF FILE=""
SET FILE="8925"
+4 SET DIC="^DIC("
SET DIC(0)="NOX"
+5 SET X=FILE
+6 DO ^DIC
IF (Y=-1)!(Y="")
QUIT 0
+7 SET FILIEN=$PIECE(Y,U,1)
+8 SET FILNM=$PIECE(Y,U,2)
+9 SET GBL=$$GET1^DIQ(1,FILIEN_",",1)
+10 SET ENTRY=GBL_IEN_",0)"
+11 IF '$DATA(@ENTRY)
QUIT 0
+12 IF FILE'=FILIEN
SET FILE=FILIEN
+13 QUIT 1
+14 ;
VROOT(ERARY) ;Check for invalid error array
+1 IF ERARY'["("
QUIT 0
+2 IF $EXTRACT(ERARY,$LENGTH(ERARY))=")"
IF $FIND(ERARY,")")>($FIND(ERARY,"(")+1)
QUIT 0
+3 QUIT 1
+4 ;
ERMSG(TYPE) ;Send an error message to TIU CACS mail group
+1 ;
+2 QUIT
+3 ;
CPYTXT(PSTXT,TIUCPRCD,C) ;FORMAT COPIED TEXT
+1 NEW CTMP,LN,SMPST,TXT,X
+2 SET SMPST=0
+3 SET X=""
+4 FOR
SET X=$ORDER(PSTXT(TIUCPRCD,0,X))
if X=""
QUIT
Begin DoDot:1
+5 SET CTMP(TIUCPRCD,0,X)=$GET(PSTXT(TIUCPRCD,0,X))
End DoDot:1
+6 SET (TXT,X)=0
+7 ;Remove leading blank lines
FOR
SET X=$ORDER(CTMP(TIUCPRCD,0,X))
if X=""
QUIT
Begin DoDot:1
+8 IF $TRANSLATE($GET(CTMP(TIUCPRCD,0,X))," ")]""
SET TXT=1
QUIT
+9 KILL CTMP(TIUCPRCD,0,X)
End DoDot:1
if TXT=1
QUIT
+10 SET TXT=0
+11 SET X=999999999
+12 ;Remove trailing blank lines
FOR
SET X=$ORDER(CTMP(TIUCPRCD,0,X),-1)
if X=0
QUIT
if X=""
QUIT
Begin DoDot:1
+13 IF $TRANSLATE($GET(CTMP(TIUCPRCD,0,X))," ")]""
SET TXT=1
QUIT
+14 KILL CTMP(TIUCPRCD,0,X)
End DoDot:1
if TXT=1
QUIT
+15 SET LN=0
+16 FOR
SET LN=$ORDER(PSTXT(TIUCPRCD,0,LN))
if LN=""
QUIT
Begin DoDot:1
+17 SET C(LN)=$GET(PSTXT(TIUCPRCD,0,LN))
End DoDot:1
+18 IF +$ORDER(C(0))>0
SET SMPST=1
+19 QUIT SMPST
+20 ;
RBLDARY(PSTXT,TIUCPRCD,CRGLN,PCT) ;Save new array values
+1 NEW ENT,ETXT,EXT,LN,LNCNT,NTXT,NOTXT,PARNT,TEXT,TIUCNT,TIULN,TIULNG
+2 NEW TMPARY,TXTDATA,X,CNTR,Y,SUB
+3 SET (CNTR,X)=0
+4 ;F S X=$O(FSD(X)) Q:X="" D
+5 FOR
SET X=$ORDER(PSTXT(TIUCPRCD,"Paste",X))
if X=""
QUIT
Begin DoDot:1
+6 SET CNTR=CNTR+1
+7 IF CNTR=1
SET PARNT=TIUCPRCD
+8 SET ENT=($ORDER(PSTXT(""),-1)+1)
+9 SET PSTXT(ENT,0)=$GET(PSTXT(TIUCPRCD,0))
+10 SET $PIECE(PSTXT(ENT,0),U,7)=-1
+11 SET $PIECE(PSTXT(ENT,0),U,9)=PARNT
+12 SET Y=0
+13 ;F S Y=$O(FSD(X,Y)) Q:Y="" D
+14 FOR
SET Y=$ORDER(PSTXT(TIUCPRCD,"Paste",X,Y))
if Y=""
QUIT
Begin DoDot:2
+15 SET TXTDATA=$GET(PSTXT(TIUCPRCD,"Paste",X,Y))
+16 ;S TIULNG=$L($G(FSD(X,Y)),CRGLN)
+17 SET TIULNG=$LENGTH(TXTDATA,CRGLN)
+18 ;S TXTDATA=$G(FSD(X,Y))
+19 FOR TIULN=1:1:TIULNG
Begin DoDot:3
+20 SET SUB=$$SUB^TIUCOPSU("T",X)
+21 SET TMPARY(X,SUB)=$PIECE(TXTDATA,CRGLN,TIULN)
End DoDot:3
End DoDot:2
+22 SET LN=0
SET LNCNT=0
SET NOTXT=0
+23 FOR
SET LN=$ORDER(TMPARY(X,LN))
if LN=""
QUIT
Begin DoDot:2
+24 SET TEXT=$GET(TMPARY(X,LN))
+25 IF TEXT=""
SET TEXT=" "
+26 IF LN=1
IF $$TRIM^TIUCOPSU($GET(TEXT),0)=""
KILL TMPARY(X,LN)
QUIT
+27 IF LN>1
Begin DoDot:3
+28 SET NOTXT=1
+29 SET NTXT=""
+30 IF $$TRIM^TIUCOPSU($GET(TEXT),0)'=""
SET NOTXT=0
+31 IF $$TRIM^TIUCOPSU($GET(TEXT),0)=""
Begin DoDot:4
+32 FOR NTXT=LN-1:-1:1
IF $DATA(PSTXT(ENT,NTXT))
IF $$TRIM^TIUCOPSU($GET(PSTXT(ENT,(NTXT))),0)'=""
SET NOTXT=0
+33 IF NOTXT=1
KILL TMPARY(X,LN)
QUIT
End DoDot:4
End DoDot:3
+34 IF NOTXT=0
SET LNCNT=LNCNT+1
SET PSTXT(ENT,LNCNT)=$GET(TMPARY(X,LN))
End DoDot:2
+35 SET ETXT=""
+36 SET LN=999999999
+37 FOR
SET LN=$ORDER(PSTXT(ENT,LN),-1)
Begin DoDot:2
+38 SET ETXT=$$TRIM^TIUCOPSU($GET(PSTXT(ENT,LN)),0)
+39 IF ((ETXT="")!(LN=0))
KILL PSTXT(ENT,LN)
End DoDot:2
if ETXT'=""
QUIT
+40 KILL TMPARY
End DoDot:1
+41 QUIT
+42 ;
