source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DG648PST.m@ 1123

Last change on this file since 1123 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 7.2 KB
Line 
1DG648PST ;BIR/CMC-PATCH DG*5.3*648 POST INSTALLATION ROUTINE ;2/11/05
2 ;;5.3;Registration;**648**;Aug 13, 1993
3 ;
4POST ;Post init
5 N DGFLD,DGMFLD,DGOUT,DGFILE
6 ;File cross references
7 D XR(2,.525) ;POW STATUS INDICATED?
8 ;;D XR(2.0361,.01) ;PATIENT ELIGIBILITIES MULTIPLE ELIGIBILITY FIELD -- MOVED TO DG*5.3*691
9 D TEMPL
10 ;fix missing leading zeros for ICN Checksums DD issue was corrected in MPIF*1.0*9
11 D MES^XPDUTL(" >>> Checking ICN Checksums for missing leading zeros. Job being tasked off.")
12 S ZTRTN="CHKSUM^DG648PST",ZTDESC="Correct missing leading zeros in ICN Checksum - DG*5.3*648"
13 S ZTIO="",ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,0,0,1,0)
14 I $D(DUZ) S ZTSAVE("DUZ")=DUZ
15 D ^%ZTLOAD
16 K ZTDESC,ZTDTH,ZTIO,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,%
17 Q
18 ;
19CHKSUM ;fix missing leading zeros for ICN Checksums
20 K ^XTMP("DG648","MISSING CHECKSUM"),^XTMP("DG648","CHECKSUM UPDATE"),^XTMP("DG648","CHECKSUM UPDATE FAIL")
21 N DFN,ICN,CHECK,DIE,DA,DR,X,Y,CNT,CNT2,CNT3,LEN
22 S (CNT2,CNT3,CNT,ICN)=0
23 F S ICN=$O(^DPT("AICN",ICN)) Q:ICN="" D
24 .Q:$E(ICN,1,3)=$P($$SITE^VASITE,"^",3)
25 .S DFN=$O(^DPT("AICN",ICN,""))
26 .I ICN'=$P($G(^DPT(DFN,"MPI")),"^") Q
27 .; ^ ONLY UPDATING PRIMARY ICN
28 .S CHECK=$P($G(^DPT(DFN,"MPI")),"^",2)
29 .I CHECK="" S CNT2=CNT2+1,^XTMP("DG648","MISSING CHECKSUM",CNT2)="DFN= "_DFN_"^"_"ICN= "_ICN Q
30 .S LEN=$L(CHECK)
31 .Q:LEN=6
32 .I LEN<6 S CHECK=$E(1000000+CHECK,2,7) ;adding missing leading zeros
33 .K X,Y,DIE,DA,DR
34 .S DA=DFN
35 .D LOCK(DA) ;LOCK DPT NODE "MPI"
36 .S DIE="^DPT(",DR="991.02///^S X=CHECK" D ^DIE
37 .L -^DPT(DA,"MPI")
38 .I +$G(Y)=-1 S CNT3=CNT3+1,^XTMP("DG648","CHECKSUM UPDATE FAIL",CNT3)="DFN= "_DFN_"^ICN= "_ICN_"^CHECKSUM= "_CHECK Q
39 .S CNT=CNT+1,^XTMP("DG648","CHECKSUM UPDATE",CNT)="DFN= "_DFN_"^ICN= "_ICN_"^CHECKSUM= "_CHECK
40 S ^XTMP("DG648","CHECKSUM UPDATE",CNT+2)="TOTAL: "_CNT,^XTMP("DG648","MISSING CHECKSUM",CNT2+2)="TOTAL: "_CNT2
41 S ^XTMP("DG648","CHECKSUM UPDATE FILE",CNT3+2)="TOTAL: "_CNT3
42 I CNT>0 D
43 .N DIFROM,XMSUB,XMTEXT,XMY
44 .S XMSUB="Updated Checksums post-init DG648 from "_$P($$SITE^VASITE,"^",3),XMY(DUZ)=""
45 .S XMTEXT="^XTMP(""DG648"",""CHECKSUM UPDATE"",",XMY("CHESNEY.CHRISTINE_M@FORUM.VA.GOV")=""
46 .D ^XMD
47 I CNT2>0 D
48 .N DIFROM,XMSUB,XMTEXT,XMY
49 .S XMSUB="Missing Checksums post-init DG648 from "_$P($$SITE^VASITE,"^",3),XMY(DUZ)=""
50 .S XMTEXT="^XTMP(""DG648"",""MISSING CHECKSUM"",",XMY("CHESNEY.CHRISTINE_M@FORUM.VA.GOV")=""
51 .D ^XMD
52 I CNT3>0 D
53 .N DIFROM,XMSUB,XMTEXT,XMY
54 .S XMSUB="Checksum updates failed in post-init DG648 from "_$P($$SITE^VASITE,"^",3),XMY(DUZ)=""
55 .S XMTEXT="^XTMP(""DG648"",""CHECKSUM UPDATE FAIL"",",XMY("CHESNEY.CHRISTINE_M@FORUM.VA.GOV")=""
56 .D ^XMD
57 I CNT=0,CNT2=0,CNT3=0 D
58 .N DIFROM,XMSUB,XMTEXT,XMY,ARR
59 .S ARR(1)="No issues with Checksums at this site"
60 .S XMSUB="Checksum updates failed in post-init DG648 from "_$P($$SITE^VASITE,"^",3),XMY(DUZ)=""
61 .S XMTEXT="ARR(",XMY("CHESNEY.CHRISTINE_M@FORUM.VA.GOV")=""
62 .D ^XMD
63 K ^XTMP("DG648","MISSING CHECKSUM"),^XTMP("DG648","CHECKSUM UPDATE"),^XTMP("DG648","CHECKSUM UPDATE FAIL")
64 Q
65 ;
66LOCK(IEN) ;
67 F L +^DPT(IEN,"MPI"):10 Q:$T
68 Q
69XR(DGFILE,DGFLD) ;File index type cross references
70 ;
71 N DGFDA,DGIEN,DGWP,DGERR,DGXR,DGVAL,DGOUT,DIERR
72 ;Set up x-refs. Any value that has a ".", will have the period
73 ;replaved with a "D" to prevent x-ref's such as .11 and 11 having
74 ;identical xref names
75 ;I DGFILE=2.0361 S DGXR="AVAFC20361" ;ELIGIBILITY -- MOVED TO DG*5.3*691
76 I '$D(DGXR) S DGXR=$S(DGFLD[".":"AVAFC"_$P(DGFLD,".",2),1:"AVAFC"_DGFLD)
77 ;Check for existing x-ref
78 S DGVAL(1)=DGFILE,DGVAL(2)=DGXR
79 D FIND^DIC(.11,"","@;IXIE","KP",.DGVAL,"","","","","DGOUT")
80 I $D(DGOUT("DILIST",1)) D Q
81 .D MES^XPDUTL(" >>> Cross reference "_DGXR_" already exists, nothing filed.")
82 .Q
83 ;Create filer array
84 S DGFDA(.11,"+1,",.01)=DGFILE ;FILE
85 S DGFDA(.11,"+1,",.02)=DGXR ;NAME
86 S DGFDA(.11,"+1,",.11)="This x-ref calls the DG FIELD MONITOR event point." ;SHORT DESCRIPTION
87 S DGFDA(.11,"+1,",.2)="MU" ;TYPE
88 S DGFDA(.11,"+1,",.4)="F" ;EXECUTION
89 S DGFDA(.11,"+1,",.41)="I" ;ACTIVITY
90 S DGFDA(.11,"+1,",.5)="I" ;ROOT TYPE
91 S DGFDA(.11,"+1,",.51)=DGFILE ;ROOT FILE
92 S DGFDA(.11,"+1,",.42)="A" ;USE
93 S DGFDA(.11,"+1,",1.1)="D FC^DGFCPROT(.DA,"_DGFILE_","_DGFLD_",""SET"",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q" ;SET LOGIC
94 S DGFDA(.11,"+1,",2.1)="D FC^DGFCPROT(.DA,"_DGFILE_","_DGFLD_",""KILL"",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q" ;KILL LOGIC
95 ;CROSS REFERENCE VALUES
96 S DGFDA(.114,"+2,+1,",.01)=1 ;ORDER NUMBER
97 S DGFDA(.114,"+2,+1,",1)="F" ;TYPE OF VALUE
98 S DGFDA(.114,"+2,+1,",2)=DGFILE ;FILE NUMBER
99 S DGFDA(.114,"+2,+1,",3)=DGFLD ;FIELD NUMBER
100 S DGFDA(.114,"+2,+1,",7)="F" ;COLLATION
101 ;DESCRIPTION
102 S DGWP(1)="This cross reference activates the DG FIELD MONITOR event point."
103 S DGWP(2)="Applications that wish to monitor edit activity related to this field may"
104 S DGWP(3)="subscribe to that event point and take action as indicated by the changes"
105 S DGWP(4)="that occur. Refer to the DG FIELD MONITOR protocol for a description of"
106 S DGWP(5)="the information available at the time of the event."
107 ;File INDEX record
108 D UPDATE^DIE("","DGFDA","DGIEN","DGERR")
109 I $D(DIERR) D Q
110 .N DGI S DGI=""
111 .D MES^XPDUTL(" >>> A problem has occurred during the filing of x-ref. "_DGXR_"!")
112 .D MES^XPDUTL(" Please contact Customer Support.")
113 .F S DGI=$O(DGERR("DIERR",1,"TEXT",DGI)) Q:DGI="" D
114 ..D MES^XPDUTL(DGERR("DIERR",1,"TEXT",DGI))
115 ..Q
116 .Q
117 S DGFLD(DGFILE,DGFLD)="" ;Create list to recompile templates
118 D MES^XPDUTL(" >>> "_DGXR_" cross reference filed.")
119 ;File DESCRIPTION field
120 D WP^DIE(.11,DGIEN(1)_",",.1,"","DGWP")
121 Q
122TEMPL N GLOBAL,FIELD,NFIELD,FILE,CNT
123 D BMES^XPDUTL("Beginning to compile templates on the PATIENT (#2) file.")
124 ;
125 S NFIELD=".525",FILE=2,FIELD="",CNT=1
126 F S FIELD=$P(NFIELD,",",CNT) Q:FIELD="" D LOOP(FIELD,FILE) S CNT=CNT+1
127 ;S NFIELD=.01,FILE=2.0361 D LOOP(NFIELD,FILE) -- MOVED TO DG*5.3*691
128 W !!
129 S (X,Y)=""
130 D BMES^XPDUTL("The following routine namespace was compiled:")
131 F S X=$O(CFIELD(X)) Q:X="" S Y=$G(Y)+1 S PRINT(Y)=" "_X_"*"
132 ;
133 D MES^XPDUTL(.PRINT)
134 K X,Y,PRINT,CFIELD
135 Q
136 ;
137LOOP(FIELD,FILE) ;
138 N GLOBAL,TEMPLATP,TEMPLATN,X,Y,DMAX
139 F GLOBAL="^DIE","^DIPT" DO
140 .I $D(@GLOBAL@("AF",FILE,FIELD)) D
141 ..S TEMPLATP=0
142 ..F S TEMPLATP=$O(@GLOBAL@("AF",FILE,FIELD,TEMPLATP)) Q:'TEMPLATP DO
143 ...S TEMPLATN=$P($G(@GLOBAL@(TEMPLATP,0)),"^",1)
144 ...I TEMPLATN="" D BMES^XPDUTL("Could not compile template "_TEMPLATN_$C(13,10)_"Please review!") Q
145 ...S X=$P($G(@GLOBAL@(TEMPLATP,"ROUOLD")),"^")
146 ...I X=""&($D(@GLOBAL@(TEMPLATP,"ROU"))'=0) D BMES^XPDUTL("Could not find routine for template "_TEMPLATN_$C(13,10)_"Please review!") Q
147 ...I X=""&($D(@GLOBAL@(TEMPLATP,"ROU"))=0) Q
148 ...I $D(CFIELD(X)) Q ;already compiled
149 ...S CFIELD(X)="" ; remember the template was compiled
150 ...S Y=TEMPLATP ; set up the call for fman
151 ...S DMAX=$$ROUSIZE^DILF
152 ...I GLOBAL="^DIE" D BMES^XPDUTL(" "),BMES^XPDUTL(" Compiling Input Templates") D EN^DIEZ Q
153 ...I GLOBAL="^DIPT" D BMES^XPDUTL(" "),BMES^XPDUTL(" Compiling Print Templates") D EN^DIPZ Q
154 Q
Note: See TracBrowser for help on using the repository browser.