HMPLOG ; ASMR/hrubovcak - eHMP logging support ;Aug 29, 2016 20:06:27
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**2,3**;June 13, 2016;Build 15
;Per VA Directive 6402, this routine should not be modified.
;
; routine created 13 June 2016 for US15658
Q
;
NWNTRY(HMPDTIM,HMPTYP,HMPLOG) ; function, create new entry in HMP EVENT file (#80003)
; returns new entry IEN
; HMPDTIM - optional FileMan format date/time. Must be precise and have time with seconds.
; defaults to NOW if not passed or invalid
; HMPTYP - optional event type, if missing, defaults to O (other)
; HMPLOG - event log passed by reference, traversed by $QUERY for word-processing text
; array is optional, but should be passed with calling routine name and module, at minimum.
; this array will remain unchanged
;
Q:'$L($G(^HMPLOG(800003,0))) -1 ; file not installed, return out-of-bounds value
;
D DT^DICRW ; ensure minimum symbol table defined
N G,H,HMPERR,HMPLGFDA,HMPLGIEN,HMPWPTXT,IENS,J,X,Y
; handle entry creation for speed
L +^HMPLOG(800003,0):DILOCKTM ; exclusive access for new IEN
S X=$G(^HMPLOG(800003,0)),J=$P(X,U,4)+1,$P(X,U,4)=J,HMPLGIEN=$P(X,U,3)+1\1 ; make it an integer
F Q:'$D(^HMPLOG(800003,HMPLGIEN)) S HMPLGIEN=HMPLGIEN+1 ; entry IEN to be returned
S ^HMPLOG(800003,HMPLGIEN,0)=HMPLGIEN,^HMPLOG(800003,"B",HMPLGIEN,HMPLGIEN)="" ; new entry and cross-ref.
S $P(X,U,3)=HMPLGIEN,^HMPLOG(800003,0)=X L -^HMPLOG(800003,0) ; update zero node and unlock
;
S J=0 D ; create word-processing text
. I $G(HMPLOG)]"" S J=J+1,HMPWPTXT(J,0)=HMPLOG ; if root has text, save it
. S Y="HMPLOG" F S Y=$Q(@Y) Q:Y="" S X=@Y,J=J+1,HMPWPTXT(J,0)=$S($L(X):X,1:" ") ; replace blanks with spaces
. S X=$S($G(DUZ):" DUZ: "_DUZ,1:"")_" $job: "_$J_" $i: "_$I_$S($G(ZTSK):" ZTSK: "_ZTSK,1:"") ; job info
. S J=J+1,HMPWPTXT(J,0)=X,J=J+1,HMPWPTXT(J,0)=" logged: "_$$HTE^XLFDT($H)
;
S IENS=HMPLGIEN_","
S Y=$G(HMPDTIM) S:'((Y?7N)!(Y?7N1"."1.6N)&$E(Y,6,7)) Y=$$NOW^XLFDT ; must be precise date, otherwise NOW
S:'$P(Y,".",2) Y=Y+.000001 ; if no seconds, make time 00:00:01
S HMPLGFDA(800003,IENS,.02)=Y ; EVENT DATE/TIME
;
S Y=$E($G(HMPTYP)) S:'(Y?1U) Y="O" ; default to other
S HMPLGFDA(800003,IENS,.03)=Y ; TYPE OF EVENT
;
D FILE^DIE("S","HMPLGFDA","HMPERR") ; "S" flag to save HMPLGFDA array
;
I $D(HMPERR("DIERR")) D ; save new entry error data, just in case (should not happen)
. S H=$H,J=0,G="HMPERR(""DIERR"")"
. S ^TMP($T(+0),$J,H,"NEW",0)=" FileMan error, adding HMP EVENT"
. F S G=$Q(@G) Q:'(G["DIERR") S J=J+1,^TMP($T(+0),$J,H,"NEW",J)=@G
; add word-processing text
K HMPERR D WP^DIE(800003,IENS,1,"","HMPWPTXT","HMPERR")
I $D(HMPERR("DIERR")) D ; save w-p error data, just in case (should not happen)
. S H=$H,J=0,G="HMPERR(""DIERR"")"
. S ^TMP($T(+0),$J,H,"W-P",0)=" FileMan error, adding w-p text"
. F S G=$Q(@G) Q:'(G["DIERR") S J=J+1,^TMP($T(+0),$J,H,"W-P",J)=@G
;
Q HMPLGIEN ; return new log IEN
;
PRGLOG ; purge HMP EVENT file (#800003) entries older than 61 days
;
Q:'$L($G(^HMPLOG(800003,0))) ; file not installed
D DT^DICRW ; minimal symbol table
;
N DA,DIK,HMP,HMPRGLOG,J,X,Y
S J=1,HMPRGLOG(J,0)="HMP EVENT log purge started"
S J=J+1,HMPRGLOG(J,0)=" calling routine: PRGLOG^"_$T(+0)
S Y=$NA(^HMPLOG(800003,0)) ; record zero node
S J=J+1,HMPRGLOG(J,0)=" "_Y_"="_$C(34)_$G(^HMPLOG(800003,0))_$C(34)
S Y=$$NWNTRY($$NOW^XLFDT,"I",.HMPRGLOG) ; log the purge start
;
S HMP("T-61")=$$HTFM^XLFDT($H-61) ; 61 days ago, FileMan format
S HMP("DEL")=0 ; deleted count
S HMP("TTL")=0 ; total checked
S DIK="^HMPLOG(800003," ; file root
S J=0 F S J=$O(^HMPLOG(800003,J)) Q:'J D
. S HMP("TTL")=HMP("TTL")+1,Y=$G(^HMPLOG(800003,J,0)) Q:$P(Y,U,2)>HMP("T-61")
. S DA=J,HMP("DEL")=HMP("DEL")+1
. N J D ^DIK ; protect J before ^DIK call
;
K HMPRGLOG S J=1,HMPRGLOG(J,0)="HMP EVENT log purge finished"
S J=J+1,HMPRGLOG(J,0)=" Entries checked: "_HMP("TTL")
S J=J+1,HMPRGLOG(J,0)=" Entries deleted: "_HMP("DEL")
S J=J+1,HMPRGLOG(J,0)=" calling routine: PRGLOG^"_$T(+0)
S Y=$$NWNTRY($$NOW^XLFDT,"I",.HMPRGLOG) ; log the purge end
Q
;
;DE5111 begin
STK2TXT(STKTXT) ; STKTXT passed by reference, no input, 11 August 2016
; returns STKTXT where STKTXT(1) is the top, STKTXT(2) is next level, etc.
; top 2 stack levels ignored because they're in this subroutine
K STKTXT N C,J S C=1
F J=$ST-2:-1:0 S C=C+1,STKTXT(C)=" $st("_J_"): "_$ST(J,"PLACE")_">"_$ST(J,"MCODE") ; save $stack, skip top 2 levelS
Q
;DE5111 end
;DE4496 begin, module created 19 August 2016
LOGDPT(HMPDFN) ; log missing Patient information in HMP EVENT
N C,J,TXT
S C=1,TXT(C)=" missing patient DFN: "_$G(HMPDFN) ; save missing Patient data
S C=C+1,TXT(C)=" calling code from $stack: "
F J=$ST-1:-1:0 S C=C+1,TXT(C)=" $st("_J_"): "_$ST(J,"PLACE")_">"_$ST(J,"MCODE") ; save $stack, skip top level
S C=C+1,TXT(C)=" " ; blank line following word-processing text
S J=$$NWNTRY($$NOW^XLFDT,"M",.TXT) ; log event as type "missing"
;DE4496 end
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPLOG 5111 printed Sep 23, 2025@19:30:09 Page 2
HMPLOG ; ASMR/hrubovcak - eHMP logging support ;Aug 29, 2016 20:06:27
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**2,3**;June 13, 2016;Build 15
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; routine created 13 June 2016 for US15658
+5 QUIT
+6 ;
NWNTRY(HMPDTIM,HMPTYP,HMPLOG) ; function, create new entry in HMP EVENT file (#80003)
+1 ; returns new entry IEN
+2 ; HMPDTIM - optional FileMan format date/time. Must be precise and have time with seconds.
+3 ; defaults to NOW if not passed or invalid
+4 ; HMPTYP - optional event type, if missing, defaults to O (other)
+5 ; HMPLOG - event log passed by reference, traversed by $QUERY for word-processing text
+6 ; array is optional, but should be passed with calling routine name and module, at minimum.
+7 ; this array will remain unchanged
+8 ;
+9 ; file not installed, return out-of-bounds value
if '$LENGTH($GET(^HMPLOG(800003,0)))
QUIT -1
+10 ;
+11 ; ensure minimum symbol table defined
DO DT^DICRW
+12 NEW G,H,HMPERR,HMPLGFDA,HMPLGIEN,HMPWPTXT,IENS,J,X,Y
+13 ; handle entry creation for speed
+14 ; exclusive access for new IEN
LOCK +^HMPLOG(800003,0):DILOCKTM
+15 ; make it an integer
SET X=$GET(^HMPLOG(800003,0))
SET J=$PIECE(X,U,4)+1
SET $PIECE(X,U,4)=J
SET HMPLGIEN=$PIECE(X,U,3)+1\1
+16 ; entry IEN to be returned
FOR
if '$DATA(^HMPLOG(800003,HMPLGIEN))
QUIT
SET HMPLGIEN=HMPLGIEN+1
+17 ; new entry and cross-ref.
SET ^HMPLOG(800003,HMPLGIEN,0)=HMPLGIEN
SET ^HMPLOG(800003,"B",HMPLGIEN,HMPLGIEN)=""
+18 ; update zero node and unlock
SET $PIECE(X,U,3)=HMPLGIEN
SET ^HMPLOG(800003,0)=X
LOCK -^HMPLOG(800003,0)
+19 ;
+20 ; create word-processing text
SET J=0
Begin DoDot:1
+21 ; if root has text, save it
IF $GET(HMPLOG)]""
SET J=J+1
SET HMPWPTXT(J,0)=HMPLOG
+22 ; replace blanks with spaces
SET Y="HMPLOG"
FOR
SET Y=$QUERY(@Y)
if Y=""
QUIT
SET X=@Y
SET J=J+1
SET HMPWPTXT(J,0)=$SELECT($LENGTH(X):X,1:" ")
+23 ; job info
SET X=$SELECT($GET(DUZ):" DUZ: "_DUZ,1:"")_" $job: "_$JOB_" $i: "_$IO_$SELECT($GET(ZTSK):" ZTSK: "_ZTSK,1:"")
+24 SET J=J+1
SET HMPWPTXT(J,0)=X
SET J=J+1
SET HMPWPTXT(J,0)=" logged: "_$$HTE^XLFDT($HOROLOG)
End DoDot:1
+25 ;
+26 SET IENS=HMPLGIEN_","
+27 ; must be precise date, otherwise NOW
SET Y=$GET(HMPDTIM)
if '((Y?7N)!(Y?7N1"."1.6N)&$EXTRACT(Y,6,7))
SET Y=$$NOW^XLFDT
+28 ; if no seconds, make time 00:00:01
if '$PIECE(Y,".",2)
SET Y=Y+.000001
+29 ; EVENT DATE/TIME
SET HMPLGFDA(800003,IENS,.02)=Y
+30 ;
+31 ; default to other
SET Y=$EXTRACT($GET(HMPTYP))
if '(Y?1U)
SET Y="O"
+32 ; TYPE OF EVENT
SET HMPLGFDA(800003,IENS,.03)=Y
+33 ;
+34 ; "S" flag to save HMPLGFDA array
DO FILE^DIE("S","HMPLGFDA","HMPERR")
+35 ;
+36 ; save new entry error data, just in case (should not happen)
IF $DATA(HMPERR("DIERR"))
Begin DoDot:1
+37 SET H=$HOROLOG
SET J=0
SET G="HMPERR(""DIERR"")"
+38 SET ^TMP($TEXT(+0),$JOB,H,"NEW",0)=" FileMan error, adding HMP EVENT"
+39 FOR
SET G=$QUERY(@G)
if '(G["DIERR")
QUIT
SET J=J+1
SET ^TMP($TEXT(+0),$JOB,H,"NEW",J)=@G
End DoDot:1
+40 ; add word-processing text
+41 KILL HMPERR
DO WP^DIE(800003,IENS,1,"","HMPWPTXT","HMPERR")
+42 ; save w-p error data, just in case (should not happen)
IF $DATA(HMPERR("DIERR"))
Begin DoDot:1
+43 SET H=$HOROLOG
SET J=0
SET G="HMPERR(""DIERR"")"
+44 SET ^TMP($TEXT(+0),$JOB,H,"W-P",0)=" FileMan error, adding w-p text"
+45 FOR
SET G=$QUERY(@G)
if '(G["DIERR")
QUIT
SET J=J+1
SET ^TMP($TEXT(+0),$JOB,H,"W-P",J)=@G
End DoDot:1
+46 ;
+47 ; return new log IEN
QUIT HMPLGIEN
+48 ;
PRGLOG ; purge HMP EVENT file (#800003) entries older than 61 days
+1 ;
+2 ; file not installed
if '$LENGTH($GET(^HMPLOG(800003,0)))
QUIT
+3 ; minimal symbol table
DO DT^DICRW
+4 ;
+5 NEW DA,DIK,HMP,HMPRGLOG,J,X,Y
+6 SET J=1
SET HMPRGLOG(J,0)="HMP EVENT log purge started"
+7 SET J=J+1
SET HMPRGLOG(J,0)=" calling routine: PRGLOG^"_$TEXT(+0)
+8 ; record zero node
SET Y=$NAME(^HMPLOG(800003,0))
+9 SET J=J+1
SET HMPRGLOG(J,0)=" "_Y_"="_$CHAR(34)_$GET(^HMPLOG(800003,0))_$CHAR(34)
+10 ; log the purge start
SET Y=$$NWNTRY($$NOW^XLFDT,"I",.HMPRGLOG)
+11 ;
+12 ; 61 days ago, FileMan format
SET HMP("T-61")=$$HTFM^XLFDT($HOROLOG-61)
+13 ; deleted count
SET HMP("DEL")=0
+14 ; total checked
SET HMP("TTL")=0
+15 ; file root
SET DIK="^HMPLOG(800003,"
+16 SET J=0
FOR
SET J=$ORDER(^HMPLOG(800003,J))
if 'J
QUIT
Begin DoDot:1
+17 SET HMP("TTL")=HMP("TTL")+1
SET Y=$GET(^HMPLOG(800003,J,0))
if $PIECE(Y,U,2)>HMP("T-61")
QUIT
+18 SET DA=J
SET HMP("DEL")=HMP("DEL")+1
+19 ; protect J before ^DIK call
NEW J
DO ^DIK
End DoDot:1
+20 ;
+21 KILL HMPRGLOG
SET J=1
SET HMPRGLOG(J,0)="HMP EVENT log purge finished"
+22 SET J=J+1
SET HMPRGLOG(J,0)=" Entries checked: "_HMP("TTL")
+23 SET J=J+1
SET HMPRGLOG(J,0)=" Entries deleted: "_HMP("DEL")
+24 SET J=J+1
SET HMPRGLOG(J,0)=" calling routine: PRGLOG^"_$TEXT(+0)
+25 ; log the purge end
SET Y=$$NWNTRY($$NOW^XLFDT,"I",.HMPRGLOG)
+26 QUIT
+27 ;
+28 ;DE5111 begin
STK2TXT(STKTXT) ; STKTXT passed by reference, no input, 11 August 2016
+1 ; returns STKTXT where STKTXT(1) is the top, STKTXT(2) is next level, etc.
+2 ; top 2 stack levels ignored because they're in this subroutine
+3 KILL STKTXT
NEW C,J
SET C=1
+4 ; save $stack, skip top 2 levelS
FOR J=$STACK-2:-1:0
SET C=C+1
SET STKTXT(C)=" $st("_J_"): "_$STACK(J,"PLACE")_">"_$STACK(J,"MCODE")
+5 QUIT
+6 ;DE5111 end
+7 ;DE4496 begin, module created 19 August 2016
LOGDPT(HMPDFN) ; log missing Patient information in HMP EVENT
+1 NEW C,J,TXT
+2 ; save missing Patient data
SET C=1
SET TXT(C)=" missing patient DFN: "_$GET(HMPDFN)
+3 SET C=C+1
SET TXT(C)=" calling code from $stack: "
+4 ; save $stack, skip top level
FOR J=$STACK-1:-1:0
SET C=C+1
SET TXT(C)=" $st("_J_"): "_$STACK(J,"PLACE")_">"_$STACK(J,"MCODE")
+5 ; blank line following word-processing text
SET C=C+1
SET TXT(C)=" "
+6 ; log event as type "missing"
SET J=$$NWNTRY($$NOW^XLFDT,"M",.TXT)
+7 ;DE4496 end
+8 ;
