HMP14699 ;ASMR/CK - HMP XU EVENTS Protocol an ITEM - HMP*2.0*3;Aug 24, 2016@11:35:01
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**3**;Sep 01, 2011;Build 15
;Per VA Directive 6402, this routine should not be modified.
;
; US14699 - CK - Subscribe HMP XU EVENTS protocol to XU USER CHANGE and XU USER TERMINATE
;
; External References ICR
; ------------------- -----
; ^DIC(19, 10075
; DIC(19 10156
;
Q
;
POST ; Post-init logic
N HMPRTCL,HMPIEN,V,X,Y
D MES^XPDUTL($T(+0)_" post-init routine started "_$$HTE^XLFDT($H))
S V=$$SVDATA D MES^XPDUTL("Old data saved in "_V)
S (X,HMPRTCL)="HMP XU EVENTS",DIC(0)="M",DIC=19 D ^DIC ;ICR 10156
; protocol missing, write message and exit
I '(Y>0) D MES^XPDUTL(HMPRTCL_" protocol not found. It must be installed to proceed.") Q
S HMPIEN=$P(Y,U)
D POST1,POST2
Q
;
POST1 ; add HMP XU EVENTS as an ITEM to XU USER CHANGE
N HMPDGIEN,HMPEXIT,X,Y
S X="XU USER CHANGE",DIC(0)="M",DIC=19 D ^DIC
; protocol missing, write message and exit
I '(Y>0) D MES^XPDUTL(Y_" protocol not found. No ITEM update performed.") Q
S HMPDGIEN=$P(Y,U)
;
; is protocol already an item?
S HMPEXIT=$O(^DIC(19,HMPDGIEN,10,"B",HMPIEN,0))
I HMPEXIT D MES^XPDUTL(HMPRTCL_" already an ITEM in "_Y_". No update needed.") Q
;
; add protocol as ITEM
K HMPFDA,HMPERR,PRTCLITM
S HMPFDA(19.01,"+1,"_HMPDGIEN_",",.01)=HMPIEN ; ICR 10075
D UPDATE^DIE("","HMPFDA","PRTCLITM","HMPERR")
I $D(HMPERR) D Q ; something went wrong
. D MES^XPDUTL("FileMan error when adding ITEM to XU USER CHANGE protocol")
. N V S V="HMPERR" F S V=$Q(@V) Q:V="" D MES^XPDUTL(V_" = "_@V)
; new ITEM sub-file IEN will be in PRTCLITM(1)
D MES^XPDUTL(HMPRTCL_" was subscribed to "_Y_", protocol update finished "_$$HTE^XLFDT($H))
Q
;
POST2 ; add HMP XU EVENTS as an ITEM to XU USER TERMINATE
N HMPDGIEN,HMPEXIT,X,Y
S X="XU USER TERMINATE",DIC(0)="M",DIC=19 D ^DIC
; protocol missing, write message and exit
I '(Y>0) D MES^XPDUTL(Y_" protocol not found. No ITEM update performed.") Q
S HMPDGIEN=$P(Y,U)
;
; is protocol already an item?
S HMPEXIT=$O(^DIC(19,HMPDGIEN,10,"B",HMPIEN,0))
I HMPEXIT D MES^XPDUTL(HMPRTCL_" already an ITEM in "_Y_". No update needed.") Q
;
; add protocol as ITEM
K HMPFDA,HMPERR,PRTCLITM
S HMPFDA(19.01,"+1,"_HMPDGIEN_",",.01)=HMPIEN
D UPDATE^DIE("","HMPFDA","PRTCLITM","HMPERR")
I $D(HMPERR) D Q ; something went wrong
. D MES^XPDUTL("FileMan error when adding ITEM to XU USER TERMINATE protocol")
. N V S V="HMPERR" F S V=$Q(@V) Q:V="" D MES^XPDUTL(V_" = "_@V)
; new ITEM sub-file IEN will be in PRTCLITM(1)
D MES^XPDUTL(HMPRTCL_" was subscribed to "_Y_", protocol update finished "_$$HTE^XLFDT($H))
Q
;
SVDATA() ; extrinsic variable, save original FileMan data, returns storage node
D DT^DICRW
N FMERRCNT,HMPXTMP,HMPIEN,LN,NTRY,TXT,V,X,Y
S Y=$$NOW^XLFDT,HMPXTMP=$NA(^XTMP("HMP INSTALL LOG",Y)) ; XTMP storage location
; ^XTMP log data expires in 90 days
S X=$G(@HMPXTMP@(0)) S:X="" @HMPXTMP@(0)=$$FMADD^XLFDT(DT,90)_U_Y_"^HMP installation "_$$FMTE^XLFDT(Y)
;
S FMERRCNT=0 ; FileMan error counter
; save entries in FileMan items list
F LN=1:1 S TXT=$P($T(FMITMS+LN),";;",2,99) Q:TXT="" D
. N FLNO,FMARRY,FMERR ; file #, FileMan returned value and error message arrays
. S FLNO=+$P(TXT,U),X=$P(TXT,U,2,99) ; file number and target entry
. Q:'(FLNO>1)!(X="") ; file and entry required
. S HMPIEN=$$FIND1^DIC(FLNO,"","",X,"","","FMERR") ; lookup value in X is external format
. I $D(FMERR) D Q ; log error message and quit
. . S V="FMERR",FMERRCNT=FMERRCNT+1 F S V=$Q(@V) Q:V="" S @HMPXTMP@("FM LOOKUP ERROR",FMERRCNT,V)=@V
. ;
. S:'(HMPIEN>0) FMERRCNT=FMERRCNT+1,@HMPXTMP@("FM ENTRY NOT FOUND",FMERRCNT)=TXT ; entry
. S:HMPIEN>0 @HMPXTMP@("ENTRY",FLNO,HMPIEN)="entry found"
. K FMERR ; just in case
. D GETS^DIQ(FLNO,HMPIEN_",","**","EN","FMARRY","FMERR") ; data including sub-files, ignore null values
. I $D(FMERR) D ; log error message
. . S V="FMERR",FMERRCNT=FMERRCNT+1 F S V=$Q(@V) Q:V="" S @HMPXTMP@("FM DATA ERROR",FMERRCNT,V)=@V
. ; save the data
. M @HMPXTMP@("ENTRY")=FMARRY
;
Q HMPXTMP ; return ^XTMP storage location
;
FMITMS ; list of FileMan entries: "file # ^ .01 field value"
;;19^XU USER CHANGE
;;19^XU USER TERMINATE
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMP14699 4387 printed Nov 22, 2024@17:03:07 Page 2
HMP14699 ;ASMR/CK - HMP XU EVENTS Protocol an ITEM - HMP*2.0*3;Aug 24, 2016@11:35:01
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**3**;Sep 01, 2011;Build 15
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; US14699 - CK - Subscribe HMP XU EVENTS protocol to XU USER CHANGE and XU USER TERMINATE
+5 ;
+6 ; External References ICR
+7 ; ------------------- -----
+8 ; ^DIC(19, 10075
+9 ; DIC(19 10156
+10 ;
+11 QUIT
+12 ;
POST ; Post-init logic
+1 NEW HMPRTCL,HMPIEN,V,X,Y
+2 DO MES^XPDUTL($TEXT(+0)_" post-init routine started "_$$HTE^XLFDT($HOROLOG))
+3 SET V=$$SVDATA
DO MES^XPDUTL("Old data saved in "_V)
+4 ;ICR 10156
SET (X,HMPRTCL)="HMP XU EVENTS"
SET DIC(0)="M"
SET DIC=19
DO ^DIC
+5 ; protocol missing, write message and exit
+6 IF '(Y>0)
DO MES^XPDUTL(HMPRTCL_" protocol not found. It must be installed to proceed.")
QUIT
+7 SET HMPIEN=$PIECE(Y,U)
+8 DO POST1
DO POST2
+9 QUIT
+10 ;
POST1 ; add HMP XU EVENTS as an ITEM to XU USER CHANGE
+1 NEW HMPDGIEN,HMPEXIT,X,Y
+2 SET X="XU USER CHANGE"
SET DIC(0)="M"
SET DIC=19
DO ^DIC
+3 ; protocol missing, write message and exit
+4 IF '(Y>0)
DO MES^XPDUTL(Y_" protocol not found. No ITEM update performed.")
QUIT
+5 SET HMPDGIEN=$PIECE(Y,U)
+6 ;
+7 ; is protocol already an item?
+8 SET HMPEXIT=$ORDER(^DIC(19,HMPDGIEN,10,"B",HMPIEN,0))
+9 IF HMPEXIT
DO MES^XPDUTL(HMPRTCL_" already an ITEM in "_Y_". No update needed.")
QUIT
+10 ;
+11 ; add protocol as ITEM
+12 KILL HMPFDA,HMPERR,PRTCLITM
+13 ; ICR 10075
SET HMPFDA(19.01,"+1,"_HMPDGIEN_",",.01)=HMPIEN
+14 DO UPDATE^DIE("","HMPFDA","PRTCLITM","HMPERR")
+15 ; something went wrong
IF $DATA(HMPERR)
Begin DoDot:1
+16 DO MES^XPDUTL("FileMan error when adding ITEM to XU USER CHANGE protocol")
+17 NEW V
SET V="HMPERR"
FOR
SET V=$QUERY(@V)
if V=""
QUIT
DO MES^XPDUTL(V_" = "_@V)
End DoDot:1
QUIT
+18 ; new ITEM sub-file IEN will be in PRTCLITM(1)
+19 DO MES^XPDUTL(HMPRTCL_" was subscribed to "_Y_", protocol update finished "_$$HTE^XLFDT($HOROLOG))
+20 QUIT
+21 ;
POST2 ; add HMP XU EVENTS as an ITEM to XU USER TERMINATE
+1 NEW HMPDGIEN,HMPEXIT,X,Y
+2 SET X="XU USER TERMINATE"
SET DIC(0)="M"
SET DIC=19
DO ^DIC
+3 ; protocol missing, write message and exit
+4 IF '(Y>0)
DO MES^XPDUTL(Y_" protocol not found. No ITEM update performed.")
QUIT
+5 SET HMPDGIEN=$PIECE(Y,U)
+6 ;
+7 ; is protocol already an item?
+8 SET HMPEXIT=$ORDER(^DIC(19,HMPDGIEN,10,"B",HMPIEN,0))
+9 IF HMPEXIT
DO MES^XPDUTL(HMPRTCL_" already an ITEM in "_Y_". No update needed.")
QUIT
+10 ;
+11 ; add protocol as ITEM
+12 KILL HMPFDA,HMPERR,PRTCLITM
+13 SET HMPFDA(19.01,"+1,"_HMPDGIEN_",",.01)=HMPIEN
+14 DO UPDATE^DIE("","HMPFDA","PRTCLITM","HMPERR")
+15 ; something went wrong
IF $DATA(HMPERR)
Begin DoDot:1
+16 DO MES^XPDUTL("FileMan error when adding ITEM to XU USER TERMINATE protocol")
+17 NEW V
SET V="HMPERR"
FOR
SET V=$QUERY(@V)
if V=""
QUIT
DO MES^XPDUTL(V_" = "_@V)
End DoDot:1
QUIT
+18 ; new ITEM sub-file IEN will be in PRTCLITM(1)
+19 DO MES^XPDUTL(HMPRTCL_" was subscribed to "_Y_", protocol update finished "_$$HTE^XLFDT($HOROLOG))
+20 QUIT
+21 ;
SVDATA() ; extrinsic variable, save original FileMan data, returns storage node
+1 DO DT^DICRW
+2 NEW FMERRCNT,HMPXTMP,HMPIEN,LN,NTRY,TXT,V,X,Y
+3 ; XTMP storage location
SET Y=$$NOW^XLFDT
SET HMPXTMP=$NAME(^XTMP("HMP INSTALL LOG",Y))
+4 ; ^XTMP log data expires in 90 days
+5 SET X=$GET(@HMPXTMP@(0))
if X=""
SET @HMPXTMP@(0)=$$FMADD^XLFDT(DT,90)_U_Y_"^HMP installation "_$$FMTE^XLFDT(Y)
+6 ;
+7 ; FileMan error counter
SET FMERRCNT=0
+8 ; save entries in FileMan items list
+9 FOR LN=1:1
SET TXT=$PIECE($TEXT(FMITMS+LN),";;",2,99)
if TXT=""
QUIT
Begin DoDot:1
+10 ; file #, FileMan returned value and error message arrays
NEW FLNO,FMARRY,FMERR
+11 ; file number and target entry
SET FLNO=+$PIECE(TXT,U)
SET X=$PIECE(TXT,U,2,99)
+12 ; file and entry required
if '(FLNO>1)!(X="")
QUIT
+13 ; lookup value in X is external format
SET HMPIEN=$$FIND1^DIC(FLNO,"","",X,"","","FMERR")
+14 ; log error message and quit
IF $DATA(FMERR)
Begin DoDot:2
+15 SET V="FMERR"
SET FMERRCNT=FMERRCNT+1
FOR
SET V=$QUERY(@V)
if V=""
QUIT
SET @HMPXTMP@("FM LOOKUP ERROR",FMERRCNT,V)=@V
End DoDot:2
QUIT
+16 ;
+17 ; entry
if '(HMPIEN>0)
SET FMERRCNT=FMERRCNT+1
SET @HMPXTMP@("FM ENTRY NOT FOUND",FMERRCNT)=TXT
+18 if HMPIEN>0
SET @HMPXTMP@("ENTRY",FLNO,HMPIEN)="entry found"
+19 ; just in case
KILL FMERR
+20 ; data including sub-files, ignore null values
DO GETS^DIQ(FLNO,HMPIEN_",","**","EN","FMARRY","FMERR")
+21 ; log error message
IF $DATA(FMERR)
Begin DoDot:2
+22 SET V="FMERR"
SET FMERRCNT=FMERRCNT+1
FOR
SET V=$QUERY(@V)
if V=""
QUIT
SET @HMPXTMP@("FM DATA ERROR",FMERRCNT,V)=@V
End DoDot:2
+23 ; save the data
+24 MERGE @HMPXTMP@("ENTRY")=FMARRY
End DoDot:1
+25 ;
+26 ; return ^XTMP storage location
QUIT HMPXTMP
+27 ;
FMITMS ; list of FileMan entries: "file # ^ .01 field value"
+1 ;;19^XU USER CHANGE
+2 ;;19^XU USER TERMINATE
+3 ;
