DG53P554 ;ALB/RBS - PATCH DG*5.3*554 INSTALL UTILITIES ; 3/16/06 2:55pm
;;5.3;Registration;**554**;Aug 13, 1993
;
ENV ;Main entry point for Environment check point.
;
S XPDABORT=""
D PROGCHK(.XPDABORT) ;checks programmer variables
Q:$G(XPDABORT)
;
I XPDABORT="" K XPDABORT
;
;Per KIDS documentation...XPDQUIT is used for multiple builds
S XPDQUIT=""
D TIUCHK(.XPDQUIT) ;check for TIU Progress Note Title
Q:$G(XPDQUIT)
;
I XPDQUIT="" K XPDQUIT
Q
;
;
PRE ;Main entry point for Pre-init items.
;
Q
;
;
POST ;Main entry point for Post-init items.
;
N DGACTDT ;software activation date
;
D POST1 ;link BEHAVIORAL Category I PRF to TIU PN
;
D POST2 ;create new "C" index for Principal Investigator field
; in the PRF Local Flag (#26.11) file.
;
S DGACTDT="June 20, 2006" ;PRF Phase 2 Software Activation date
;
D POST3(DGACTDT) ;create/update PRF PHASE 2 ACTIVATION (#6) field
; in the PRF PARAMETERS (#26.18) file.
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
;
;
TIUCHK(XPDQUIT) ;check for Category I (National) TIU Progress Note Title
;name setup in the TIU DOCUMENT DEFINITION file (#8925.1)
;Abort if not found.
;
N DGTITLE
S DGTITLE="PATIENT RECORD FLAG CATEGORY I"
;
I '$$FIND1^DIC(8925.1,"","X",DGTITLE,"B") D
. D BMES^XPDUTL("*****")
. D MES^XPDUTL("The TIU Progress Note Title name 'PATIENT RECORD FLAG CATEGORY I' is not setup.")
. D MES^XPDUTL("See patch TIU*1*165 for details.")
. D MES^XPDUTL("Installation aborted.")
. D MES^XPDUTL("*****")
. S XPDQUIT=1
;
Q
;
;
POST1 ;link associated TIU PROGRESS NOTE TITLE IEN to
;the Category I (National) PRF BEHAVIORAL Flag
;
;warn installer if flag not found
I '$D(^DGPF(26.15,"B","BEHAVIORAL")) D Q
. D BMES^XPDUTL("*****")
. D MES^XPDUTL(" 'BEHAVIORAL' Category I (National) PRF Flag not defined...seek help!")
. D MES^XPDUTL("*****")
;
;short circuit if flag TIU PN Title already exists
I $D(^DGPF(26.15,"ATIU")) D Q
. D BMES^XPDUTL("*****")
. D MES^XPDUTL(" 'BEHAVIORAL' Category I (National) PRF Flag already associated with a TIU Progress Note Title...No action taken.")
. D MES^XPDUTL("*****")
;
N DGFLAG ;Category I (National) PRF name
N DGIEN ;IEN of National Flag record
N DGFDA ;filer FDA array
N DGIENS ;filer record IEN value
N DGERR ;filer error array
N DGTITLE ;Category I (National) TIU Progress Note Title name
;
;Category I (National) PRF flag IEN record value
S DGFLAG="BEHAVIORAL"
S DGIEN=$O(^DGPF(26.15,"B",DGFLAG,0))
S DGIENS=DGIEN_","
;
;set name equal to the nationaly released Category I Title that
;is setup in the TIU DOCUMENT DEFINITION file (#8925.1)
S DGTITLE="PATIENT RECORD FLAG CATEGORY I"
;
;build FDA array
S DGFDA(26.15,DGIENS,.07)=DGTITLE
;
;file link in new field (#.07) TIU PN TITLE
D FILE^DIE("E","DGFDA","DGERR")
;
;check for errors and inform the installer of update status
D BMES^XPDUTL("*****")
I '$D(DGERR) D
. D MES^XPDUTL(" 'BEHAVIORAL' Category I (National) PRF Flag linked to associated TIU Progress Note Title successfully.")
E D
. D MES^XPDUTL(" 'BEHAVIORAL' Category I (National) PRF Flag link to associated TIU Progress Note Title failed!")
D MES^XPDUTL("*****")
Q
;
;
POST2 ;create new 'C' index for Principal Investigator field (multiple)
;-- PRF LOCAL FLAG (#26.11) file
;-- SUB-FILE (2) PRINCIPAL INVESTIGATOR(S) (#26.112), field (.01)
;
Q:$D(^DGPF(26.11,"C")) ;already setup
;
N DA,DIC,DIK,DGIEN,X
;
S DGIEN=0
F S DGIEN=$O(^DGPF(26.11,DGIEN)) Q:'DGIEN D
. K DA,DIC,DIK,X
. S DIK=$$ROOT^DILFD(26.112,","_DGIEN_",")
. S DIK(1)=".01^C"
. S DA(1)=DGIEN
. D ENALL^DIK
;
Q
;
;
POST3(DGACTDT) ;create/update PRF PHASE 2 ACTIVATION (#6) field of the
;PRF PARAMETERS (#26.18) file entry at IEN "1"
;
; Input:
; DGACTDT - (required) software activation date in external format
;
; Output:
; none
;
N DGERR ;error array
N DGFDA ;FDA array
N DGRESULT ;return var
;
Q:($G(DGACTDT)="")
;
;existing file entry
Q:'$D(^DGPF(26.18,1,0))
;
;convert external date to internal FM date
D CHK^DIE(26.18,6,"",DGACTDT,.DGRESULT,"DGERR")
Q:$D(DGERR)
Q:'$G(DGRESULT)
;
S DGACTDT=DGRESULT
;
S DGFDA(26.18,"1,",6)=DGACTDT
;
D FILE^DIE("","DGFDA","DGERR")
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53P554 4689 printed Dec 13, 2024@02:39:48 Page 2
DG53P554 ;ALB/RBS - PATCH DG*5.3*554 INSTALL UTILITIES ; 3/16/06 2:55pm
+1 ;;5.3;Registration;**554**;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 $GET(XPDABORT)
QUIT
+5 ;
+6 IF XPDABORT=""
KILL XPDABORT
+7 ;
+8 ;Per KIDS documentation...XPDQUIT is used for multiple builds
+9 SET XPDQUIT=""
+10 ;check for TIU Progress Note Title
DO TIUCHK(.XPDQUIT)
+11 if $GET(XPDQUIT)
QUIT
+12 ;
+13 IF XPDQUIT=""
KILL XPDQUIT
+14 QUIT
+15 ;
+16 ;
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 ;link BEHAVIORAL Category I PRF to TIU PN
DO POST1
+5 ;
+6 ;create new "C" index for Principal Investigator field
DO POST2
+7 ; in the PRF Local Flag (#26.11) file.
+8 ;
+9 ;PRF Phase 2 Software Activation date
SET DGACTDT="June 20, 2006"
+10 ;
+11 ;create/update PRF PHASE 2 ACTIVATION (#6) field
DO POST3(DGACTDT)
+12 ; in the PRF PARAMETERS (#26.18) file.
+13 QUIT
+14 ;
+15 ;
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 ;
+10 ;
TIUCHK(XPDQUIT) ;check for Category I (National) TIU Progress Note Title
+1 ;name setup in the TIU DOCUMENT DEFINITION file (#8925.1)
+2 ;Abort if not found.
+3 ;
+4 NEW DGTITLE
+5 SET DGTITLE="PATIENT RECORD FLAG CATEGORY I"
+6 ;
+7 IF '$$FIND1^DIC(8925.1,"","X",DGTITLE,"B")
Begin DoDot:1
+8 DO BMES^XPDUTL("*****")
+9 DO MES^XPDUTL("The TIU Progress Note Title name 'PATIENT RECORD FLAG CATEGORY I' is not setup.")
+10 DO MES^XPDUTL("See patch TIU*1*165 for details.")
+11 DO MES^XPDUTL("Installation aborted.")
+12 DO MES^XPDUTL("*****")
+13 SET XPDQUIT=1
End DoDot:1
+14 ;
+15 QUIT
+16 ;
+17 ;
POST1 ;link associated TIU PROGRESS NOTE TITLE IEN to
+1 ;the Category I (National) PRF BEHAVIORAL Flag
+2 ;
+3 ;warn installer if flag not found
+4 IF '$DATA(^DGPF(26.15,"B","BEHAVIORAL"))
Begin DoDot:1
+5 DO BMES^XPDUTL("*****")
+6 DO MES^XPDUTL(" 'BEHAVIORAL' Category I (National) PRF Flag not defined...seek help!")
+7 DO MES^XPDUTL("*****")
End DoDot:1
QUIT
+8 ;
+9 ;short circuit if flag TIU PN Title already exists
+10 IF $DATA(^DGPF(26.15,"ATIU"))
Begin DoDot:1
+11 DO BMES^XPDUTL("*****")
+12 DO MES^XPDUTL(" 'BEHAVIORAL' Category I (National) PRF Flag already associated with a TIU Progress Note Title...No action taken.")
+13 DO MES^XPDUTL("*****")
End DoDot:1
QUIT
+14 ;
+15 ;Category I (National) PRF name
NEW DGFLAG
+16 ;IEN of National Flag record
NEW DGIEN
+17 ;filer FDA array
NEW DGFDA
+18 ;filer record IEN value
NEW DGIENS
+19 ;filer error array
NEW DGERR
+20 ;Category I (National) TIU Progress Note Title name
NEW DGTITLE
+21 ;
+22 ;Category I (National) PRF flag IEN record value
+23 SET DGFLAG="BEHAVIORAL"
+24 SET DGIEN=$ORDER(^DGPF(26.15,"B",DGFLAG,0))
+25 SET DGIENS=DGIEN_","
+26 ;
+27 ;set name equal to the nationaly released Category I Title that
+28 ;is setup in the TIU DOCUMENT DEFINITION file (#8925.1)
+29 SET DGTITLE="PATIENT RECORD FLAG CATEGORY I"
+30 ;
+31 ;build FDA array
+32 SET DGFDA(26.15,DGIENS,.07)=DGTITLE
+33 ;
+34 ;file link in new field (#.07) TIU PN TITLE
+35 DO FILE^DIE("E","DGFDA","DGERR")
+36 ;
+37 ;check for errors and inform the installer of update status
+38 DO BMES^XPDUTL("*****")
+39 IF '$DATA(DGERR)
Begin DoDot:1
+40 DO MES^XPDUTL(" 'BEHAVIORAL' Category I (National) PRF Flag linked to associated TIU Progress Note Title successfully.")
End DoDot:1
+41 IF '$TEST
Begin DoDot:1
+42 DO MES^XPDUTL(" 'BEHAVIORAL' Category I (National) PRF Flag link to associated TIU Progress Note Title failed!")
End DoDot:1
+43 DO MES^XPDUTL("*****")
+44 QUIT
+45 ;
+46 ;
POST2 ;create new 'C' index for Principal Investigator field (multiple)
+1 ;-- PRF LOCAL FLAG (#26.11) file
+2 ;-- SUB-FILE (2) PRINCIPAL INVESTIGATOR(S) (#26.112), field (.01)
+3 ;
+4 ;already setup
if $DATA(^DGPF(26.11,"C"))
QUIT
+5 ;
+6 NEW DA,DIC,DIK,DGIEN,X
+7 ;
+8 SET DGIEN=0
+9 FOR
SET DGIEN=$ORDER(^DGPF(26.11,DGIEN))
if 'DGIEN
QUIT
Begin DoDot:1
+10 KILL DA,DIC,DIK,X
+11 SET DIK=$$ROOT^DILFD(26.112,","_DGIEN_",")
+12 SET DIK(1)=".01^C"
+13 SET DA(1)=DGIEN
+14 DO ENALL^DIK
End DoDot:1
+15 ;
+16 QUIT
+17 ;
+18 ;
POST3(DGACTDT) ;create/update PRF PHASE 2 ACTIVATION (#6) field of the
+1 ;PRF PARAMETERS (#26.18) file entry at IEN "1"
+2 ;
+3 ; Input:
+4 ; DGACTDT - (required) software activation date in external format
+5 ;
+6 ; Output:
+7 ; none
+8 ;
+9 ;error array
NEW DGERR
+10 ;FDA array
NEW DGFDA
+11 ;return var
NEW DGRESULT
+12 ;
+13 if ($GET(DGACTDT)="")
QUIT
+14 ;
+15 ;existing file entry
+16 if '$DATA(^DGPF(26.18,1,0))
QUIT
+17 ;
+18 ;convert external date to internal FM date
+19 DO CHK^DIE(26.18,6,"",DGACTDT,.DGRESULT,"DGERR")
+20 if $DATA(DGERR)
QUIT
+21 if '$GET(DGRESULT)
QUIT
+22 ;
+23 SET DGACTDT=DGRESULT
+24 ;
+25 SET DGFDA(26.18,"1,",6)=DGACTDT
+26 ;
+27 DO FILE^DIE("","DGFDA","DGERR")
+28 ;
+29 QUIT
