DIPR162 ;O-OIFO/GMB-Correct NOW function ;8/31/2009
;;22.0;VA FileMan;**162**;Mar 30, 1999;Build 19
;Per VHA Directive 2004-038, this routine should not be modified.
ENV ; Environmental Check
D BMES^XPDUTL("Perform Environment Check...")
D CHKSTOP
D BMES^XPDUTL("Finished Environment Check.")
Q
CHKSTOP ;
; Check XPDENV 0 = Loading; 1 = Installing
Q:'XPDENV ; Loading Distribution - No Check
;
;
INSCHK ; Do Checks During Install Only
W $C(7)
D MES^XPDUTL("** Although Queuing is allowed - it is HIGHLY recommended that ALL Users and")
D MES^XPDUTL("VISTA Background jobs be STOPPED before installation of this patch. Failure")
D MES^XPDUTL("to do so may result in 'source routine edited' error(s). Edits will be")
D MES^XPDUTL("lost and record(s) may be left in an inconsistent state, for example,")
D MES^XPDUTL("not all Cross-Referencing completed; which in turn may cause FUTURE")
D MES^XPDUTL("VistA/FileMan Hard Errors or corrupted Data. **")
;
TMCHK ; Check to see if TaskMan is still running
S X=$$TM^%ZTLOAD
I X,'$D(^%ZTSCH("WAIT")) D
. W $C(7)
. D BMES^XPDUTL("* Warning TaskMan Has NOT Been Stopped or Placed in a WAIT State!")
;
LINH ; Check to see if Logons are Inhibited
D GETENV^%ZOSV ; $P(Y,"^",2) = Installing Volume
Q:$G(^%ZIS(14.5,"LOGON",$P(Y,"^",2)))
W $C(7)
D BMES^XPDUTL("* Warning Logons are NOT Inhibited!")
Q
POSTINIT ; Post-Init
D BMES^XPDUTL("Beginning Post-Installation...")
D BMES^XPDUTL(" I am saving routine DIDT as %DT.")
N SCR,%S,%D,ZTOS
S SCR="I 1",ZTOS=$$OSNUM^ZTMGRSET,%S="DIDT",%D="%DT" D MOVE^ZTMGRSET
N NOWX,TODAYX
S NOWX("BEFORE")="S %=$P($H,"","",2),X=DT_(%\60#60/100+(%\3600)+(%#60/10000)/100)"
S NOWX("AFTER")="N %I,%H,% D NOW^%DTC S X=%"
S TODAYX("BEFORE")="S X=DT"
S TODAYX("AFTER")="N %I,%H,% D NOW^%DTC"
I $G(^DD("FUNC",24,1))=NOWX("AFTER") D
. D BMES^XPDUTL(" The NOW function has already been corrected. No action taken.")
E D
. D BMES^XPDUTL(" I am changing ^DD(""FUNC"",24,1) to correct the NOW function.")
. S ^DD("FUNC",24,1)=NOWX("AFTER")
I $G(^DD("FUNC",25,1))=TODAYX("AFTER") D
. D BMES^XPDUTL(" The TODAY function has already been corrected. No action taken.")
E D
. D BMES^XPDUTL(" I am changing ^DD(""FUNC"",25,1) to correct the TODAY function.")
. S ^DD("FUNC",25,1)=TODAYX("AFTER")
D FIND
D BMES^XPDUTL("Finished Post-Installation.")
Q
FIND ; Find and replace NOW and TODAY code in triggers
D BMES^XPDUTL(" I am finding and replacing all NOW and TODAY code in triggers.")
N FILE,FLD,IEN,LINE,FLAG,CNT
S (FILE,CNT)=0
F S FILE=$O(^DD(FILE)) Q:'FILE D
. S FLD=0
. F S FLD=$O(^DD(FILE,FLD)) Q:'FLD D
. . S IEN=0
. . F S IEN=$O(^DD(FILE,FLD,1,IEN)) Q:'IEN D
. . . S FLAG=0
. . . I $G(^DD(FILE,FLD,1,IEN,"CREATE VALUE"))="NOW" D REPLACE("NOW","CREATE",1,.NOWX)
. . . I $G(^DD(FILE,FLD,1,IEN,"CREATE VALUE"))="TODAY" D REPLACE("TODAY","CREATE",1,.TODAYX)
. . . I $G(^DD(FILE,FLD,1,IEN,"DELETE VALUE"))="NOW" D REPLACE("NOW","DELETE",2,.NOWX)
. . . I $G(^DD(FILE,FLD,1,IEN,"DELETE VALUE"))="TODAY" D REPLACE("TODAY","DELETE",2,.TODAYX)
D BMES^XPDUTL(" I have replaced the NOW and TODAY code in "_CNT_" triggers.")
Q
REPLACE(FUNC,VAL,NODE,CODE) ;
N LINE,P1,P2,START,STOP
S START=NODE-.00001,STOP=NODE+.39999,NODE=START
F S NODE=$O(^DD(FILE,FLD,1,IEN,NODE)) Q:'NODE!(NODE>STOP) D
. S LINE=$G(^DD(FILE,FLD,1,IEN,NODE))
. Q:LINE'[CODE("BEFORE")
. I 'FLAG D
. . S FLAG=1
. . S CNT=CNT+1
. . D BMES^XPDUTL(" For TRIGGER at ^DD("_FILE_","_FLD_",1,"_IEN_", change:")
. D MES^XPDUTL(" "_FUNC_" code in node "_NODE_")")
. D MES^XPDUTL(" from: "_LINE)
. S P1=$P(LINE,CODE("BEFORE"),1)
. S P2=$P(LINE,CODE("BEFORE"),2)
. S LINE=P1_CODE("AFTER")_P2
. S ^DD(FILE,FLD,1,IEN,NODE)=LINE
. D MES^XPDUTL(" to: "_LINE)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIPR162 3858 printed Apr 09, 2024@21:49:55 Page 2
DIPR162 ;O-OIFO/GMB-Correct NOW function ;8/31/2009
+1 ;;22.0;VA FileMan;**162**;Mar 30, 1999;Build 19
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
ENV ; Environmental Check
+1 DO BMES^XPDUTL("Perform Environment Check...")
+2 DO CHKSTOP
+3 DO BMES^XPDUTL("Finished Environment Check.")
+4 QUIT
CHKSTOP ;
+1 ; Check XPDENV 0 = Loading; 1 = Installing
+2 ; Loading Distribution - No Check
if 'XPDENV
QUIT
+3 ;
+4 ;
INSCHK ; Do Checks During Install Only
+1 WRITE $CHAR(7)
+2 DO MES^XPDUTL("** Although Queuing is allowed - it is HIGHLY recommended that ALL Users and")
+3 DO MES^XPDUTL("VISTA Background jobs be STOPPED before installation of this patch. Failure")
+4 DO MES^XPDUTL("to do so may result in 'source routine edited' error(s). Edits will be")
+5 DO MES^XPDUTL("lost and record(s) may be left in an inconsistent state, for example,")
+6 DO MES^XPDUTL("not all Cross-Referencing completed; which in turn may cause FUTURE")
+7 DO MES^XPDUTL("VistA/FileMan Hard Errors or corrupted Data. **")
+8 ;
TMCHK ; Check to see if TaskMan is still running
+1 SET X=$$TM^%ZTLOAD
+2 IF X
IF '$DATA(^%ZTSCH("WAIT"))
Begin DoDot:1
+3 WRITE $CHAR(7)
+4 DO BMES^XPDUTL("* Warning TaskMan Has NOT Been Stopped or Placed in a WAIT State!")
End DoDot:1
+5 ;
LINH ; Check to see if Logons are Inhibited
+1 ; $P(Y,"^",2) = Installing Volume
DO GETENV^%ZOSV
+2 if $GET(^%ZIS(14.5,"LOGON",$PIECE(Y,"^",2)))
QUIT
+3 WRITE $CHAR(7)
+4 DO BMES^XPDUTL("* Warning Logons are NOT Inhibited!")
+5 QUIT
POSTINIT ; Post-Init
+1 DO BMES^XPDUTL("Beginning Post-Installation...")
+2 DO BMES^XPDUTL(" I am saving routine DIDT as %DT.")
+3 NEW SCR,%S,%D,ZTOS
+4 SET SCR="I 1"
SET ZTOS=$$OSNUM^ZTMGRSET
SET %S="DIDT"
SET %D="%DT"
DO MOVE^ZTMGRSET
+5 NEW NOWX,TODAYX
+6 SET NOWX("BEFORE")="S %=$P($H,"","",2),X=DT_(%\60#60/100+(%\3600)+(%#60/10000)/100)"
+7 SET NOWX("AFTER")="N %I,%H,% D NOW^%DTC S X=%"
+8 SET TODAYX("BEFORE")="S X=DT"
+9 SET TODAYX("AFTER")="N %I,%H,% D NOW^%DTC"
+10 IF $GET(^DD("FUNC",24,1))=NOWX("AFTER")
Begin DoDot:1
+11 DO BMES^XPDUTL(" The NOW function has already been corrected. No action taken.")
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 DO BMES^XPDUTL(" I am changing ^DD(""FUNC"",24,1) to correct the NOW function.")
+14 SET ^DD("FUNC",24,1)=NOWX("AFTER")
End DoDot:1
+15 IF $GET(^DD("FUNC",25,1))=TODAYX("AFTER")
Begin DoDot:1
+16 DO BMES^XPDUTL(" The TODAY function has already been corrected. No action taken.")
End DoDot:1
+17 IF '$TEST
Begin DoDot:1
+18 DO BMES^XPDUTL(" I am changing ^DD(""FUNC"",25,1) to correct the TODAY function.")
+19 SET ^DD("FUNC",25,1)=TODAYX("AFTER")
End DoDot:1
+20 DO FIND
+21 DO BMES^XPDUTL("Finished Post-Installation.")
+22 QUIT
FIND ; Find and replace NOW and TODAY code in triggers
+1 DO BMES^XPDUTL(" I am finding and replacing all NOW and TODAY code in triggers.")
+2 NEW FILE,FLD,IEN,LINE,FLAG,CNT
+3 SET (FILE,CNT)=0
+4 FOR
SET FILE=$ORDER(^DD(FILE))
if 'FILE
QUIT
Begin DoDot:1
+5 SET FLD=0
+6 FOR
SET FLD=$ORDER(^DD(FILE,FLD))
if 'FLD
QUIT
Begin DoDot:2
+7 SET IEN=0
+8 FOR
SET IEN=$ORDER(^DD(FILE,FLD,1,IEN))
if 'IEN
QUIT
Begin DoDot:3
+9 SET FLAG=0
+10 IF $GET(^DD(FILE,FLD,1,IEN,"CREATE VALUE"))="NOW"
DO REPLACE("NOW","CREATE",1,.NOWX)
+11 IF $GET(^DD(FILE,FLD,1,IEN,"CREATE VALUE"))="TODAY"
DO REPLACE("TODAY","CREATE",1,.TODAYX)
+12 IF $GET(^DD(FILE,FLD,1,IEN,"DELETE VALUE"))="NOW"
DO REPLACE("NOW","DELETE",2,.NOWX)
+13 IF $GET(^DD(FILE,FLD,1,IEN,"DELETE VALUE"))="TODAY"
DO REPLACE("TODAY","DELETE",2,.TODAYX)
End DoDot:3
End DoDot:2
End DoDot:1
+14 DO BMES^XPDUTL(" I have replaced the NOW and TODAY code in "_CNT_" triggers.")
+15 QUIT
REPLACE(FUNC,VAL,NODE,CODE) ;
+1 NEW LINE,P1,P2,START,STOP
+2 SET START=NODE-.00001
SET STOP=NODE+.39999
SET NODE=START
+3 FOR
SET NODE=$ORDER(^DD(FILE,FLD,1,IEN,NODE))
if 'NODE!(NODE>STOP)
QUIT
Begin DoDot:1
+4 SET LINE=$GET(^DD(FILE,FLD,1,IEN,NODE))
+5 if LINE'[CODE("BEFORE")
QUIT
+6 IF 'FLAG
Begin DoDot:2
+7 SET FLAG=1
+8 SET CNT=CNT+1
+9 DO BMES^XPDUTL(" For TRIGGER at ^DD("_FILE_","_FLD_",1,"_IEN_", change:")
End DoDot:2
+10 DO MES^XPDUTL(" "_FUNC_" code in node "_NODE_")")
+11 DO MES^XPDUTL(" from: "_LINE)
+12 SET P1=$PIECE(LINE,CODE("BEFORE"),1)
+13 SET P2=$PIECE(LINE,CODE("BEFORE"),2)
+14 SET LINE=P1_CODE("AFTER")_P2
+15 SET ^DD(FILE,FLD,1,IEN,NODE)=LINE
+16 DO MES^XPDUTL(" to: "_LINE)
End DoDot:1
+17 QUIT
