DG53P425 ;ALB/RPM - PATCH DG*5.3*425 INSTALL UTILITIES ; 8/21/03 4:52pm
;;5.3;Registration;**425**;Aug 13, 1993
;
ENV ;Main entry point for Environment check point.
;
S XPDABORT=""
D PROGCHK(.XPDABORT) ;checks programmer variables
I XPDABORT="" K XPDABORT
Q
;
;
PRE ;Main entry point for Pre-init items.
;
Q
;
;
POST ;Main entry point for Post-init items.
;
N DGACTDT ;software activation date
;
S DGACTDT="Sep 25, 2003" ;National PRF Software Activation date
;
D POST1(DGACTDT) ;create/update PRF PARAMETERS (#26.18) file
D POST2 ;load BEHAVIORAL Category I PRF
Q
;
;
PROGCHK(XPDABORT) ;checks for necessary programmer variables
;
I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") DO
.D BMES^XPDUTL("*****")
.D MES^XPDUTL("Your programming variables are not set up properly.")
.D MES^XPDUTL("Installation aborted.")
.D MES^XPDUTL("*****")
.S XPDABORT=2
Q
;
POST1(DGACTDT) ;create PRF PARAMETERS (#26.18) file entry at IEN "1"
;
; Input:
; DGACTDT - (optional) software activation date in external format
; [default="May 01, 2003" ;used at test sites]
;
; Output:
; none
;
N DGACT ;type of file activity (add/update)
N DGFDA ;FDA array
N DGFLD ;field #
N DGERR ;error array
N DGIEN ;IEN array
N DGIENS
N DGPARM ;parameter record
;
I $G(DGACTDT)="" S DGACTDT="May 01, 2003" ;date for test sites
;
;existing file entry
I $D(^DGPF(26.18,1,0))#2 D
. N DGERR
. S DGIENS="1,"
. S DGACT="update"
E D
. S DGIENS="+1,"
. S DGACT="add"
;
;retrieve existing record
S DGPARM=$G(^DGPF(26.18,1,0))
;
;provide values for any missing parameters
I $P(DGPARM,U,1)="" S DGFDA(26.18,DGIENS,.01)=1
I $P(DGPARM,U,2)="" S DGFDA(26.18,DGIENS,1)=DGACTDT ;activation date
I $P(DGPARM,U,3)="" S DGFDA(26.18,DGIENS,2)="ACTIVE" ;ORU HL7 interface
I $P(DGPARM,U,4)="" S DGFDA(26.18,DGIENS,3)="DIRECT" ;QRY HL7 interface
I $P(DGPARM,U,6)="" S DGFDA(26.18,DGIENS,5)=7 ;HL7 Auto Retrans Days
;
;short-circuit when there are no missing parameters
I '$D(DGFDA) D Q
. D BMES^XPDUTL("*****")
. D MES^XPDUTL(" PRF PARAMETERS (#26.18) file values previously defined...no action taken.")
. D MES^XPDUTL("*****")
Q:'$D(DGFDA)
D UPDATE^DIE("ES","DGFDA","DGIEN","DGERR")
;
;check for errors and inform the installer of update status
I '$D(DGERR) D
. D BMES^XPDUTL("*****")
. D MES^XPDUTL("The '1' entry in the PRF PARAMETERS (#26.18) file was "_DGACT_$S(DGACT="add":"ed",1:"d")_" successfully.")
. ;
. ;display updated field list and values
. I DGACT="update" D
. . S DGFLD=0
. . F S DGFLD=$O(DGFDA(26.18,DGIENS,DGFLD)) Q:'DGFLD D
. . . D MES^XPDUTL("The "_$$GET1^DID(26.18,DGFLD,"","LABEL")_" (#"_DGFLD_") field was set to '"_DGFDA(26.18,DGIENS,DGFLD)_"'.")
. D MES^XPDUTL("*****")
E D
. D BMES^XPDUTL("*****")
. D MES^XPDUTL("The attempt to "_DGACT_" the '1' entry in the PRF PARAMETERS (#26.18) file failed.")
. D MES^XPDUTL($G(DGERR("DIERR",1,"TEXT",1)))
. D MES^XPDUTL("*****")
;
Q
;
POST2 ;create BEHAVIORAL Category I PRF
;
;short circuit if flag already exists
I $D(^DGPF(26.15,"B","BEHAVIORAL")) D Q
. D BMES^XPDUTL("*****")
. D MES^XPDUTL(" 'BEHAVIORAL' Category I flag previously defined...no action taken.")
. D MES^XPDUTL("*****")
;
N DGDESC ;description word-processing array
N DGFDA ;FDA array
N DGIEN ;IEN array
;
;flag description
S DGDESC(1,0)="The purpose of this National Patient Record Flag is to alert VHA medical"
S DGDESC(2,0)="staff and employees of patients whose behavior or characteristics may pose"
S DGDESC(3,0)="a threat either to their safety, the safety of other patients, or"
S DGDESC(4,0)="compromise the delivery of quality health care."
S DGDESC(5,0)="Application of National Patient Record Flags is coordinated through the"
S DGDESC(6,0)="Chief of Staff."
S DGDESC(7,0)="This is a nationally distributed flag."
;
;build FDA array
S DGFDA(26.15,"+1,",.01)="BEHAVIORAL"
S DGFDA(26.15,"+1,",.02)="ACTIVE"
S DGFDA(26.15,"+1,",.03)="BEHAVIORAL"
S DGFDA(26.15,"+1,",.04)=730
S DGFDA(26.15,"+1,",.05)=60
S DGFDA(26.15,"+1,",.06)="DGPF BEHAVIORAL FLAG REVIEW"
S DGFDA(26.15,"+1,",1)="DGDESC"
;
;ask for IEN = 1
S DGIEN(1)=1
;
;store record
D UPDATE^DIE("E","DGFDA","DGIEN","DGERR")
;
;check for errors and inform the installer of update status
D BMES^XPDUTL("*****")
I $D(^DGPF(26.15,"B","BEHAVIORAL")),'$D(DGERR) D
. D MES^XPDUTL(" 'BEHAVIORAL' Category I Patient Record Flag created successfully.")
E D
. D MES^XPDUTL(" 'BEHAVIORAL' Category I Patient Record Flag creation failed!")
D MES^XPDUTL("*****")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53P425 4773 printed Dec 13, 2024@02:39:43 Page 2
DG53P425 ;ALB/RPM - PATCH DG*5.3*425 INSTALL UTILITIES ; 8/21/03 4:52pm
+1 ;;5.3;Registration;**425**;Aug 13, 1993
+2 ;
ENV ;Main entry point for Environment check point.
+1 ;
+2 SET XPDABORT=""
+3 ;checks programmer variables
DO PROGCHK(.XPDABORT)
+4 IF XPDABORT=""
KILL XPDABORT
+5 QUIT
+6 ;
+7 ;
PRE ;Main entry point for Pre-init items.
+1 ;
+2 QUIT
+3 ;
+4 ;
POST ;Main entry point for Post-init items.
+1 ;
+2 ;software activation date
NEW DGACTDT
+3 ;
+4 ;National PRF Software Activation date
SET DGACTDT="Sep 25, 2003"
+5 ;
+6 ;create/update PRF PARAMETERS (#26.18) file
DO POST1(DGACTDT)
+7 ;load BEHAVIORAL Category I PRF
DO POST2
+8 QUIT
+9 ;
+10 ;
PROGCHK(XPDABORT) ;checks for necessary programmer variables
+1 ;
+2 IF '$GET(DUZ)!($GET(DUZ(0))'="@")!('$GET(DT))!($GET(U)'="^")
Begin DoDot:1
+3 DO BMES^XPDUTL("*****")
+4 DO MES^XPDUTL("Your programming variables are not set up properly.")
+5 DO MES^XPDUTL("Installation aborted.")
+6 DO MES^XPDUTL("*****")
+7 SET XPDABORT=2
End DoDot:1
+8 QUIT
+9 ;
POST1(DGACTDT) ;create PRF PARAMETERS (#26.18) file entry at IEN "1"
+1 ;
+2 ; Input:
+3 ; DGACTDT - (optional) software activation date in external format
+4 ; [default="May 01, 2003" ;used at test sites]
+5 ;
+6 ; Output:
+7 ; none
+8 ;
+9 ;type of file activity (add/update)
NEW DGACT
+10 ;FDA array
NEW DGFDA
+11 ;field #
NEW DGFLD
+12 ;error array
NEW DGERR
+13 ;IEN array
NEW DGIEN
+14 NEW DGIENS
+15 ;parameter record
NEW DGPARM
+16 ;
+17 ;date for test sites
IF $GET(DGACTDT)=""
SET DGACTDT="May 01, 2003"
+18 ;
+19 ;existing file entry
+20 IF $DATA(^DGPF(26.18,1,0))#2
Begin DoDot:1
+21 NEW DGERR
+22 SET DGIENS="1,"
+23 SET DGACT="update"
End DoDot:1
+24 IF '$TEST
Begin DoDot:1
+25 SET DGIENS="+1,"
+26 SET DGACT="add"
End DoDot:1
+27 ;
+28 ;retrieve existing record
+29 SET DGPARM=$GET(^DGPF(26.18,1,0))
+30 ;
+31 ;provide values for any missing parameters
+32 IF $PIECE(DGPARM,U,1)=""
SET DGFDA(26.18,DGIENS,.01)=1
+33 ;activation date
IF $PIECE(DGPARM,U,2)=""
SET DGFDA(26.18,DGIENS,1)=DGACTDT
+34 ;ORU HL7 interface
IF $PIECE(DGPARM,U,3)=""
SET DGFDA(26.18,DGIENS,2)="ACTIVE"
+35 ;QRY HL7 interface
IF $PIECE(DGPARM,U,4)=""
SET DGFDA(26.18,DGIENS,3)="DIRECT"
+36 ;HL7 Auto Retrans Days
IF $PIECE(DGPARM,U,6)=""
SET DGFDA(26.18,DGIENS,5)=7
+37 ;
+38 ;short-circuit when there are no missing parameters
+39 IF '$DATA(DGFDA)
Begin DoDot:1
+40 DO BMES^XPDUTL("*****")
+41 DO MES^XPDUTL(" PRF PARAMETERS (#26.18) file values previously defined...no action taken.")
+42 DO MES^XPDUTL("*****")
End DoDot:1
QUIT
+43 if '$DATA(DGFDA)
QUIT
+44 DO UPDATE^DIE("ES","DGFDA","DGIEN","DGERR")
+45 ;
+46 ;check for errors and inform the installer of update status
+47 IF '$DATA(DGERR)
Begin DoDot:1
+48 DO BMES^XPDUTL("*****")
+49 DO MES^XPDUTL("The '1' entry in the PRF PARAMETERS (#26.18) file was "_DGACT_$SELECT(DGACT="add":"ed",1:"d")_" successfully.")
+50 ;
+51 ;display updated field list and values
+52 IF DGACT="update"
Begin DoDot:2
+53 SET DGFLD=0
+54 FOR
SET DGFLD=$ORDER(DGFDA(26.18,DGIENS,DGFLD))
if 'DGFLD
QUIT
Begin DoDot:3
+55 DO MES^XPDUTL("The "_$$GET1^DID(26.18,DGFLD,"","LABEL")_" (#"_DGFLD_") field was set to '"_DGFDA(26.18,DGIENS,DGFLD)_"'.")
End DoDot:3
End DoDot:2
+56 DO MES^XPDUTL("*****")
End DoDot:1
+57 IF '$TEST
Begin DoDot:1
+58 DO BMES^XPDUTL("*****")
+59 DO MES^XPDUTL("The attempt to "_DGACT_" the '1' entry in the PRF PARAMETERS (#26.18) file failed.")
+60 DO MES^XPDUTL($GET(DGERR("DIERR",1,"TEXT",1)))
+61 DO MES^XPDUTL("*****")
End DoDot:1
+62 ;
+63 QUIT
+64 ;
POST2 ;create BEHAVIORAL Category I PRF
+1 ;
+2 ;short circuit if flag already exists
+3 IF $DATA(^DGPF(26.15,"B","BEHAVIORAL"))
Begin DoDot:1
+4 DO BMES^XPDUTL("*****")
+5 DO MES^XPDUTL(" 'BEHAVIORAL' Category I flag previously defined...no action taken.")
+6 DO MES^XPDUTL("*****")
End DoDot:1
QUIT
+7 ;
+8 ;description word-processing array
NEW DGDESC
+9 ;FDA array
NEW DGFDA
+10 ;IEN array
NEW DGIEN
+11 ;
+12 ;flag description
+13 SET DGDESC(1,0)="The purpose of this National Patient Record Flag is to alert VHA medical"
+14 SET DGDESC(2,0)="staff and employees of patients whose behavior or characteristics may pose"
+15 SET DGDESC(3,0)="a threat either to their safety, the safety of other patients, or"
+16 SET DGDESC(4,0)="compromise the delivery of quality health care."
+17 SET DGDESC(5,0)="Application of National Patient Record Flags is coordinated through the"
+18 SET DGDESC(6,0)="Chief of Staff."
+19 SET DGDESC(7,0)="This is a nationally distributed flag."
+20 ;
+21 ;build FDA array
+22 SET DGFDA(26.15,"+1,",.01)="BEHAVIORAL"
+23 SET DGFDA(26.15,"+1,",.02)="ACTIVE"
+24 SET DGFDA(26.15,"+1,",.03)="BEHAVIORAL"
+25 SET DGFDA(26.15,"+1,",.04)=730
+26 SET DGFDA(26.15,"+1,",.05)=60
+27 SET DGFDA(26.15,"+1,",.06)="DGPF BEHAVIORAL FLAG REVIEW"
+28 SET DGFDA(26.15,"+1,",1)="DGDESC"
+29 ;
+30 ;ask for IEN = 1
+31 SET DGIEN(1)=1
+32 ;
+33 ;store record
+34 DO UPDATE^DIE("E","DGFDA","DGIEN","DGERR")
+35 ;
+36 ;check for errors and inform the installer of update status
+37 DO BMES^XPDUTL("*****")
+38 IF $DATA(^DGPF(26.15,"B","BEHAVIORAL"))
IF '$DATA(DGERR)
Begin DoDot:1
+39 DO MES^XPDUTL(" 'BEHAVIORAL' Category I Patient Record Flag created successfully.")
End DoDot:1
+40 IF '$TEST
Begin DoDot:1
+41 DO MES^XPDUTL(" 'BEHAVIORAL' Category I Patient Record Flag creation failed!")
End DoDot:1
+42 DO MES^XPDUTL("*****")
+43 QUIT
