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

DG648PST.m

Go to the documentation of this file. 
  1. DG648PST ;BIR/CMC-PATCH DG*5.3*648 POST INSTALLATION ROUTINE ;2/11/05
  1.  ;;5.3;Registration;**648**;Aug 13, 1993
  1.  ;
  1. POST ;Post init
  1.  N DGFLD,DGMFLD,DGOUT,DGFILE
  1.  ;File cross references
  1.  D XR(2,.525) ;POW STATUS INDICATED?
  1.  ;;D XR(2.0361,.01) ;PATIENT ELIGIBILITIES MULTIPLE ELIGIBILITY FIELD -- MOVED TO DG*5.3*691
  1.  D TEMPL
  1.  ;fix missing leading zeros for ICN Checksums DD issue was corrected in MPIF*1.0*9
  1.  D MES^XPDUTL("  >>> Checking ICN Checksums for missing leading zeros. Job being tasked off.")
  1.  S ZTRTN="CHKSUM^DG648PST",ZTDESC="Correct missing leading zeros in ICN Checksum - DG*5.3*648"
  1.  S ZTIO="",ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,0,0,1,0)
  1.  I $D(DUZ) S ZTSAVE("DUZ")=DUZ
  1.  D ^%ZTLOAD
  1.  K ZTDESC,ZTDTH,ZTIO,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,%
  1.  Q
  1.  ;
  1. CHKSUM ;fix missing leading zeros for ICN Checksums
  1.  K ^XTMP("DG648","MISSING CHECKSUM"),^XTMP("DG648","CHECKSUM UPDATE"),^XTMP("DG648","CHECKSUM UPDATE FAIL")
  1.  N DFN,ICN,CHECK,DIE,DA,DR,X,Y,CNT,CNT2,CNT3,LEN
  1.  S (CNT2,CNT3,CNT,ICN)=0
  1.  F  S ICN=$O(^DPT("AICN",ICN)) Q:ICN=""  D
  1.  .Q:$E(ICN,1,3)=$P($$SITE^VASITE,"^",3)
  1.  .S DFN=$O(^DPT("AICN",ICN,""))
  1.  .I ICN'=$P($G(^DPT(DFN,"MPI")),"^") Q
  1.  .; ^ ONLY UPDATING PRIMARY ICN
  1.  .S CHECK=$P($G(^DPT(DFN,"MPI")),"^",2)
  1.  .I CHECK="" S CNT2=CNT2+1,^XTMP("DG648","MISSING CHECKSUM",CNT2)="DFN= "_DFN_"^"_"ICN= "_ICN Q
  1.  .S LEN=$L(CHECK)
  1.  .Q:LEN=6
  1.  .I LEN<6 S CHECK=$E(1000000+CHECK,2,7) ;adding missing leading zeros
  1.  .K X,Y,DIE,DA,DR
  1.  .S DA=DFN
  1.  .D LOCK(DA) ;LOCK DPT NODE "MPI"
  1.  .S DIE="^DPT(",DR="991.02///^S X=CHECK" D ^DIE
  1.  .L -^DPT(DA,"MPI")
  1.  .I +$G(Y)=-1 S CNT3=CNT3+1,^XTMP("DG648","CHECKSUM UPDATE FAIL",CNT3)="DFN= "_DFN_"^ICN= "_ICN_"^CHECKSUM= "_CHECK Q
  1.  .S CNT=CNT+1,^XTMP("DG648","CHECKSUM UPDATE",CNT)="DFN= "_DFN_"^ICN= "_ICN_"^CHECKSUM= "_CHECK
  1.  S ^XTMP("DG648","CHECKSUM UPDATE",CNT+2)="TOTAL: "_CNT,^XTMP("DG648","MISSING CHECKSUM",CNT2+2)="TOTAL: "_CNT2
  1.  S ^XTMP("DG648","CHECKSUM UPDATE FILE",CNT3+2)="TOTAL: "_CNT3
  1.  I CNT>0 D
  1.  .N DIFROM,XMSUB,XMTEXT,XMY
  1.  .S XMSUB="Updated Checksums post-init DG648 from "_$P($$SITE^VASITE,"^",3),XMY(DUZ)=""
  1.  .S XMTEXT="^XTMP(""DG648"",""CHECKSUM UPDATE"",",XMY("CHESNEY.CHRISTINE_M@DOMAIN.EXT")=""
  1.  .D ^XMD
  1.  I CNT2>0 D
  1.  .N DIFROM,XMSUB,XMTEXT,XMY
  1.  .S XMSUB="Missing Checksums post-init DG648 from "_$P($$SITE^VASITE,"^",3),XMY(DUZ)=""
  1.  .S XMTEXT="^XTMP(""DG648"",""MISSING CHECKSUM"",",XMY("CHESNEY.CHRISTINE_M@DOMAIN.EXT")=""
  1.  .D ^XMD
  1.  I CNT3>0 D
  1.  .N DIFROM,XMSUB,XMTEXT,XMY
  1.  .S XMSUB="Checksum updates failed in post-init DG648 from "_$P($$SITE^VASITE,"^",3),XMY(DUZ)=""
  1.  .S XMTEXT="^XTMP(""DG648"",""CHECKSUM UPDATE FAIL"",",XMY("CHESNEY.CHRISTINE_M@DOMAIN.EXT")=""
  1.  .D ^XMD
  1.  I CNT=0,CNT2=0,CNT3=0 D
  1.  .N DIFROM,XMSUB,XMTEXT,XMY,ARR
  1.  .S ARR(1)="No issues with Checksums at this site"
  1.  .S XMSUB="Checksum updates failed in post-init DG648 from "_$P($$SITE^VASITE,"^",3),XMY(DUZ)=""
  1.  .S XMTEXT="ARR(",XMY("CHESNEY.CHRISTINE_M@DOMAIN.EXT")=""
  1.  .D ^XMD
  1.  K ^XTMP("DG648","MISSING CHECKSUM"),^XTMP("DG648","CHECKSUM UPDATE"),^XTMP("DG648","CHECKSUM UPDATE FAIL")
  1.  Q
  1.  ;
  1. LOCK(IEN) ;
  1.  F  L +^DPT(IEN,"MPI"):10 Q:$T
  1.  Q
  1. XR(DGFILE,DGFLD) ;File index type cross references
  1.  ;
  1.  N DGFDA,DGIEN,DGWP,DGERR,DGXR,DGVAL,DGOUT,DIERR
  1.  ;Set up x-refs. Any value that has a ".", will have the period
  1.  ;replaved with a "D" to prevent x-ref's such as .11 and 11 having
  1.  ;identical xref names
  1.  ;I DGFILE=2.0361 S DGXR="AVAFC20361" ;ELIGIBILITY -- MOVED TO DG*5.3*691
  1.  I '$D(DGXR) S DGXR=$S(DGFLD[".":"AVAFC"_$P(DGFLD,".",2),1:"AVAFC"_DGFLD)
  1.  ;Check for existing x-ref
  1.  S DGVAL(1)=DGFILE,DGVAL(2)=DGXR
  1.  D FIND^DIC(.11,"","@;IXIE","KP",.DGVAL,"","","","","DGOUT")
  1.  I $D(DGOUT("DILIST",1)) D  Q
  1.  .D MES^XPDUTL("     >>> Cross reference "_DGXR_" already exists, nothing filed.")
  1.  .Q
  1.  ;Create filer array
  1.  S DGFDA(.11,"+1,",.01)=DGFILE                      ;FILE
  1.  S DGFDA(.11,"+1,",.02)=DGXR                        ;NAME
  1.  S DGFDA(.11,"+1,",.11)="This x-ref calls the DG FIELD MONITOR event point."     ;SHORT DESCRIPTION
  1.  S DGFDA(.11,"+1,",.2)="MU"                         ;TYPE
  1.  S DGFDA(.11,"+1,",.4)="F"                          ;EXECUTION
  1.  S DGFDA(.11,"+1,",.41)="I"                         ;ACTIVITY
  1.  S DGFDA(.11,"+1,",.5)="I"                          ;ROOT TYPE
  1.  S DGFDA(.11,"+1,",.51)=DGFILE                      ;ROOT FILE
  1.  S DGFDA(.11,"+1,",.42)="A"                         ;USE
  1.  S DGFDA(.11,"+1,",1.1)="D FC^DGFCPROT(.DA,"_DGFILE_","_DGFLD_",""SET"",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q"     ;SET LOGIC
  1.  S DGFDA(.11,"+1,",2.1)="D FC^DGFCPROT(.DA,"_DGFILE_","_DGFLD_",""KILL"",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q"     ;KILL LOGIC
  1.  ;CROSS REFERENCE VALUES
  1.  S DGFDA(.114,"+2,+1,",.01)=1                       ;ORDER NUMBER
  1.  S DGFDA(.114,"+2,+1,",1)="F"                       ;TYPE OF VALUE
  1.  S DGFDA(.114,"+2,+1,",2)=DGFILE                    ;FILE NUMBER
  1.  S DGFDA(.114,"+2,+1,",3)=DGFLD                     ;FIELD NUMBER
  1.  S DGFDA(.114,"+2,+1,",7)="F"                       ;COLLATION
  1.  ;DESCRIPTION
  1.  S DGWP(1)="This cross reference activates the DG FIELD MONITOR event point."
  1.  S DGWP(2)="Applications that wish to monitor edit activity related to this field may"
  1.  S DGWP(3)="subscribe to that event point and take action as indicated by the changes"
  1.  S DGWP(4)="that occur.  Refer to the DG FIELD MONITOR protocol for a description of"
  1.  S DGWP(5)="the information available at the time of the event."
  1.  ;File INDEX record
  1.  D UPDATE^DIE("","DGFDA","DGIEN","DGERR")
  1.  I $D(DIERR) D  Q
  1.  .N DGI S DGI=""
  1.  .D MES^XPDUTL("     >>> A problem has occurred during the filing of x-ref. "_DGXR_"!")
  1.  .D MES^XPDUTL("         Please contact Customer Support.")
  1.  .F  S DGI=$O(DGERR("DIERR",1,"TEXT",DGI)) Q:DGI=""  D
  1.  ..D MES^XPDUTL(DGERR("DIERR",1,"TEXT",DGI))
  1.  ..Q
  1.  .Q
  1.  S DGFLD(DGFILE,DGFLD)=""  ;Create list to recompile templates
  1.  D MES^XPDUTL("     >>> "_DGXR_" cross reference filed.")
  1.  ;File DESCRIPTION field
  1.  D WP^DIE(.11,DGIEN(1)_",",.1,"","DGWP")
  1.  Q
  1. TEMPL N GLOBAL,FIELD,NFIELD,FILE,CNT
  1.  D BMES^XPDUTL("Beginning to compile templates on the PATIENT (#2) file.")
  1.  ;
  1.  S NFIELD=".525",FILE=2,FIELD="",CNT=1
  1.  F  S FIELD=$P(NFIELD,",",CNT) Q:FIELD=""  D LOOP(FIELD,FILE) S CNT=CNT+1
  1.  ;S NFIELD=.01,FILE=2.0361 D LOOP(NFIELD,FILE) -- MOVED TO DG*5.3*691
  1.  W !!
  1.  S (X,Y)=""
  1.  D BMES^XPDUTL("The following routine namespace was compiled:")
  1.  F  S X=$O(CFIELD(X)) Q:X=""  S Y=$G(Y)+1 S PRINT(Y)=" "_X_"*"
  1.  ;
  1.  D MES^XPDUTL(.PRINT)
  1.  K X,Y,PRINT,CFIELD
  1.  Q
  1.  ;
  1. LOOP(FIELD,FILE) ;
  1.  N GLOBAL,TEMPLATP,TEMPLATN,X,Y,DMAX
  1.  F GLOBAL="^DIE","^DIPT" DO
  1.  .I $D(@GLOBAL@("AF",FILE,FIELD)) D
  1.  ..S TEMPLATP=0
  1.  ..F  S TEMPLATP=$O(@GLOBAL@("AF",FILE,FIELD,TEMPLATP)) Q:'TEMPLATP  DO
  1.  ...S TEMPLATN=$P($G(@GLOBAL@(TEMPLATP,0)),"^",1)
  1.  ...I TEMPLATN="" D BMES^XPDUTL("Could not compile template "_TEMPLATN_$C(13,10)_"Please review!") Q
  1.  ...S X=$P($G(@GLOBAL@(TEMPLATP,"ROUOLD")),"^")
  1.  ...I X=""&($D(@GLOBAL@(TEMPLATP,"ROU"))'=0) D BMES^XPDUTL("Could not find routine for template "_TEMPLATN_$C(13,10)_"Please review!") Q
  1.  ...I X=""&($D(@GLOBAL@(TEMPLATP,"ROU"))=0) Q
  1.  ...I $D(CFIELD(X)) Q  ;already compiled
  1.  ...S CFIELD(X)="" ;                remember the template was compiled
  1.  ...S Y=TEMPLATP ;                 set up the call for fman
  1.  ...S DMAX=$$ROUSIZE^DILF
  1.  ...I GLOBAL="^DIE" D BMES^XPDUTL(" "),BMES^XPDUTL("   Compiling Input Templates") D EN^DIEZ Q
  1.  ...I GLOBAL="^DIPT" D BMES^XPDUTL(" "),BMES^XPDUTL("   Compiling Print Templates") D EN^DIPZ Q
  1.  Q