HMP0311P ;ASMR/hrubovcak - HMP DGPF ASSIGN FLAG Protocol to ITEM;Mar 20, 2015@14:34:08
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**;November 30,2015;Build 63
;Per VA Directive 6402, this routine should not be modified.
;
Q
; Post-init logic
POST ; make HMP DGPF ASSIGN FLAG protocol an ITEM
;
N HMPDGIEN,HMPERR,HMPEXIT,HMPFDA,HMPIEN,HMPRTCL,J,PRTCLITM,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 HMPRTCL="HMP DGPF ASSIGN FLAG",HMPIEN=$O(^ORD(101,"B",HMPRTCL,0))
; protocol missing, write message and exit
I '(HMPIEN>0) D MES^XPDUTL(HMPRTCL_" protocol not found. It must be installed to proceed.") Q
;
S Y="DGPF ASSIGN FLAG",HMPDGIEN=$O(^ORD(101,"B",Y,0))
; protocol missing, write message and exit
I '(HMPDGIEN>0) D MES^XPDUTL(Y_" protocol not found. No ITEM update performed.") Q
; make DGPF ASSIGN FLAG an extended action
S HMPFDA(101,HMPDGIEN_",",4)="X"
D UPDATE^DIE("","HMPFDA","","HMPERR")
I $D(HMPERR) D Q ; something went wrong
.D MES^XPDUTL("FileMan error when editing DGPF ASSIGN FLAG protocol")
.N V S V="HMPERR" F S V=$Q(@V) Q:V="" D MES^XPDUTL(V_" = "_@V)
;
; is protocol already an item?
S HMPEXIT=$O(^ORD(101,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
S HMPFDA(101.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 DGPF ASSIGN FLAG 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_" 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"
;;101^DGPF ASSIGN FLAG
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMP0311P 3419 printed Apr 09, 2024@20:58:39 Page 2
HMP0311P ;ASMR/hrubovcak - HMP DGPF ASSIGN FLAG Protocol to ITEM;Mar 20, 2015@14:34:08
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**;November 30,2015;Build 63
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ; Post-init logic
POST ; make HMP DGPF ASSIGN FLAG protocol an ITEM
+1 ;
+2 NEW HMPDGIEN,HMPERR,HMPEXIT,HMPFDA,HMPIEN,HMPRTCL,J,PRTCLITM,V,X,Y
+3 ;
+4 DO MES^XPDUTL($TEXT(+0)_" post-init routine started "_$$HTE^XLFDT($HOROLOG))
+5 SET V=$$SVDATA
DO MES^XPDUTL("Old data saved in "_V)
+6 SET HMPRTCL="HMP DGPF ASSIGN FLAG"
SET HMPIEN=$ORDER(^ORD(101,"B",HMPRTCL,0))
+7 ; protocol missing, write message and exit
+8 IF '(HMPIEN>0)
DO MES^XPDUTL(HMPRTCL_" protocol not found. It must be installed to proceed.")
QUIT
+9 ;
+10 SET Y="DGPF ASSIGN FLAG"
SET HMPDGIEN=$ORDER(^ORD(101,"B",Y,0))
+11 ; protocol missing, write message and exit
+12 IF '(HMPDGIEN>0)
DO MES^XPDUTL(Y_" protocol not found. No ITEM update performed.")
QUIT
+13 ; make DGPF ASSIGN FLAG an extended action
+14 SET HMPFDA(101,HMPDGIEN_",",4)="X"
+15 DO UPDATE^DIE("","HMPFDA","","HMPERR")
+16 ; something went wrong
IF $DATA(HMPERR)
Begin DoDot:1
+17 DO MES^XPDUTL("FileMan error when editing DGPF ASSIGN FLAG protocol")
+18 NEW V
SET V="HMPERR"
FOR
SET V=$QUERY(@V)
if V=""
QUIT
DO MES^XPDUTL(V_" = "_@V)
End DoDot:1
QUIT
+19 ;
+20 ; is protocol already an item?
+21 SET HMPEXIT=$ORDER(^ORD(101,HMPDGIEN,10,"B",HMPIEN,0))
+22 IF HMPEXIT
DO MES^XPDUTL(HMPRTCL_" already an ITEM in "_Y_". No update needed.")
QUIT
+23 ;
+24 ; add protocol as ITEM
+25 KILL HMPFDA,HMPERR
+26 SET HMPFDA(101.01,"+1,"_HMPDGIEN_",",.01)=HMPIEN
+27 DO UPDATE^DIE("","HMPFDA","PRTCLITM","HMPERR")
+28 ; something went wrong
IF $DATA(HMPERR)
Begin DoDot:1
+29 DO MES^XPDUTL("FileMan error when adding ITEM to DGPF ASSIGN FLAG protocol")
+30 NEW V
SET V="HMPERR"
FOR
SET V=$QUERY(@V)
if V=""
QUIT
DO MES^XPDUTL(V_" = "_@V)
End DoDot:1
QUIT
+31 ; new ITEM sub-file IEN will be in PRTCLITM(1)
+32 DO MES^XPDUTL(HMPRTCL_" protocol update finished "_$$HTE^XLFDT($HOROLOG))
+33 ;
+34 QUIT
+35 ;
SVDATA() ; extrinsic variable, save original FileMan data, returns storage node
+1 ;
+2 DO DT^DICRW
+3 NEW FMERRCNT,HMPXTMP,HMPIEN,LN,NTRY,TXT,V,X,Y
+4 ; XTMP storage location
SET Y=$$NOW^XLFDT
SET HMPXTMP=$NAME(^XTMP("HMP INSTALL LOG",Y))
+5 ; ^XTMP log data expires in 90 days
+6 SET X=$GET(@HMPXTMP@(0))
if X=""
SET @HMPXTMP@(0)=$$FMADD^XLFDT(DT,90)_U_Y_"^HMP installation "_$$FMTE^XLFDT(Y)
+7 ;
+8 ; FileMan error counter
SET FMERRCNT=0
+9 ; save entries in FileMan items list
+10 FOR LN=1:1
SET TXT=$PIECE($TEXT(FMITMS+LN),";;",2,99)
if TXT=""
QUIT
Begin DoDot:1
+11 ; file #, FileMan returned value and error message arrays
NEW FLNO,FMARRY,FMERR
+12 ; file number and target entry
SET FLNO=+$PIECE(TXT,U)
SET X=$PIECE(TXT,U,2,99)
+13 ; file and entry required
if '(FLNO>1)!(X="")
QUIT
+14 ; lookup value in X is external format
SET HMPIEN=$$FIND1^DIC(FLNO,"","",X,"","","FMERR")
+15 ; log error message and quit
IF $DATA(FMERR)
Begin DoDot:2
+16 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
+17 ;
+18 ; entry
if '(HMPIEN>0)
SET FMERRCNT=FMERRCNT+1
SET @HMPXTMP@("FM ENTRY NOT FOUND",FMERRCNT)=TXT
+19 if HMPIEN>0
SET @HMPXTMP@("ENTRY",FLNO,HMPIEN)="entry found"
+20 ; just in case
KILL FMERR
+21 ; data including sub-files, ignore null values
DO GETS^DIQ(FLNO,HMPIEN_",","**","EN","FMARRY","FMERR")
+22 ; log error message
IF $DATA(FMERR)
Begin DoDot:2
+23 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
+24 ; save the data
+25 MERGE @HMPXTMP@("ENTRY")=FMARRY
End DoDot:1
+26 ;
+27 ; return ^XTMP storage location
QUIT HMPXTMP
+28 ;
FMITMS ; list of FileMan entries: "file # ^ .01 field value"
+1 ;;101^DGPF ASSIGN FLAG
+2 ;
