DG53688P ;ALB/CKN,BAJ,ERC - Patch DG*5.3*688 Install Utility Routine ; 8/15/08 12:03pm
;;5.3;Registration;**688**;AUG 13, 1993;Build 29
Q
EP ;Entry point - Driver
N ELEMNT,I,J,ABORT,EXIST,DMSG,ACTION
;
; Run trigger clean-up on Patient file per EVC_CR5834
D START^DG53688A
D START^DG53688B ;Run field defintion clean-up per EVC_CR7473
;
S GLOBAL="^IVM",ABORT=0,DMSG="",ACTION="create"
F I=1:1 S ELEMNT=$P($T(TEXT+I),";;",2) Q:ELEMNT="QUIT"!(ABORT) D
. S FILE=$P(ELEMNT,";",1),EXIST=0
. K DGDATA S (DATA,SUB)="" F J=2:1:$L(ELEMNT,";") S DATA=$P(ELEMNT,";",J) D Q:EXIST
. . S SUB=$P(DATA,"~",1),VALUE=$P(DATA,"~",2)
. . S DGDATA(SUB)=VALUE
. . I SUB=.01,$$ISTHERE(FILE,.DGDATA,GLOBAL) S EXIST=1
. I 'EXIST D
. . I '$$ADD^DGENDBS(FILE,,.DGDATA) S ABORT=1
; setup message variable
S DMSG=$G(DGDATA(.01))
; if Ok so far, install #506 modification & #88 addition
;
I 'ABORT S ACTION="modify",DMSG="INCONSISTENT DATA ELEMENT #506",ABORT=$$506()
I 'ABORT S DMSG="INCONSISTENT DATA ELEMENT #88",ABORT=$$88()
;
;add NOT APPLICABLE Enrollment Status to file 27.15
I 'ABORT D
. N DGABORT
. S ACTION="add",DMSG="ENROLLMENT STATUS #23",ABORT=$$ENRSTAT()
;
I ABORT D
. S XPDABORT=2
. D BMES^XPDUTL("Install process could not "_ACTION_" an entry in file for "_DMSG)
. D BMES^XPDUTL(" <<<< INSTALLATION ABORTED >>>>")
Q
;
ISTHERE(FILE,DGDATA,GLOBAL) ;
N FOUND,GLOB
S FOUND=0
S GLOB=GLOBAL_"(FILE,""B"",DGDATA(.01))"
I $D(@GLOB) D
. D BMES^XPDUTL(" Internal Entry Value for .01 -- "_DGDATA(.01)_" -- already exists in file "_FILE)
. S FOUND=1
Q FOUND
;
HECMSG ; Send message to HEC Legacy that install is complete.
;
;also index the Other Federal Agency file (#35) with the new "C" cross reference
D CREF
;
N SITE,STATN,PRODFLG,XMDUZ,XMSUB,XMY,XMTEXT,MSG,DIFROM
S SITE=$$SITE^VASITE,STATN=$P($G(SITE),U,3)
S PRODFLG=$$GET1^DIQ(869.3,"1,",.03,"I")="P"
S XMDUZ="EVC I2 Install"
S XMSUB=XMDUZ_" - "_STATN_" (DG*5.3*688)"
S:PRODFLG XMY("S.IVMB*2*860 MESSAGE@IVM.DOMAIN.EXT")=""
S:'PRODFLG XMY(DUZ)=""
S XMTEXT="MSG("
S $P(MSG(1),U)="IVMB*2*860"
S $P(MSG(1),U,2)=STATN
S $P(MSG(1),U,3)="DG*5.3*688 "_$$FMTE^XLFDT($$NOW^XLFDT(),"5D")
S $P(MSG(1),U,4)=PRODFLG
S $P(MSG(1),U,5)=1
D ^XMD
D BMES^XPDUTL(" *** Install Message Sent to HEC Legacy ***")
Q
;
506() ; Update entry #506 in the INCONSISTENT DATA ELEMENTS file (#38.6)
;-----------------------------------------------------------------
;-----------------------------------------------------------------
N DATA,DGENDA,DGERR,FILE,DGTITL,ABORT,DGWP
S FILE=38.6,DGENDA=506,DGTITL="Entry #506 SW ASIA CONDITIONS",ABORT=0
D BMES^XPDUTL(" >> Modifying entry #506 in the INCONSISTENT DATA ELEMENTS file (#38.6)")
S DATA(.01)="VALUE FOR SW ASIA COND INVALID"
S DATA(2)="THE VALUE FOR SW ASIA CONDITIONS MUST BE EITHER YES, NO, OR UNKNOWN"
S DATA(50)="DGWP"
S DGWP(1,0)="If completed, the value for Southwest Asia Conditions must be"
S DGWP(2,0)="Yes, No or Unknown."
I '$$UPD^DGENDBS(FILE,.DGENDA,.DATA,.DGERR) D
. D BMES^XPDUTL(" >>> ERROR! "_DGTITL_" not changed in file #38.6")
. D MES^XPDUTL(" "_$G(DGERR))
. S ABORT=1
D:'ABORT BMES^XPDUTL(" "_DGTITL_" successfully modified.")
Q ABORT
;
88() ; Add entry #88 TEMP. ADDRESS DATA INCOMPLETE
N DATA,DGERR,DGTITL,ABORT,I,DGWP,ROOT,QUIT,DGFDA,DGIEN
S DGIEN(1)=88,(ABORT,QUIT)=0
S DGTITL="Entry #88 'TEMPORARY ADDRESS' DATA IS INCOMPLETE"
D BMES^XPDUTL(" >> Modifying entry #88 in the INCONSISTENT DATA ELEMENTS file (#38.6)")
S ROOT="DGFDA(38.6,""?+1,"")"
S @ROOT@(.01)="TEMP. ADDRESS DATA INCOMPLETE"
I $D(^DGIN(38.6,88,0)) D Q ABORT
. I $P(^DGIN(38.6,88,0),U,1)'=@ROOT@(.01) D Q
. . D MES^XPDUTL(" >>> ERROR: Entry # 88 needs to be reviewed by NVS! <<<")
. . D MES^XPDUTL(" Existing entry: "_$P($G(^DGIN(38.6,88,0)),"^"))
. . D MES^XPDUTL(" Incoming entry: "_$G(@ROOT@(.01)))
. . D BMES^XPDUTL(" <<<< INSTALLATION ABORTED >>>>")
. . S ABORT=1
. D BMES^XPDUTL(" >> Entry #88 already exists in the INCONSISTENT DATA ELEMENTS file (#38.6)")
S @ROOT@(2)="'TEMPORARY ADDRESS' DATA IS INCOMPLETE"
F I=3:1:6 S @ROOT@(I)=0
S @ROOT@(50)="DGWP"
S DGWP(1,0)="Inconsistency results if a record with an active temporary"
S DGWP(2,0)="address does not contain the first line of the street address, city, state,"
S DGWP(3,0)="and zip code for a domestic temporary address, or, for a foreign temporary"
S DGWP(4,0)="address, the first line of the street address and the city."
D UPDATE^DIE("","DGFDA","DGIEN","DGERR")
I $D(DGERR) D
. D BMES^XPDUTL(" >>> ERROR! "_DGTITL_" not added to file #38.6")
. D MES^XPDUTL(" "_DGERR("DIERR",1)_": "_DGERR("DIERR",1,"TEXT",1))
. D BMES^XPDUTL(" <<<< INSTALLATION ABORTED >>>>")
. S ABORT=1
D:'ABORT BMES^XPDUTL(" "_DGTITL_" successfully added.")
Q ABORT
;
ENRSTAT() ;Add NOT APPLICABLE to the Enrollment Status file (#27.15)
N DGCAT,DGMSG,DGSTAT
S DGSTAT="NOT APPLICABLE"
S DGCAT="N"
S DGABORT=1
;check to see if there is an entry already
I $D(^DGEN(27.15,23)) D Q DGABORT
. I $P(^DGEN(27.15,23,0),U)="NOT APPLICABLE" D Q
. . D CHKSTAT
. . I DGABORT=0 S DGMSG=(" >> NOT APPLICABLE already exists in Enrollment Status file (#27.15)") D MSG(1) Q
. . I DGABORT=1 D SETSTAT
. . I DGABORT=0 S DGMSG=(" >> NOT APPLICABLE updated in Enrollment Status file (#27.15)") D MSG(1)
. I $P(^DGEN(27.15,23,0),U)'="NOT APPLICABLE" D Q
. . S DGMSG=" >> File 27.15 has an existing, invalid Entry #23" D MSG(1)
. . S DGABORT=1
NEWSTAT ;set .01 and .02 fields
; .01 - NOT APPLICABLE
; .02 - N:NOT ENROLLED
;
N DGFDA,DGIEN
S DGFDA(1,27.15,"+1,",.01)=DGSTAT
S DGFDA(1,27.15,"+1,",.02)=DGCAT
S DGIEN=23
K DGERR
D UPDATE^DIE("","DGFDA(1)","DGIEN","DGERR")
I $D(DGERR) D ERR Q DGABORT
S DGMSG=(" >> NOT APPLICABLE added to Enrollment Status file (#27.15)") D MSG(1)
S DGABORT=0
Q DGABORT
CHKSTAT ;check to see if existing NOT APPLICABLE entry has "N" for .02 field
I $P(^DGEN(27.15,23,0),U,2)="N" S DGABORT=0
Q
SETSTAT ;set .02 field (Enr Category) to "N" (Not Enrolled) on existing N/A entry
N DGFDA
S DGFDA(27.15,23_",",.02)=DGCAT
K DGERR
D FILE^DIE("","DGFDA","DGERR")
I $D(DGERR) D ERR S DGABORT=1 Q ;S DGMSG="Unable to update ""NOT APPLICABLE"" Enrollment Status in file 27.15." D MSG(0) S DGOK=2 Q
I '$D(DGERR) S DGABORT=0 ;DGMSG=" NOT APPLICABLE entry in file 27.15 successfully updated." D MSG(1) S DGOK=1
Q
ERR ;set error message into DGMSG for installation message
N DGC,DGCC
S (DGC,DGCC)=0
F S DGC=$O(DGERR("DIERR",DGC)) Q:'DGC D
. F S DGCC=$O(DGERR("DIERR",DGC,"TEXT",DGCC)) Q:'DGCC D
. . S DGMSG=DGERR("DIERR",DGC,"TEXT",DGCC) I DGC=1,(DGCC=1) D MSG(1) Q
. . D MSG(0)
K DGERR
Q
MSG(DGB) ;generate installation message
;if DGB=1, need a blank line before message
I DGB=1 D BMES^XPDUTL(DGMSG) Q
D MES^XPDUTL(DGMSG)
Q
;
CREF ;index fuile #35 with new "C" cross reference
N DIK
S DIK="^DIC(35,",DIK(1)="1^C"
D ENALL^DIK
;
TEXT ;FILE#;FIELD#~VALUE;FIELD#~VALUE;FIELD#~VALUE.....
;;301.92;.01~PROVINCE;.02~PID114F;.03~1;.04~2;.05~.1171;.08~1;10~S DR=.1171 D LOOK^IVMPREC9;20~S DR=.1171 D LOOK^IVMPREC9
;;301.92;.01~POSTAL CODE;.02~PID115F;.03~1;.04~2;.05~.1172;.08~1;10~S DR=.1172 D LOOK^IVMPREC9;20~S DR=.1172 D LOOK^IVMPREC9
;;301.92;.01~COUNTRY;.02~PID116;.03~1;.04~2;.05~.1173;.08~1;10~S DR=.1173 D LOOK^IVMPREC9;20~S DR=.1173 D LOOK^IVMPREC9
;;301.92;.01~BAD ADDRESS INDICATOR;.02~PID117;.03~1;.04~2;.05~.121;.08~1;10~S DR=.121 D LOOK^IVMPREC9;20~S DR=.121 D LOOK^IVMPREC9
;;301.92;.01~STREET ADDRESS [LINE 3];.02~PID118;.03~1;.04~2;.05~.113;.08~1;10~S Y=$P(VAPA(3),"^");20~S Y=VAPA(3)
;;301.92;.01~PAGER NUMBER;.02~PID13B;.03~1;.04~2;.05~.135;.08~1;10~S DR=.135 D LOOK^IVMPREC9;20~S DR=.135 D LOOK^IVMPREC9
;;301.92;.01~CELLULAR NUMBER;.02~PID13C;.03~1;.04~2;.05~.134;.08~1;10~S DR=.134 D LOOK^IVMPREC9;20~S DR=.134 D LOOK^IVMPREC9
;;301.92;.01~EMAIL ADDRESS;.02~PID13E;.03~1;.04~2;.05~.133;.08~1;10~S DR=.133 D LOOK^IVMPREC9;20~S DR=.133 D LOOK^IVMPREC9
;;301.92;.01~PAGER CHANGE DT/TM;.02~RF171B;.03~1;.04~2;.05~.1312;.08~1;10~S DR=.1312 D LOOK^IVMPREC9;20~S DR=.1312 D LOOK^IVMPREC9
;;301.92;.01~PAGER CHANGE SOURCE;.02~RF162B;.03~1;.04~2;.05~.1313;.08~1;10~S DR=.1313 D LOOK^IVMPREC9;20~S DR=.1313 D LOOK^IVMPREC9
;;301.92;.01~PAGER CHANGE SITE;.02~RF161B;.03~1;.04~2;.05~.1314;.08~1;10~S DR=.1314 D LOOK^IVMPREC9;20~S DR=.1314 D LOOK^IVMPREC9
;;301.92;.01~CELL PHONE CHANGE DT/TM;.02~RF171C;.03~1;.04~2;.05~.139;.08~1;10~S DR=.139 D LOOK^IVMPREC9;20~S DR=.139 D LOOK^IVMPREC9
;;301.92;.01~CELL PHONE CHANGE SOURCE;.02~RF162C;.03~1;.04~2;.05~.1311;.08~1;10~S DR=.1311 D LOOK^IVMPREC9;20~S DR=.1311 D LOOK^IVMPREC9
;;301.92;.01~CELL PHONE CHANGE SITE;.02~RF161C;.03~1;.04~2;.05~.13111;.08~1;10~S DR=.13111 D LOOK^IVMPREC9;20~S DR=.13111 D LOOK^IVMPREC9
;;301.92;.01~EMAIL CHANGE DT/TM;.02~RF171E;.03~1;.04~2;.05~.136;.08~1;10~S DR=.136 D LOOK^IVMPREC9;20~S DR=.136 D LOOK^IVMPREC9
;;301.92;.01~EMAIL CHANGE SOURCE;.02~RF162E;.03~1;.04~2;.05~.137;.08~1;10~S DR=.137 D LOOK^IVMPREC9;20~S DR=.137 D LOOK^IVMPREC9
;;301.92;.01~EMAIL CHANGE SITE;.02~RF161E;.03~1;.04~2;.05~.138;.08~1;10~S DR=.138 D LOOK^IVMPREC9;20~S DR=.138 D LOOK^IVMPREC9
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53688P 9459 printed Apr 09, 2024@22:01:50 Page 2
DG53688P ;ALB/CKN,BAJ,ERC - Patch DG*5.3*688 Install Utility Routine ; 8/15/08 12:03pm
+1 ;;5.3;Registration;**688**;AUG 13, 1993;Build 29
+2 QUIT
EP ;Entry point - Driver
+1 NEW ELEMNT,I,J,ABORT,EXIST,DMSG,ACTION
+2 ;
+3 ; Run trigger clean-up on Patient file per EVC_CR5834
+4 DO START^DG53688A
+5 ;Run field defintion clean-up per EVC_CR7473
DO START^DG53688B
+6 ;
+7 SET GLOBAL="^IVM"
SET ABORT=0
SET DMSG=""
SET ACTION="create"
+8 FOR I=1:1
SET ELEMNT=$PIECE($TEXT(TEXT+I),";;",2)
if ELEMNT="QUIT"!(ABORT)
QUIT
Begin DoDot:1
+9 SET FILE=$PIECE(ELEMNT,";",1)
SET EXIST=0
+10 KILL DGDATA
SET (DATA,SUB)=""
FOR J=2:1:$LENGTH(ELEMNT,";")
SET DATA=$PIECE(ELEMNT,";",J)
Begin DoDot:2
+11 SET SUB=$PIECE(DATA,"~",1)
SET VALUE=$PIECE(DATA,"~",2)
+12 SET DGDATA(SUB)=VALUE
+13 IF SUB=.01
IF $$ISTHERE(FILE,.DGDATA,GLOBAL)
SET EXIST=1
End DoDot:2
if EXIST
QUIT
+14 IF 'EXIST
Begin DoDot:2
+15 IF '$$ADD^DGENDBS(FILE,,.DGDATA)
SET ABORT=1
End DoDot:2
End DoDot:1
+16 ; setup message variable
+17 SET DMSG=$GET(DGDATA(.01))
+18 ; if Ok so far, install #506 modification & #88 addition
+19 ;
+20 IF 'ABORT
SET ACTION="modify"
SET DMSG="INCONSISTENT DATA ELEMENT #506"
SET ABORT=$$506()
+21 IF 'ABORT
SET DMSG="INCONSISTENT DATA ELEMENT #88"
SET ABORT=$$88()
+22 ;
+23 ;add NOT APPLICABLE Enrollment Status to file 27.15
+24 IF 'ABORT
Begin DoDot:1
+25 NEW DGABORT
+26 SET ACTION="add"
SET DMSG="ENROLLMENT STATUS #23"
SET ABORT=$$ENRSTAT()
End DoDot:1
+27 ;
+28 IF ABORT
Begin DoDot:1
+29 SET XPDABORT=2
+30 DO BMES^XPDUTL("Install process could not "_ACTION_" an entry in file for "_DMSG)
+31 DO BMES^XPDUTL(" <<<< INSTALLATION ABORTED >>>>")
End DoDot:1
+32 QUIT
+33 ;
ISTHERE(FILE,DGDATA,GLOBAL) ;
+1 NEW FOUND,GLOB
+2 SET FOUND=0
+3 SET GLOB=GLOBAL_"(FILE,""B"",DGDATA(.01))"
+4 IF $DATA(@GLOB)
Begin DoDot:1
+5 DO BMES^XPDUTL(" Internal Entry Value for .01 -- "_DGDATA(.01)_" -- already exists in file "_FILE)
+6 SET FOUND=1
End DoDot:1
+7 QUIT FOUND
+8 ;
HECMSG ; Send message to HEC Legacy that install is complete.
+1 ;
+2 ;also index the Other Federal Agency file (#35) with the new "C" cross reference
+3 DO CREF
+4 ;
+5 NEW SITE,STATN,PRODFLG,XMDUZ,XMSUB,XMY,XMTEXT,MSG,DIFROM
+6 SET SITE=$$SITE^VASITE
SET STATN=$PIECE($GET(SITE),U,3)
+7 SET PRODFLG=$$GET1^DIQ(869.3,"1,",.03,"I")="P"
+8 SET XMDUZ="EVC I2 Install"
+9 SET XMSUB=XMDUZ_" - "_STATN_" (DG*5.3*688)"
+10 if PRODFLG
SET XMY("S.IVMB*2*860 MESSAGE@IVM.DOMAIN.EXT")=""
+11 if 'PRODFLG
SET XMY(DUZ)=""
+12 SET XMTEXT="MSG("
+13 SET $PIECE(MSG(1),U)="IVMB*2*860"
+14 SET $PIECE(MSG(1),U,2)=STATN
+15 SET $PIECE(MSG(1),U,3)="DG*5.3*688 "_$$FMTE^XLFDT($$NOW^XLFDT(),"5D")
+16 SET $PIECE(MSG(1),U,4)=PRODFLG
+17 SET $PIECE(MSG(1),U,5)=1
+18 DO ^XMD
+19 DO BMES^XPDUTL(" *** Install Message Sent to HEC Legacy ***")
+20 QUIT
+21 ;
506() ; Update entry #506 in the INCONSISTENT DATA ELEMENTS file (#38.6)
+1 ;-----------------------------------------------------------------
+2 ;-----------------------------------------------------------------
+3 NEW DATA,DGENDA,DGERR,FILE,DGTITL,ABORT,DGWP
+4 SET FILE=38.6
SET DGENDA=506
SET DGTITL="Entry #506 SW ASIA CONDITIONS"
SET ABORT=0
+5 DO BMES^XPDUTL(" >> Modifying entry #506 in the INCONSISTENT DATA ELEMENTS file (#38.6)")
+6 SET DATA(.01)="VALUE FOR SW ASIA COND INVALID"
+7 SET DATA(2)="THE VALUE FOR SW ASIA CONDITIONS MUST BE EITHER YES, NO, OR UNKNOWN"
+8 SET DATA(50)="DGWP"
+9 SET DGWP(1,0)="If completed, the value for Southwest Asia Conditions must be"
+10 SET DGWP(2,0)="Yes, No or Unknown."
+11 IF '$$UPD^DGENDBS(FILE,.DGENDA,.DATA,.DGERR)
Begin DoDot:1
+12 DO BMES^XPDUTL(" >>> ERROR! "_DGTITL_" not changed in file #38.6")
+13 DO MES^XPDUTL(" "_$GET(DGERR))
+14 SET ABORT=1
End DoDot:1
+15 if 'ABORT
DO BMES^XPDUTL(" "_DGTITL_" successfully modified.")
+16 QUIT ABORT
+17 ;
88() ; Add entry #88 TEMP. ADDRESS DATA INCOMPLETE
+1 NEW DATA,DGERR,DGTITL,ABORT,I,DGWP,ROOT,QUIT,DGFDA,DGIEN
+2 SET DGIEN(1)=88
SET (ABORT,QUIT)=0
+3 SET DGTITL="Entry #88 'TEMPORARY ADDRESS' DATA IS INCOMPLETE"
+4 DO BMES^XPDUTL(" >> Modifying entry #88 in the INCONSISTENT DATA ELEMENTS file (#38.6)")
+5 SET ROOT="DGFDA(38.6,""?+1,"")"
+6 SET @ROOT@(.01)="TEMP. ADDRESS DATA INCOMPLETE"
+7 IF $DATA(^DGIN(38.6,88,0))
Begin DoDot:1
+8 IF $PIECE(^DGIN(38.6,88,0),U,1)'=@ROOT@(.01)
Begin DoDot:2
+9 DO MES^XPDUTL(" >>> ERROR: Entry # 88 needs to be reviewed by NVS! <<<")
+10 DO MES^XPDUTL(" Existing entry: "_$PIECE($GET(^DGIN(38.6,88,0)),"^"))
+11 DO MES^XPDUTL(" Incoming entry: "_$GET(@ROOT@(.01)))
+12 DO BMES^XPDUTL(" <<<< INSTALLATION ABORTED >>>>")
+13 SET ABORT=1
End DoDot:2
QUIT
+14 DO BMES^XPDUTL(" >> Entry #88 already exists in the INCONSISTENT DATA ELEMENTS file (#38.6)")
End DoDot:1
QUIT ABORT
+15 SET @ROOT@(2)="'TEMPORARY ADDRESS' DATA IS INCOMPLETE"
+16 FOR I=3:1:6
SET @ROOT@(I)=0
+17 SET @ROOT@(50)="DGWP"
+18 SET DGWP(1,0)="Inconsistency results if a record with an active temporary"
+19 SET DGWP(2,0)="address does not contain the first line of the street address, city, state,"
+20 SET DGWP(3,0)="and zip code for a domestic temporary address, or, for a foreign temporary"
+21 SET DGWP(4,0)="address, the first line of the street address and the city."
+22 DO UPDATE^DIE("","DGFDA","DGIEN","DGERR")
+23 IF $DATA(DGERR)
Begin DoDot:1
+24 DO BMES^XPDUTL(" >>> ERROR! "_DGTITL_" not added to file #38.6")
+25 DO MES^XPDUTL(" "_DGERR("DIERR",1)_": "_DGERR("DIERR",1,"TEXT",1))
+26 DO BMES^XPDUTL(" <<<< INSTALLATION ABORTED >>>>")
+27 SET ABORT=1
End DoDot:1
+28 if 'ABORT
DO BMES^XPDUTL(" "_DGTITL_" successfully added.")
+29 QUIT ABORT
+30 ;
ENRSTAT() ;Add NOT APPLICABLE to the Enrollment Status file (#27.15)
+1 NEW DGCAT,DGMSG,DGSTAT
+2 SET DGSTAT="NOT APPLICABLE"
+3 SET DGCAT="N"
+4 SET DGABORT=1
+5 ;check to see if there is an entry already
+6 IF $DATA(^DGEN(27.15,23))
Begin DoDot:1
+7 IF $PIECE(^DGEN(27.15,23,0),U)="NOT APPLICABLE"
Begin DoDot:2
+8 DO CHKSTAT
+9 IF DGABORT=0
SET DGMSG=(" >> NOT APPLICABLE already exists in Enrollment Status file (#27.15)")
DO MSG(1)
QUIT
+10 IF DGABORT=1
DO SETSTAT
+11 IF DGABORT=0
SET DGMSG=(" >> NOT APPLICABLE updated in Enrollment Status file (#27.15)")
DO MSG(1)
End DoDot:2
QUIT
+12 IF $PIECE(^DGEN(27.15,23,0),U)'="NOT APPLICABLE"
Begin DoDot:2
+13 SET DGMSG=" >> File 27.15 has an existing, invalid Entry #23"
DO MSG(1)
+14 SET DGABORT=1
End DoDot:2
QUIT
End DoDot:1
QUIT DGABORT
NEWSTAT ;set .01 and .02 fields
+1 ; .01 - NOT APPLICABLE
+2 ; .02 - N:NOT ENROLLED
+3 ;
+4 NEW DGFDA,DGIEN
+5 SET DGFDA(1,27.15,"+1,",.01)=DGSTAT
+6 SET DGFDA(1,27.15,"+1,",.02)=DGCAT
+7 SET DGIEN=23
+8 KILL DGERR
+9 DO UPDATE^DIE("","DGFDA(1)","DGIEN","DGERR")
+10 IF $DATA(DGERR)
DO ERR
QUIT DGABORT
+11 SET DGMSG=(" >> NOT APPLICABLE added to Enrollment Status file (#27.15)")
DO MSG(1)
+12 SET DGABORT=0
+13 QUIT DGABORT
CHKSTAT ;check to see if existing NOT APPLICABLE entry has "N" for .02 field
+1 IF $PIECE(^DGEN(27.15,23,0),U,2)="N"
SET DGABORT=0
+2 QUIT
SETSTAT ;set .02 field (Enr Category) to "N" (Not Enrolled) on existing N/A entry
+1 NEW DGFDA
+2 SET DGFDA(27.15,23_",",.02)=DGCAT
+3 KILL DGERR
+4 DO FILE^DIE("","DGFDA","DGERR")
+5 ;S DGMSG="Unable to update ""NOT APPLICABLE"" Enrollment Status in file 27.15." D MSG(0) S DGOK=2 Q
IF $DATA(DGERR)
DO ERR
SET DGABORT=1
QUIT
+6 ;DGMSG=" NOT APPLICABLE entry in file 27.15 successfully updated." D MSG(1) S DGOK=1
IF '$DATA(DGERR)
SET DGABORT=0
+7 QUIT
ERR ;set error message into DGMSG for installation message
+1 NEW DGC,DGCC
+2 SET (DGC,DGCC)=0
+3 FOR
SET DGC=$ORDER(DGERR("DIERR",DGC))
if 'DGC
QUIT
Begin DoDot:1
+4 FOR
SET DGCC=$ORDER(DGERR("DIERR",DGC,"TEXT",DGCC))
if 'DGCC
QUIT
Begin DoDot:2
+5 SET DGMSG=DGERR("DIERR",DGC,"TEXT",DGCC)
IF DGC=1
IF (DGCC=1)
DO MSG(1)
QUIT
+6 DO MSG(0)
End DoDot:2
End DoDot:1
+7 KILL DGERR
+8 QUIT
MSG(DGB) ;generate installation message
+1 ;if DGB=1, need a blank line before message
+2 IF DGB=1
DO BMES^XPDUTL(DGMSG)
QUIT
+3 DO MES^XPDUTL(DGMSG)
+4 QUIT
+5 ;
CREF ;index fuile #35 with new "C" cross reference
+1 NEW DIK
+2 SET DIK="^DIC(35,"
SET DIK(1)="1^C"
+3 DO ENALL^DIK
+4 ;
TEXT ;FILE#;FIELD#~VALUE;FIELD#~VALUE;FIELD#~VALUE.....
+1 ;;301.92;.01~PROVINCE;.02~PID114F;.03~1;.04~2;.05~.1171;.08~1;10~S DR=.1171 D LOOK^IVMPREC9;20~S DR=.1171 D LOOK^IVMPREC9
+2 ;;301.92;.01~POSTAL CODE;.02~PID115F;.03~1;.04~2;.05~.1172;.08~1;10~S DR=.1172 D LOOK^IVMPREC9;20~S DR=.1172 D LOOK^IVMPREC9
+3 ;;301.92;.01~COUNTRY;.02~PID116;.03~1;.04~2;.05~.1173;.08~1;10~S DR=.1173 D LOOK^IVMPREC9;20~S DR=.1173 D LOOK^IVMPREC9
+4 ;;301.92;.01~BAD ADDRESS INDICATOR;.02~PID117;.03~1;.04~2;.05~.121;.08~1;10~S DR=.121 D LOOK^IVMPREC9;20~S DR=.121 D LOOK^IVMPREC9
+5 ;;301.92;.01~STREET ADDRESS [LINE 3];.02~PID118;.03~1;.04~2;.05~.113;.08~1;10~S Y=$P(VAPA(3),"^");20~S Y=VAPA(3)
+6 ;;301.92;.01~PAGER NUMBER;.02~PID13B;.03~1;.04~2;.05~.135;.08~1;10~S DR=.135 D LOOK^IVMPREC9;20~S DR=.135 D LOOK^IVMPREC9
+7 ;;301.92;.01~CELLULAR NUMBER;.02~PID13C;.03~1;.04~2;.05~.134;.08~1;10~S DR=.134 D LOOK^IVMPREC9;20~S DR=.134 D LOOK^IVMPREC9
+8 ;;301.92;.01~EMAIL ADDRESS;.02~PID13E;.03~1;.04~2;.05~.133;.08~1;10~S DR=.133 D LOOK^IVMPREC9;20~S DR=.133 D LOOK^IVMPREC9
+9 ;;301.92;.01~PAGER CHANGE DT/TM;.02~RF171B;.03~1;.04~2;.05~.1312;.08~1;10~S DR=.1312 D LOOK^IVMPREC9;20~S DR=.1312 D LOOK^IVMPREC9
+10 ;;301.92;.01~PAGER CHANGE SOURCE;.02~RF162B;.03~1;.04~2;.05~.1313;.08~1;10~S DR=.1313 D LOOK^IVMPREC9;20~S DR=.1313 D LOOK^IVMPREC9
+11 ;;301.92;.01~PAGER CHANGE SITE;.02~RF161B;.03~1;.04~2;.05~.1314;.08~1;10~S DR=.1314 D LOOK^IVMPREC9;20~S DR=.1314 D LOOK^IVMPREC9
+12 ;;301.92;.01~CELL PHONE CHANGE DT/TM;.02~RF171C;.03~1;.04~2;.05~.139;.08~1;10~S DR=.139 D LOOK^IVMPREC9;20~S DR=.139 D LOOK^IVMPREC9
+13 ;;301.92;.01~CELL PHONE CHANGE SOURCE;.02~RF162C;.03~1;.04~2;.05~.1311;.08~1;10~S DR=.1311 D LOOK^IVMPREC9;20~S DR=.1311 D LOOK^IVMPREC9
+14 ;;301.92;.01~CELL PHONE CHANGE SITE;.02~RF161C;.03~1;.04~2;.05~.13111;.08~1;10~S DR=.13111 D LOOK^IVMPREC9;20~S DR=.13111 D LOOK^IVMPREC9
+15 ;;301.92;.01~EMAIL CHANGE DT/TM;.02~RF171E;.03~1;.04~2;.05~.136;.08~1;10~S DR=.136 D LOOK^IVMPREC9;20~S DR=.136 D LOOK^IVMPREC9
+16 ;;301.92;.01~EMAIL CHANGE SOURCE;.02~RF162E;.03~1;.04~2;.05~.137;.08~1;10~S DR=.137 D LOOK^IVMPREC9;20~S DR=.137 D LOOK^IVMPREC9
+17 ;;301.92;.01~EMAIL CHANGE SITE;.02~RF161E;.03~1;.04~2;.05~.138;.08~1;10~S DR=.138 D LOOK^IVMPREC9;20~S DR=.138 D LOOK^IVMPREC9
+18 ;;QUIT
