DG477PST ;BIR/DRI-DG*5.3*477 PATCH POST INSTALL ROUTINE ;9/11/02
;;5.3;Registration;**477,1015**;Aug 13, 1993;Build 21
;
;Reference to TRIG^DICR supported by IA #3405
;
POST ;Post-init functions
D POST1,POST2
Q
;
POST1 ;recompile input templates and update triggered fields
;Recompile input templates
D COMPILE
;Update triggered fields
D TRIG
Q
;
COMPILE N GLOBAL,FIELD,CFIELD,NFIELD,TEMPLATP,TEMPLATN
D BMES^XPDUTL("Beginning to compile templates on the PATIENT (#2) file.")
;
S NFIELD=$P($T(AFIELDS),";;",2) ;get the fields that have new xref
;
F GLOBAL="^DIE","^DIPT" DO
.I GLOBAL="^DIE" D BMES^XPDUTL(" Compiling Input Templates")
.I GLOBAL="^DIPT" DO
. . D BMES^XPDUTL(" ")
. . D BMES^XPDUTL(" Compiling Print Templates")
.;
.S FIELD=0
.; go find templates on fields that have added cross-ref
.F S FIELD=$O(@GLOBAL@("AF",2,FIELD)) Q:'FIELD DO
. .;
. .S CFIELD=","_FIELD_","
. .;if we didn't add the cross reference, quit
. .I NFIELD'[CFIELD Q
. .;
. .S TEMPLATP=0
. .F S TEMPLATP=$O(@GLOBAL@("AF",2,FIELD,TEMPLATP)) Q:'TEMPLATP DO
. . . S TEMPLATN=$P($G(@GLOBAL@(TEMPLATP,0)),"^",1)
. . . I TEMPLATN="" DO Q
. . . . D BMES^XPDUTL("Could not compile template "_TEMPLATN_$C(13,10)_"Please review!")
. . . .;
. . . S X=$P($G(@GLOBAL@(TEMPLATP,"ROUOLD")),"^")
. . . I X=""&($D(@GLOBAL@(TEMPLATP,"ROU"))'=0) DO Q
. . . . D BMES^XPDUTL("Could not find routine for template "_TEMPLATN_$C(13,10)_"Please review!")
. . . I X=""&($D(@GLOBAL@(TEMPLATP,"ROU"))=0) Q
. . . I $D(FIELD(X)) Q ;already compiled
. . .;
. . . S FIELD(X)="" ; remember the template was compiled
. . . S Y=TEMPLATP ; set up the call for fman
. . . S DMAX=$$ROUSIZE^DILF
. . . I GLOBAL="^DIE" D EN^DIEZ Q
. . . I GLOBAL="^DIPT" D EN^DIPZ Q
.;
S (X,Y)=""
D BMES^XPDUTL("The following routine namespace was compiled:")
F S X=$O(FIELD(X)) Q:X="" DO
. S Y=$G(Y)+1 S PRINT(Y)=" "_X_"*"
;
D MES^XPDUTL(.PRINT)
K X,Y,DMAX,PRINT
Q
;
;these are the fields that have a new cross-ref
AFIELDS ;;,.313,
Q
;
TRIG ;Update trigger definitions
N DGFLD
D BMES^XPDUTL("Updating trigger field definitions...")
F DGFLD=.092,.093 S DGFLD(2,DGFLD)=""
D T1(.DGFLD)
Q
;
T1(DGFLD) ;Check/update triggering field definitions
;Input: DGFLD=array of fields to update
N DGOUT,DGFILE
D TRIG^DICR(.DGFLD,.DGOUT)
S DGFILE=0 F S DGFILE=$O(DGOUT(DGFILE)) Q:'DGFILE D
.S DGFLD=0 F S DGFLD=$O(DGOUT(DGFILE,DGFLD)) Q:'DGFLD D
..D MES^XPDUTL(" Field #"_DGFLD_" of file #"_DGFILE_" updated.")
..Q
.Q
Q
;
POST2 ;translate marital status from 'n' to 'never married'
;caused by dg*5.3*474 initially installed 10/31/2002
NEW FIELD,FILE,GLO,IEN,MSCNT,PDR,VAL
D BMES^XPDUTL(" Translating MARITAL STATUS from 'N' to 'NEVER MARRIED' in the")
D MES^XPDUTL(" PATIENT DATA ELEMENTS (#391.99) file for PATIENT DATA REVIEWS.")
S GLO="^DGCN(391.98,""EVT"",3021030)",FILE=2,FIELD=.05,MSCNT=0
F S GLO=$Q(@GLO) Q:$QS(GLO,2)'="EVT" S PDR=$QS(GLO,4) I PDR S IEN=$O(^DGCN(391.99,"AKY",PDR,FILE,FIELD,"")) I IEN Q ;find first possible affected pdr
I $G(IEN) S IEN=IEN-1 F S IEN=$O(^DGCN(391.99,"ASRT",FILE,FIELD,IEN)) Q:'IEN S VAL=$G(^DGCN(391.99,IEN,"VAL")) I VAL="N" S MSCNT=MSCNT+1 D
. D UPD(IEN,50,"NEVER MARRIED"),UPD(IEN,.06,"@") ;loop through subsequent marital status elements and update if necessary
D BMES^XPDUTL(" "_MSCNT_" MARITAL STATUS entries were translated.")
Q
;
UPD(DA,FLD,VAL) ;update value
L +^DGCN(391.99,DA,0):10 I '$T D BMES^XPDUTL("Unable to lock entry "_DA_" in the PATIENT DATA ELEMENT (#391.99) file.") Q
S DIE="^DGCN(391.99,"
S DR=FLD_"///^S X=VAL"
D ^DIE K DIE,DR
L -^DGCN(391.99,DA,0)
Q
DG477PST ;BIR/DRI-DG*5.3*477 PATCH POST INSTALL ROUTINE ;9/11/02
+1 ;;5.3;Registration;**477,1015**;Aug 13, 1993;Build 21
+2 ;
+3 ;Reference to TRIG^DICR supported by IA #3405
+4 ;
POST ;Post-init functions
+1 DO POST1
DO POST2
+2 QUIT
+3 ;
POST1 ;recompile input templates and update triggered fields
+1 ;Recompile input templates
+2 DO COMPILE
+3 ;Update triggered fields
+4 DO TRIG
+5 QUIT
+6 ;
COMPILE NEW GLOBAL,FIELD,CFIELD,NFIELD,TEMPLATP,TEMPLATN
+1 DO BMES^XPDUTL("Beginning to compile templates on the PATIENT (#2) file.")
+2 ;
+3 ;get the fields that have new xref
SET NFIELD=$PIECE($TEXT(AFIELDS),";;",2)
+4 ;
+5 FOR GLOBAL="^DIE","^DIPT"
Begin DoDot:1
+6 IF GLOBAL="^DIE"
DO BMES^XPDUTL(" Compiling Input Templates")
+7 IF GLOBAL="^DIPT"
Begin DoDot:2
+8 DO BMES^XPDUTL(" ")
+9 DO BMES^XPDUTL(" Compiling Print Templates")
End DoDot:2
+10 ;
+11 SET FIELD=0
+12 ; go find templates on fields that have added cross-ref
+13 FOR
SET FIELD=$ORDER(@GLOBAL@("AF",2,FIELD))
IF 'FIELD
QUIT
Begin DoDot:2
+14 ;
+15 SET CFIELD=","_FIELD_","
+16 ;if we didn't add the cross reference, quit
+17 IF NFIELD'[CFIELD
QUIT
+18 ;
+19 SET TEMPLATP=0
+20 FOR
SET TEMPLATP=$ORDER(@GLOBAL@("AF",2,FIELD,TEMPLATP))
IF 'TEMPLATP
QUIT
Begin DoDot:3
+21 SET TEMPLATN=$PIECE($GET(@GLOBAL@(TEMPLATP,0)),"^",1)
+22 IF TEMPLATN=""
Begin DoDot:4
+23 DO BMES^XPDUTL("Could not compile template "_TEMPLATN_$CHAR(13,10)_"Please review!")
+24 ;
End DoDot:4
QUIT
+25 SET X=$PIECE($GET(@GLOBAL@(TEMPLATP,"ROUOLD")),"^")
+26 IF X=""&($DATA(@GLOBAL@(TEMPLATP,"ROU"))'=0)
Begin DoDot:4
+27 DO BMES^XPDUTL("Could not find routine for template "_TEMPLATN_$CHAR(13,10)_"Please review!")
End DoDot:4
QUIT
+28 IF X=""&($DATA(@GLOBAL@(TEMPLATP,"ROU"))=0)
QUIT
+29 ;already compiled
IF $DATA(FIELD(X))
QUIT
+30 ;
+31 ; remember the template was compiled
SET FIELD(X)=""
+32 ; set up the call for fman
SET Y=TEMPLATP
+33 SET DMAX=$$ROUSIZE^DILF
+34 IF GLOBAL="^DIE"
DO EN^DIEZ
QUIT
+35 IF GLOBAL="^DIPT"
DO EN^DIPZ
QUIT
End DoDot:3
End DoDot:2
+36 ;
End DoDot:1
+37 SET (X,Y)=""
+38 DO BMES^XPDUTL("The following routine namespace was compiled:")
+39 FOR
SET X=$ORDER(FIELD(X))
IF X=""
QUIT
Begin DoDot:1
+40 SET Y=$GET(Y)+1
SET PRINT(Y)=" "_X_"*"
End DoDot:1
+41 ;
+42 DO MES^XPDUTL(.PRINT)
+43 KILL X,Y,DMAX,PRINT
+44 QUIT
+45 ;
+46 ;these are the fields that have a new cross-ref
AFIELDS ;;,.313,
+1 QUIT
+2 ;
TRIG ;Update trigger definitions
+1 NEW DGFLD
+2 DO BMES^XPDUTL("Updating trigger field definitions...")
+3 FOR DGFLD=.092,.093
SET DGFLD(2,DGFLD)=""
+4 DO T1(.DGFLD)
+5 QUIT
+6 ;
T1(DGFLD) ;Check/update triggering field definitions
+1 ;Input: DGFLD=array of fields to update
+2 NEW DGOUT,DGFILE
+3 DO TRIG^DICR(.DGFLD,.DGOUT)
+4 SET DGFILE=0
FOR
SET DGFILE=$ORDER(DGOUT(DGFILE))
IF 'DGFILE
QUIT
Begin DoDot:1
+5 SET DGFLD=0
FOR
SET DGFLD=$ORDER(DGOUT(DGFILE,DGFLD))
IF 'DGFLD
QUIT
Begin DoDot:2
+6 DO MES^XPDUTL(" Field #"_DGFLD_" of file #"_DGFILE_" updated.")
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
POST2 ;translate marital status from 'n' to 'never married'
+1 ;caused by dg*5.3*474 initially installed 10/31/2002
+2 NEW FIELD,FILE,GLO,IEN,MSCNT,PDR,VAL
+3 DO BMES^XPDUTL(" Translating MARITAL STATUS from 'N' to 'NEVER MARRIED' in the")
+4 DO MES^XPDUTL(" PATIENT DATA ELEMENTS (#391.99) file for PATIENT DATA REVIEWS.")
+5 SET GLO="^DGCN(391.98,""EVT"",3021030)"
SET FILE=2
SET FIELD=.05
SET MSCNT=0
+6 ;find first possible affected pdr
FOR
SET GLO=$QUERY(@GLO)
IF $QSUBSCRIPT(GLO,2)'="EVT"
QUIT
SET PDR=$QSUBSCRIPT(GLO,4)
IF PDR
SET IEN=$ORDER(^DGCN(391.99,"AKY",PDR,FILE,FIELD,""))
IF IEN
QUIT
+7 IF $GET(IEN)
SET IEN=IEN-1
FOR
SET IEN=$ORDER(^DGCN(391.99,"ASRT",FILE,FIELD,IEN))
IF 'IEN
QUIT
SET VAL=$GET(^DGCN(391.99,IEN,"VAL"))
IF VAL="N"
SET MSCNT=MSCNT+1
Begin DoDot:1
+8 ;loop through subsequent marital status elements and update if necessary
DO UPD(IEN,50,"NEVER MARRIED")
DO UPD(IEN,.06,"@")
End DoDot:1
+9 DO BMES^XPDUTL(" "_MSCNT_" MARITAL STATUS entries were translated.")
+10 QUIT
+11 ;
UPD(DA,FLD,VAL) ;update value
+1 LOCK +^DGCN(391.99,DA,0):10
IF '$TEST
DO BMES^XPDUTL("Unable to lock entry "_DA_" in the PATIENT DATA ELEMENT (#391.99) file.")
QUIT
+2 SET DIE="^DGCN(391.99,"
+3 SET DR=FLD_"///^S X=VAL"
+4 DO ^DIE
KILL DIE,DR
+5 LOCK -^DGCN(391.99,DA,0)
+6 QUIT
