- 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 Feb 19, 2025@00:05:55 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 ;