INTENV1 ;bar; 26 Feb 97 18:07; Purge modules for GIS Environment Mgmt
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
Q
;
TPURGE(INPURGE,INTT) ; purge transactions from UIF based on criteria
; input: INPURGE = amount of time to keep data, required
; format: nL where n = number and L is a letter
; D = days, H = hours, M = minutes
; INTT = Transaction Type filter value (text with wild cards)
; example: "HL TEST*", optional
; can also pass in the array already built
N DIK,DA,INC,INP,INX,INX0
S INP=INPURGE,INPURGE=$$PDATE($G(INPURGE)) Q:'INPURGE
S:$L($G(INTT)) %=$$TTCONV(INTT,.INTT)
S INX=0,INC=0,DIK="^INTHU(" F S INX=$O(^INTHU(INX)) Q:'INX D
. I '$L($G(^INTHU(INX,0))) K ^INTHU(INX) Q
. S INX0=^INTHU(INX,0) Q:$P(INX0,U,14)'<INPURGE
. I $D(INTT) Q:'$D(INTT(+$P(INX0,U,11)))
. D REMSCH(+$P(INX0,U,16),$P(INX0,U,19),$P(INX0,U,2),INX)
. S DA=INX D ^DIK
. S INC=INC+1 I INC>20 S INC=0 H 1
; purge formatter jobs if INTT is defined
D:$D(INTT) FPURGE(INP,.INTT)
Q
;
TDPURGE(INPURGE,INDEST) ; purge transactions from UIF based on criteria
; input: INPURGE = amount of time to keep data, required
; format: nL where n = number and L is a letter
; D = days, H = hours, M = minutes
; INDEST = DESTINATION ien
N DIK,DA,INC,INQ,INX,INX0
S ZTSK=+$G(ZTSK)
S INPURGE=$$PDATE($G(INPURGE)) Q:'INPURGE
S INC=0,INQ="^INLHDEST("_INDEST_")",DIK="^INTHU("
F S INQ=$Q(@INQ) Q:$QS(INQ,1)'=INDEST S INX=$QS(INQ,4) D
. I '$L($G(^INTHU(INX,0))) K ^INTHU(INX),@INQ Q
. S INX0=^INTHU(INX,0) Q:$P(INX0,U,14)'<INPURGE
. D REMSCH(+$P(INX0,U,16),$P(INX0,U,19),$P(INX0,U,2),INX)
. S INC=INC+1 I INC>20 S INC=0 H 1
. S DA=INX D ^DIK
Q
;
EPURGE(INPURGE,INCON) ; purge GIS errors
; input: INPURGE = amount of data to keep, required
; format: nL where n = number and L is a letter
; D = days, H = hours, M = minutes
; INCON = flag to consolidate remaining errors 1 = YES,
; 0 = NO, default is no
;
N DIK,DA,INC,INX,INX0,INXP,INCONT,INDIR
S INPURGE=$$PDATE($G(INPURGE)) Q:'INPURGE K ^UTILITY($J,"ERR")
S INCON=+$G(INCON),INX=" ",INC=0,DIK="^INTHER("
F S INX=$O(^INTHER(INX),-1) Q:'INX D
. I '$L($G(^INTHER(INX,0))) K ^INTHER(INX) Q
. ; INXP flag tell whether data should purge
. S INX0=^INTHER(INX,0),INXP=$P(INX0,U)'>INPURGE
. I 'INXP,INCON D
.. ; criteria: TTien ^ BCFien ^ first_50_chars_of_error_msg
.. S INCONT=$P(INX0,U,2)_U_$P(INX0,U,11)_U_$E($G(^INTHER(INX,2,1,0)),1,50)
.. Q:'$L($TR(INCONT,"^"))
.. I $D(^UTILITY($J,"ERR",INCONT)) S INXP=1 Q
.. S ^UTILITY($J,"ERR",INCONT)=""
. Q:'INXP S DA=INX,INC=INC+1 D ^DIK I INC>20 S INC=0 H 1
K ^UTILITY($J,"ERR")
Q
;
FPURGE(INPURGE,INTT) ; remove formatter tasks
; input: INPURGE = amount of data to keep, required
; format: nL where n = number and L is a letter
; D = days, H = hours, M = minutes
; INTT = list of TT iens to search for and remove from
; formatter queue
N DIK,DA,INX,INX0,H
S INPURGE=$$PDATE($G(INPURGE),1) Q:'INPURGE
S:$L($G(INTT)) %=$$TTCONV(INTT,.INTT)
S INX=0,DIK="^INLHFTSK("
F S INX=$O(^INLHFTSK(INX)) Q:'INX D
. S INX0=$G(^INLHFTSK(INX,0)) Q:$P(INX0,U,4)]INPURGE
. I $D(INTT) Q:'$D(INTT(+$P(INX0,U)))
. S DA=INX D ^DIK
Q
;
DPURGE ; remove destination entries with no UIF
; input: INTT = list of TT iens to search for and remove from
; formatter queue
N DIK,DA,INX,INX01
S INC=0,INQ="^INLHDEST(0)",DIK="^INTHU("
F S INQ=$Q(@INQ) Q:'$L(INQ) S INX=$QS(INQ,4) D
. K:'$L($G(^INTHU(INX,0))) ^INTHU(INX),@INQ
Q
;
REMSCH(PRIO,DTTM,DEST,DA) ; remove entries from Output and Destination queues
; input: PRIO = priority, DTTM = $H, DEST = dest ien, DA = UIF ien
Q:'$L(PRIO)!'$L(DTTM)!'$L(DEST)!'$L(DA)
K ^INLHSCH(PRIO,DTTM,DA),^INLHDEST(DEST,PRIO,DTTM,DA)
Q
;
TTCONV(INTT,INTTA) ; take a TT filter value and create an array of iens
; input: INTT = string to match TTs, can use wildcards (*)
; and minus (-) to remove selections
; INTTA = array of iens and names passed by reference
; output: returns number selected or deselected
;
N INREM,INSELECT,INCNT
S INSEL='($E(INTT)="-") S:'INSEL INTT=$E(INTT,2,$L(INTT))
I INTT'["*" S INCNT=0 D Q INCNT
. N DIC S DIC="^INRHT(",X=INTT,DIC(0)="QM"
. S Y=$$DIC^INHSYS05(DIC,X,"",DIC(0)) Q:Y<1
. I INSEL S:'$D(INTTA(Y)) INTTA(+Y)=$P(Y,U,2),INCNT=1 Q
. I $D(INTTA(Y)) K INTTA(+Y) S INCNT=-1
N F,L,N,X,Y S Y=""
; get each * piece, conv * to match any, string to match one of string
S L=$L(INTT,"*"),F=1 F I=1:1:L S X=$P(INTT,"*",I) D
. I $L(X) S Y=Y_"1"""_X_"""",F=1-(I=L)
. S:F Y=Y_"0.E",F=0
K X S X="I N?"_Y,N="",INCNT=0
F S N=$O(^INRHT("B",N)) Q:'$L(N) D
. X X E Q
. S Y=$O(^INRHT("B",N,0)) Q:'Y
. I INSEL S:'$D(INTTA(Y)) INTTA(Y)=N,INCNT=INCNT+1 Q
. I $D(INTTA(Y)) K INTTA(Y) S INCNT=INCNT-1
Q INCNT
;
CLEAN ; clear all dynamic GIS files and queues
; UIF, Error File, Formatter, Ouput Controller, Destination
; STOPALL^INHB should be called first, but can be run in uptime
N FILE,X,MESSID
S MESSID=+$G(^INTHU("MESSID"))
F FILE="^INTHU","^INTHER","^INLHFTSK","^INLHSCH","^INLHDEST" D
. L +@FILE@(0)
. S X=$P($G(@FILE@(0)),"^",1,2) K @FILE S:$L(X) @FILE@(0)=X
. L -@FILE@(0)
S:$L(MESSID) ^INTHU("MESSID")=MESSID
Q
;
SHUT ; shutdown all GIS, code copied from STOPALL^INHB, removed writes
N INDA,X
; Signal all background processes to quit
F X=1:1:100 K ^INRHB("RUN")
; shutdown active servers
S INDA=0 F S INDA=$O(^INTHPC("ACT",1,INDA)) Q:'INDA I +$P(^INTHPC(INDA,0),U,8),$$VER^INHB(INDA) S X=$$SRVRHNG^INHB(INDA)
Q
;
PDATE(X,C) ; calculate date/time to purge to based on user input
; input: X format: nl where n = number and l is a letter
; D = days, H = hours, M = minutes
; C = 0 return in FM format (default), 1 = return in ascii-$H
;
N D,H,M,T,H1,H2
S T=$$UPCASE^%ZTF($E(X,$L(X))) Q:'$L(T)!("DHM"'[T) 0
S (D,H,M)=0,@T=+X,H2=$H,H1=$P(H2,","),H2=$P(H2,",",2) D
. I D S H1=H1-D Q
. S H2=H2-(H*3600)-(M*60)
. I H2<0 S H1=H1+(H2+1\86400)-1,H2=H2#86400
I $G(C) Q H1_","_$E("00000",1,5-$L(H2))_H2
Q $$CDATH2F^%ZTFDT(H1_","_H2)
;
INTENV1 ;bar; 26 Feb 97 18:07; Purge modules for GIS Environment Mgmt
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 QUIT
+4 ;
TPURGE(INPURGE,INTT) ; purge transactions from UIF based on criteria
+1 ; input: INPURGE = amount of time to keep data, required
+2 ; format: nL where n = number and L is a letter
+3 ; D = days, H = hours, M = minutes
+4 ; INTT = Transaction Type filter value (text with wild cards)
+5 ; example: "HL TEST*", optional
+6 ; can also pass in the array already built
+7 NEW DIK,DA,INC,INP,INX,INX0
+8 SET INP=INPURGE
SET INPURGE=$$PDATE($GET(INPURGE))
IF 'INPURGE
QUIT
+9 IF $LENGTH($GET(INTT))
SET %=$$TTCONV(INTT,.INTT)
+10 SET INX=0
SET INC=0
SET DIK="^INTHU("
FOR
SET INX=$ORDER(^INTHU(INX))
IF 'INX
QUIT
Begin DoDot:1
+11 IF '$LENGTH($GET(^INTHU(INX,0)))
KILL ^INTHU(INX)
QUIT
+12 SET INX0=^INTHU(INX,0)
IF $PIECE(INX0,U,14)'<INPURGE
QUIT
+13 IF $DATA(INTT)
IF '$DATA(INTT(+$PIECE(INX0,U,11)))
QUIT
+14 DO REMSCH(+$PIECE(INX0,U,16),$PIECE(INX0,U,19),$PIECE(INX0,U,2),INX)
+15 SET DA=INX
DO ^DIK
+16 SET INC=INC+1
IF INC>20
SET INC=0
HANG 1
End DoDot:1
+17 ; purge formatter jobs if INTT is defined
+18 IF $DATA(INTT)
DO FPURGE(INP,.INTT)
+19 QUIT
+20 ;
TDPURGE(INPURGE,INDEST) ; purge transactions from UIF based on criteria
+1 ; input: INPURGE = amount of time to keep data, required
+2 ; format: nL where n = number and L is a letter
+3 ; D = days, H = hours, M = minutes
+4 ; INDEST = DESTINATION ien
+5 NEW DIK,DA,INC,INQ,INX,INX0
+6 SET ZTSK=+$GET(ZTSK)
+7 SET INPURGE=$$PDATE($GET(INPURGE))
IF 'INPURGE
QUIT
+8 SET INC=0
SET INQ="^INLHDEST("_INDEST_")"
SET DIK="^INTHU("
+9 FOR
SET INQ=$QUERY(@INQ)
IF $QSUBSCRIPT(INQ,1)'=INDEST
QUIT
SET INX=$QSUBSCRIPT(INQ,4)
Begin DoDot:1
+10 IF '$LENGTH($GET(^INTHU(INX,0)))
KILL ^INTHU(INX),@INQ
QUIT
+11 SET INX0=^INTHU(INX,0)
IF $PIECE(INX0,U,14)'<INPURGE
QUIT
+12 DO REMSCH(+$PIECE(INX0,U,16),$PIECE(INX0,U,19),$PIECE(INX0,U,2),INX)
+13 SET INC=INC+1
IF INC>20
SET INC=0
HANG 1
+14 SET DA=INX
DO ^DIK
End DoDot:1
+15 QUIT
+16 ;
EPURGE(INPURGE,INCON) ; purge GIS errors
+1 ; input: INPURGE = amount of data to keep, required
+2 ; format: nL where n = number and L is a letter
+3 ; D = days, H = hours, M = minutes
+4 ; INCON = flag to consolidate remaining errors 1 = YES,
+5 ; 0 = NO, default is no
+6 ;
+7 NEW DIK,DA,INC,INX,INX0,INXP,INCONT,INDIR
+8 SET INPURGE=$$PDATE($GET(INPURGE))
IF 'INPURGE
QUIT
KILL ^UTILITY($JOB,"ERR")
+9 SET INCON=+$GET(INCON)
SET INX=" "
SET INC=0
SET DIK="^INTHER("
+10 FOR
SET INX=$ORDER(^INTHER(INX),-1)
IF 'INX
QUIT
Begin DoDot:1
+11 IF '$LENGTH($GET(^INTHER(INX,0)))
KILL ^INTHER(INX)
QUIT
+12 ; INXP flag tell whether data should purge
+13 SET INX0=^INTHER(INX,0)
SET INXP=$PIECE(INX0,U)'>INPURGE
+14 IF 'INXP
IF INCON
Begin DoDot:2
+15 ; criteria: TTien ^ BCFien ^ first_50_chars_of_error_msg
+16 SET INCONT=$PIECE(INX0,U,2)_U_$PIECE(INX0,U,11)_U_$EXTRACT($GET(^INTHER(INX,2,1,0)),1,50)
+17 IF '$LENGTH($TRANSLATE(INCONT,"^"))
QUIT
+18 IF $DATA(^UTILITY($JOB,"ERR",INCONT))
SET INXP=1
QUIT
+19 SET ^UTILITY($JOB,"ERR",INCONT)=""
End DoDot:2
+20 IF 'INXP
QUIT
SET DA=INX
SET INC=INC+1
DO ^DIK
IF INC>20
SET INC=0
HANG 1
End DoDot:1
+21 KILL ^UTILITY($JOB,"ERR")
+22 QUIT
+23 ;
FPURGE(INPURGE,INTT) ; remove formatter tasks
+1 ; input: INPURGE = amount of data to keep, required
+2 ; format: nL where n = number and L is a letter
+3 ; D = days, H = hours, M = minutes
+4 ; INTT = list of TT iens to search for and remove from
+5 ; formatter queue
+6 NEW DIK,DA,INX,INX0,H
+7 SET INPURGE=$$PDATE($GET(INPURGE),1)
IF 'INPURGE
QUIT
+8 IF $LENGTH($GET(INTT))
SET %=$$TTCONV(INTT,.INTT)
+9 SET INX=0
SET DIK="^INLHFTSK("
+10 FOR
SET INX=$ORDER(^INLHFTSK(INX))
IF 'INX
QUIT
Begin DoDot:1
+11 SET INX0=$GET(^INLHFTSK(INX,0))
IF $PIECE(INX0,U,4)]INPURGE
QUIT
+12 IF $DATA(INTT)
IF '$DATA(INTT(+$PIECE(INX0,U)))
QUIT
+13 SET DA=INX
DO ^DIK
End DoDot:1
+14 QUIT
+15 ;
DPURGE ; remove destination entries with no UIF
+1 ; input: INTT = list of TT iens to search for and remove from
+2 ; formatter queue
+3 NEW DIK,DA,INX,INX01
+4 SET INC=0
SET INQ="^INLHDEST(0)"
SET DIK="^INTHU("
+5 FOR
SET INQ=$QUERY(@INQ)
IF '$LENGTH(INQ)
QUIT
SET INX=$QSUBSCRIPT(INQ,4)
Begin DoDot:1
+6 IF '$LENGTH($GET(^INTHU(INX,0)))
KILL ^INTHU(INX),@INQ
End DoDot:1
+7 QUIT
+8 ;
REMSCH(PRIO,DTTM,DEST,DA) ; remove entries from Output and Destination queues
+1 ; input: PRIO = priority, DTTM = $H, DEST = dest ien, DA = UIF ien
+2 IF '$LENGTH(PRIO)!'$LENGTH(DTTM)!'$LENGTH(DEST)!'$LENGTH(DA)
QUIT
+3 KILL ^INLHSCH(PRIO,DTTM,DA),^INLHDEST(DEST,PRIO,DTTM,DA)
+4 QUIT
+5 ;
TTCONV(INTT,INTTA) ; take a TT filter value and create an array of iens
+1 ; input: INTT = string to match TTs, can use wildcards (*)
+2 ; and minus (-) to remove selections
+3 ; INTTA = array of iens and names passed by reference
+4 ; output: returns number selected or deselected
+5 ;
+6 NEW INREM,INSELECT,INCNT
+7 SET INSEL='($EXTRACT(INTT)="-")
IF 'INSEL
SET INTT=$EXTRACT(INTT,2,$LENGTH(INTT))
+8 IF INTT'["*"
SET INCNT=0
Begin DoDot:1
+9 NEW DIC
SET DIC="^INRHT("
SET X=INTT
SET DIC(0)="QM"
+10 SET Y=$$DIC^INHSYS05(DIC,X,"",DIC(0))
IF Y<1
QUIT
+11 IF INSEL
IF '$DATA(INTTA(Y))
SET INTTA(+Y)=$PIECE(Y,U,2)
SET INCNT=1
QUIT
+12 IF $DATA(INTTA(Y))
KILL INTTA(+Y)
SET INCNT=-1
End DoDot:1
QUIT INCNT
+13 NEW F,L,N,X,Y
SET Y=""
+14 ; get each * piece, conv * to match any, string to match one of string
+15 SET L=$LENGTH(INTT,"*")
SET F=1
FOR I=1:1:L
SET X=$PIECE(INTT,"*",I)
Begin DoDot:1
+16 IF $LENGTH(X)
SET Y=Y_"1"""_X_""""
SET F=1-(I=L)
+17 IF F
SET Y=Y_"0.E"
SET F=0
End DoDot:1
+18 KILL X
SET X="I N?"_Y
SET N=""
SET INCNT=0
+19 FOR
SET N=$ORDER(^INRHT("B",N))
IF '$LENGTH(N)
QUIT
Begin DoDot:1
+20 XECUTE X
IF '$TEST
QUIT
+21 SET Y=$ORDER(^INRHT("B",N,0))
IF 'Y
QUIT
+22 IF INSEL
IF '$DATA(INTTA(Y))
SET INTTA(Y)=N
SET INCNT=INCNT+1
QUIT
+23 IF $DATA(INTTA(Y))
KILL INTTA(Y)
SET INCNT=INCNT-1
End DoDot:1
+24 QUIT INCNT
+25 ;
CLEAN ; clear all dynamic GIS files and queues
+1 ; UIF, Error File, Formatter, Ouput Controller, Destination
+2 ; STOPALL^INHB should be called first, but can be run in uptime
+3 NEW FILE,X,MESSID
+4 SET MESSID=+$GET(^INTHU("MESSID"))
+5 FOR FILE="^INTHU","^INTHER","^INLHFTSK","^INLHSCH","^INLHDEST"
Begin DoDot:1
+6 LOCK +@FILE@(0)
+7 SET X=$PIECE($GET(@FILE@(0)),"^",1,2)
KILL @FILE
IF $LENGTH(X)
SET @FILE@(0)=X
+8 LOCK -@FILE@(0)
End DoDot:1
+9 IF $LENGTH(MESSID)
SET ^INTHU("MESSID")=MESSID
+10 QUIT
+11 ;
SHUT ; shutdown all GIS, code copied from STOPALL^INHB, removed writes
+1 NEW INDA,X
+2 ; Signal all background processes to quit
+3 FOR X=1:1:100
KILL ^INRHB("RUN")
+4 ; shutdown active servers
+5 SET INDA=0
FOR
SET INDA=$ORDER(^INTHPC("ACT",1,INDA))
IF 'INDA
QUIT
IF +$PIECE(^INTHPC(INDA,0),U,8)
IF $$VER^INHB(INDA)
SET X=$$SRVRHNG^INHB(INDA)
+6 QUIT
+7 ;
PDATE(X,C) ; calculate date/time to purge to based on user input
+1 ; input: X format: nl where n = number and l is a letter
+2 ; D = days, H = hours, M = minutes
+3 ; C = 0 return in FM format (default), 1 = return in ascii-$H
+4 ;
+5 NEW D,H,M,T,H1,H2
+6 SET T=$$UPCASE^%ZTF($EXTRACT(X,$LENGTH(X)))
IF '$LENGTH(T)!("DHM"'[T)
QUIT 0
+7 SET (D,H,M)=0
SET @T=+X
SET H2=$HOROLOG
SET H1=$PIECE(H2,",")
SET H2=$PIECE(H2,",",2)
Begin DoDot:1
+8 IF D
SET H1=H1-D
QUIT
+9 SET H2=H2-(H*3600)-(M*60)
+10 IF H2<0
SET H1=H1+(H2+1\86400)-1
SET H2=H2#86400
End DoDot:1
+11 IF $GET(C)
QUIT H1_","_$EXTRACT("00000",1,5-$LENGTH(H2))_H2
+12 QUIT $$CDATH2F^%ZTFDT(H1_","_H2)
+13 ;
