Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DG53688P

DG53688P.m

Go to the documentation of this file. 
  1. DG53688P ;ALB/CKN,BAJ,ERC - Patch DG*5.3*688 Install Utility Routine ; 8/15/08 12:03pm
  1.  ;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20
  1.  Q
  1. EP ;Entry point - Driver
  1.  N ELEMNT,I,J,ABORT,EXIST,DMSG,ACTION
  1.  ;
  1.  ; Run trigger clean-up on Patient file per EVC_CR5834
  1.  D START^DG53688A
  1.  D START^DG53688B    ;Run field defintion clean-up per EVC_CR7473
  1.  ;
  1.  S GLOBAL="^IVM",ABORT=0,DMSG="",ACTION="create"
  1.  F I=1:1 S ELEMNT=$P($T(TEXT+I),";;",2) Q:ELEMNT="QUIT"!(ABORT)  D
  1.  . S FILE=$P(ELEMNT,";",1),EXIST=0
  1.  . K DGDATA S (DATA,SUB)="" F J=2:1:$L(ELEMNT,";") S DATA=$P(ELEMNT,";",J) D  Q:EXIST
  1.  . . S SUB=$P(DATA,"~",1),VALUE=$P(DATA,"~",2)
  1.  . . S DGDATA(SUB)=VALUE
  1.  . . I SUB=.01,$$ISTHERE(FILE,.DGDATA,GLOBAL) S EXIST=1
  1.  . I 'EXIST D
  1.  . . I '$$ADD^DGENDBS(FILE,,.DGDATA) S ABORT=1
  1.  ; setup message variable
  1.  S DMSG=$G(DGDATA(.01))
  1.  ; if Ok so far, install #506 modification & #88 addition
  1.  ; 
  1.  I 'ABORT S ACTION="modify",DMSG="INCONSISTENT DATA ELEMENT #506",ABORT=$$506()
  1.  I 'ABORT S DMSG="INCONSISTENT DATA ELEMENT #88",ABORT=$$88()
  1.  ;
  1.  ;add NOT APPLICABLE Enrollment Status to file 27.15
  1.  I 'ABORT D
  1.  . N DGABORT
  1.  . S ACTION="add",DMSG="ENROLLMENT STATUS #23",ABORT=$$ENRSTAT()
  1.  ;
  1.  I ABORT D
  1.  . S XPDABORT=2
  1.  . D BMES^XPDUTL("Install process could not "_ACTION_" an entry in file for "_DMSG)
  1.  . D BMES^XPDUTL("                        <<<< INSTALLATION ABORTED >>>>")
  1.  Q
  1.  ;
  1. ISTHERE(FILE,DGDATA,GLOBAL) ;
  1.  N FOUND,GLOB
  1.  S FOUND=0
  1.  S GLOB=GLOBAL_"(FILE,""B"",DGDATA(.01))"
  1.  I $D(@GLOB) D
  1.  . D BMES^XPDUTL("   Internal Entry Value for .01 -- "_DGDATA(.01)_" -- already exists in file "_FILE)
  1.  . S FOUND=1
  1.  Q FOUND
  1.  ;
  1. HECMSG ; Send message to HEC Legacy that install is complete.
  1.  ;
  1.  ;also index the Other Federal Agency file (#35) with the new "C" cross reference
  1.  D CREF
  1.  ;
  1.  N SITE,STATN,PRODFLG,XMDUZ,XMSUB,XMY,XMTEXT,MSG,DIFROM
  1.  S SITE=$$SITE^VASITE,STATN=$P($G(SITE),U,3)
  1.  S PRODFLG=$$GET1^DIQ(869.3,"1,",.03,"I")="P"
  1.  S XMDUZ="EVC I2 Install"
  1.  S XMSUB=XMDUZ_" - "_STATN_" (DG*5.3*688)"
  1.  S:PRODFLG XMY("S.IVMB*2*860 MESSAGE@IVM.MED.VA.GOV")=""
  1.  S:'PRODFLG XMY(DUZ)=""
  1.  S XMTEXT="MSG("
  1.  S $P(MSG(1),U)="IVMB*2*860"
  1.  S $P(MSG(1),U,2)=STATN
  1.  S $P(MSG(1),U,3)="DG*5.3*688 "_$$FMTE^XLFDT($$NOW^XLFDT(),"5D")
  1.  S $P(MSG(1),U,4)=PRODFLG
  1.  S $P(MSG(1),U,5)=1
  1.  D ^XMD
  1.  D BMES^XPDUTL("    *** Install Message Sent to HEC Legacy ***")
  1.  Q
  1.  ;
  1. 506() ; Update entry #506 in the INCONSISTENT DATA ELEMENTS file (#38.6)
  1.  ;-----------------------------------------------------------------
  1.  ;-----------------------------------------------------------------
  1.  N DATA,DGENDA,DGERR,FILE,DGTITL,ABORT,DGWP
  1.  S FILE=38.6,DGENDA=506,DGTITL="Entry #506 SW ASIA CONDITIONS",ABORT=0
  1.  D BMES^XPDUTL("  >> Modifying entry #506 in the INCONSISTENT DATA ELEMENTS file (#38.6)")
  1.  S DATA(.01)="VALUE FOR SW ASIA COND INVALID"
  1.  S DATA(2)="THE VALUE FOR SW ASIA CONDITIONS MUST BE EITHER YES, NO, OR UNKNOWN"
  1.  S DATA(50)="DGWP"
  1.  S DGWP(1,0)="If completed, the value for Southwest Asia Conditions must be"
  1.  S DGWP(2,0)="Yes, No or Unknown."
  1.  I '$$UPD^DGENDBS(FILE,.DGENDA,.DATA,.DGERR) D
  1.  . D BMES^XPDUTL("   >>> ERROR! "_DGTITL_" not changed in file #38.6")
  1.  . D MES^XPDUTL("       "_$G(DGERR))
  1.  . S ABORT=1
  1.  D:'ABORT BMES^XPDUTL("      "_DGTITL_" successfully modified.")
  1.  Q ABORT
  1.  ;
  1. 88() ; Add entry #88 TEMP. ADDRESS DATA INCOMPLETE
  1.  N DATA,DGERR,DGTITL,ABORT,I,DGWP,ROOT,QUIT,DGFDA,DGIEN
  1.  S DGIEN(1)=88,(ABORT,QUIT)=0
  1.  S DGTITL="Entry #88 'TEMPORARY ADDRESS' DATA IS INCOMPLETE"
  1.  D BMES^XPDUTL("  >> Modifying entry #88 in the INCONSISTENT DATA ELEMENTS file (#38.6)")
  1.  S ROOT="DGFDA(38.6,""?+1,"")"
  1.  S @ROOT@(.01)="TEMP. ADDRESS DATA INCOMPLETE"
  1.  I $D(^DGIN(38.6,88,0)) D  Q ABORT
  1.  . I $P(^DGIN(38.6,88,0),U,1)'=@ROOT@(.01) D  Q
  1.  . . D MES^XPDUTL("     >>> ERROR: Entry # 88 needs to be reviewed by NVS! <<<")
  1.  . . D MES^XPDUTL("           Existing entry: "_$P($G(^DGIN(38.6,88,0)),"^"))
  1.  . . D MES^XPDUTL("           Incoming entry: "_$G(@ROOT@(.01)))
  1.  . . D BMES^XPDUTL("                        <<<< INSTALLATION ABORTED >>>>")
  1.  . . S ABORT=1
  1.  . D BMES^XPDUTL("  >> Entry #88 already exists in the INCONSISTENT DATA ELEMENTS file (#38.6)")
  1.  S @ROOT@(2)="'TEMPORARY ADDRESS' DATA IS INCOMPLETE"
  1.  F I=3:1:6 S @ROOT@(I)=0
  1.  S @ROOT@(50)="DGWP"
  1.  S DGWP(1,0)="Inconsistency results if a record with an active temporary"
  1.  S DGWP(2,0)="address does not contain the first line of the street address, city, state,"
  1.  S DGWP(3,0)="and zip code for a domestic temporary address, or, for a foreign temporary"
  1.  S DGWP(4,0)="address, the first line of the street address and the city."
  1.  D UPDATE^DIE("","DGFDA","DGIEN","DGERR")
  1.  I $D(DGERR) D
  1.  . D BMES^XPDUTL("   >>> ERROR! "_DGTITL_" not added to file #38.6")
  1.  . D MES^XPDUTL("     "_DGERR("DIERR",1)_": "_DGERR("DIERR",1,"TEXT",1))
  1.  . D BMES^XPDUTL("                        <<<< INSTALLATION ABORTED >>>>")
  1.  . S ABORT=1
  1.  D:'ABORT BMES^XPDUTL("      "_DGTITL_" successfully added.")
  1.  Q ABORT
  1.  ;
  1. ENRSTAT() ;Add NOT APPLICABLE to the Enrollment Status file (#27.15)
  1.  N DGCAT,DGMSG,DGSTAT
  1.  S DGSTAT="NOT APPLICABLE"
  1.  S DGCAT="N"
  1.  S DGABORT=1
  1.  ;check to see if there is an entry already
  1.  I $D(^DGEN(27.15,23)) D  Q DGABORT
  1.  . I $P(^DGEN(27.15,23,0),U)="NOT APPLICABLE" D  Q
  1.  . . D CHKSTAT
  1.  . . I DGABORT=0 S DGMSG=("  >> NOT APPLICABLE already exists in Enrollment Status file (#27.15)") D MSG(1)  Q
  1.  . . I DGABORT=1 D SETSTAT
  1.  . . I DGABORT=0 S DGMSG=("  >> NOT APPLICABLE updated in Enrollment Status file (#27.15)") D MSG(1)
  1.  . I $P(^DGEN(27.15,23,0),U)'="NOT APPLICABLE" D  Q
  1.  . . S DGMSG="  >> File 27.15 has an existing, invalid Entry #23" D MSG(1)
  1.  . . S DGABORT=1
  1. NEWSTAT ;set .01 and .02 fields
  1.  ;  .01 - NOT APPLICABLE
  1.  ;  .02 - N:NOT ENROLLED
  1.  ;
  1.  N DGFDA,DGIEN
  1.  S DGFDA(1,27.15,"+1,",.01)=DGSTAT
  1.  S DGFDA(1,27.15,"+1,",.02)=DGCAT
  1.  S DGIEN=23
  1.  K DGERR
  1.  D UPDATE^DIE("","DGFDA(1)","DGIEN","DGERR")
  1.  I $D(DGERR) D ERR Q DGABORT
  1.  S DGMSG=("  >> NOT APPLICABLE added to Enrollment Status file (#27.15)") D MSG(1)
  1.  S DGABORT=0
  1.  Q DGABORT
  1. CHKSTAT ;check to see if existing NOT APPLICABLE entry has "N" for .02 field
  1.  I $P(^DGEN(27.15,23,0),U,2)="N" S DGABORT=0
  1.  Q
  1. SETSTAT ;set .02 field (Enr Category) to "N" (Not Enrolled) on existing N/A entry
  1.  N DGFDA
  1.  S DGFDA(27.15,23_",",.02)=DGCAT
  1.  K DGERR
  1.  D FILE^DIE("","DGFDA","DGERR")
  1.  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
  1.  I '$D(DGERR) S DGABORT=0 ;DGMSG="    NOT APPLICABLE entry in file 27.15 successfully updated." D MSG(1) S DGOK=1
  1.  Q
  1. ERR ;set error message into DGMSG for installation message
  1.  N DGC,DGCC
  1.  S (DGC,DGCC)=0
  1.  F  S DGC=$O(DGERR("DIERR",DGC)) Q:'DGC  D
  1.  . F  S DGCC=$O(DGERR("DIERR",DGC,"TEXT",DGCC)) Q:'DGCC  D
  1.  . . S DGMSG=DGERR("DIERR",DGC,"TEXT",DGCC) I DGC=1,(DGCC=1) D MSG(1) Q
  1.  . . D MSG(0)
  1.  K DGERR
  1.  Q
  1. MSG(DGB) ;generate installation message
  1.  ;if DGB=1, need a blank line before message
  1.  I DGB=1 D BMES^XPDUTL(DGMSG) Q
  1.  D MES^XPDUTL(DGMSG)
  1.  Q
  1.  ;
  1. CREF ;index fuile #35 with new "C" cross reference
  1.  N DIK
  1.  S DIK="^DIC(35,",DIK(1)="1^C"
  1.  D ENALL^DIK
  1.  ;
  1. 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
  1.  ;;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
  1.  ;;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
  1.  ;;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
  1.  ;;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)
  1.  ;;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
  1.  ;;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
  1.  ;;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
  1.  ;;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
  1.  ;;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
  1.  ;;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
  1.  ;;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
  1.  ;;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
  1.  ;;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
  1.  ;;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
  1.  ;;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
  1.  ;;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
  1.  ;;QUIT