source: FOIAVistA/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXIPOST.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 5.7 KB
Line 
1PXIPOST ;ISL/dee - POST ROUTINE FOR PX PACKAGE ;8/12/96
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;;Aug 12, 1996
3EN ;
4 ;Run post clean up routine
5 N PXNEWCP
6 S PXNEWCP=$$NEWCP^XPDUTL("PXPTPOST LOC","LOC^PXPTPOST")
7 S PXNEWCP=$$NEWCP^XPDUTL("PXPTPOST MASTER","MASTER^PXPTPOST")
8 S PXNEWCP=$$NEWCP^XPDUTL("PXIPOST1","PROTOCOL^PXIPOST1")
9 S PXNEWCP=$$NEWCP^XPDUTL("PXIPOST","POST^PXIPOST")
10 S PXNEWCP=$$NEWCP^XPDUTL("PXIPOST APPGRP","APPGRP^PXIPOST")
11 S PXNEWCP=$$NEWCP^XPDUTL("PXIPOST AICS","AICS^PXIPOST")
12 S PXNEWCP=$$NEWCP^XPDUTL("PXIPOST SDAMPROT","SDAMPROT^PXIPOST")
13 S PXNEWCP=$$NEWCP^XPDUTL("PXIPOST PACKAGE","PACKAGE^PXIPOST")
14 S PXNEWCP=$$NEWCP^XPDUTL("PXIPOST QUE","QUE^PXIPOST")
15 Q
16 ;
17POST ;
18 S $P(^AUPNVPRV(0),"^",2)="9000010.06AIP"
19 ;
20 ;Set the SD/PCE SWITCH OVER DATE
21 I $P($G(^PX(815,1,0)),"^",2)'>2960000,$G(XPDQUES("POS SWITCH DATE")),XPDQUES("POS SWITCH DATE")>2960000,XPDQUES("POS SWITCH DATE")<2961002 D
22 . I $D(^PX(815,1,0))#2 S $P(^PX(815,1,0),"^",2)=XPDQUES("POS SWITCH DATE")
23 . E S ^PX(815,1,0)="1^"_XPDQUES("POS SWITCH DATE")
24 ;
25 ;Set the HEALTH SUMMARY START DATE
26 I $P($G(^PX(815,1,0)),"^",3)'>1800000,$P($G(^PX(815,1,0)),"^",2)>2960000 D
27 . S $P(^PX(815,1,0),"^",3)=$P(^PX(815,1,0),"^",2)
28 ;
29SET ;Set PCE into the package multiple in visit tracking
30 N VAR
31 S VAR=$$PKGON^VSIT("PX") I VAR'=1 S VAR=$$PKG^VSIT("PX",1)
32 Q
33 ;
34APPGRP ;
35 D BMES^XPDUTL("Add ""PXRM"" Application Group to file 60, 71, 120.51")
36 D MES^XPDUTL(" Done only if not there already.")
37 N GMI
38 K DIC,DA,DD,DO
39 F GMI=60,71,120.51 I '$D(^DIC(GMI,"%","B","PXRM")) D
40 . S DIC="^DIC("_GMI_",""%"","
41 . S DIC(0)="L"
42 . S DA(1)=GMI
43 . S X="PXRM"
44 . S DIC("P")=$P(^DD(1,10,0),"^",2)
45 . D FILE^DICN
46 . K DIC,DA,DD,DO
47 . D:+Y>0 BMES^XPDUTL("Adding ""PXRM"" Application Group to ^DIC("_GMI_",")
48 ;
49APPGRP2 ;
50 D BMES^XPDUTL("Add ""PXRS"" Application Group to file 80, 80.1, 81")
51 D MES^XPDUTL(" Done only if not there already.")
52 K GMI,DIC,DA,DD,DO
53 F GMI=80,80.1,81 I '$D(^DIC(GMI,"%","B","PXRS")) D
54 . S DIC="^DIC("_GMI_",""%"","
55 . S DIC(0)="L"
56 . S DA(1)=GMI
57 . S X="PXRS"
58 . S DIC("P")=$P(^DD(1,10,0),"^",2)
59 . D FILE^DICN
60 . K DIC,DA,DD,DO
61 . D:+Y>0 BMES^XPDUTL("Adding ""PXRS"" Application Group to ^DIC("_GMI_",")
62 Q
63 ;
64AICS ;Below is copyed form PXACT^IBD21PT2
65PXACT ; -- if pce is installed, activate the selection package interfaces
66 D BMES^XPDUTL("Activate the selection package interfaces in AICS for PCE")
67 N I,J
68 K X,Y
69 I $D(^AUTTEDT(0)) D ; education topics installed
70 .F I=1:1 S X=$P($T(INTRFCE+I),";;",2) Q:X="" D
71 ..S IBDIEN=$O(^IBE(357.6,"B",X,0))
72 ..Q:'IBDIEN
73 ..Q:$G(^IBE(357.6,IBDIEN,0))=""
74 ..Q:$P($G(^IBE(357.6,IBDIEN,0)),"^",9)=1 ;already available
75 ..S $P(^IBE(357.6,IBDIEN,0),"^",9)=1 ;makes it available
76 ..D BMES^XPDUTL(">>> AICS interface ",X," now available.")
77 ;
78AICSPROT ;
79 D BMES^XPDUTL("Attach other packages' protocol to PCE's protocols.")
80 N IBDF,PXCA,PXK,IBDFNAME,PXCANAME,PXKNAME
81 K DIC,DA,X,Y
82 S IBDFNAME="IBDF PCE EVENT"
83 S IBDF=$O(^ORD(101,"B",IBDFNAME,0))
84 S PXCANAME="PXCA DATA EVENT"
85 S PXCA=$O(^ORD(101,"B",PXCANAME,0))
86 S PXKNAME="PXK VISIT DATA EVENT"
87 S PXK=$O(^ORD(101,"B",PXKNAME,0))
88 I IBDF>0 D
89 . S DIC(0)="LSX"
90 . S DIC("P")=$P(^DD(101,10,0),"^",2)
91 . I PXCA>0 D
92 .. D MES^XPDUTL(" Adding protocol "_IBDFNAME_" to extended action protocol "_PXCANAME)
93 .. S DA(1)=PXCA
94 .. I $O(^ORD(101,DA(1),10,"B",IBDF,0))>0 D MES^XPDUTL(" ... already there") Q
95 .. S DIC="^ORD(101,"_DA(1)_",10,"
96 .. S X=IBDFNAME
97 .. D ^DIC
98 . I PXK>0 D
99 .. D MES^XPDUTL(" Adding protocol "_IBDFNAME_" to extended action protocol "_PXKNAME)
100 .. S DA(1)=PXK
101 .. I $O(^ORD(101,DA(1),10,"B",IBDF,0))>0 D MES^XPDUTL(" ... already there") Q
102 .. S DIC="^ORD(101,"_DA(1)_",10,"
103 .. S X=IBDFNAME
104 .. D ^DIC
105 Q
106 ;
107SDAMPROT ;
108 N IBDF,PXCA,PXK,IBDFNAME,PXCANAME,PXKNAME
109 K DIC,DA,X,Y
110 S SDAMNAME="SDAM PCE EVENT"
111 S SDAM=$O(^ORD(101,"B",SDAMNAME,0))
112 S PXKNAME="PXK VISIT DATA EVENT"
113 S PXK=$O(^ORD(101,"B",PXKNAME,0))
114 I SDAM>0 D
115 . S DIC(0)="LSX"
116 . S DIC("P")=$P(^DD(101,10,0),"^",2)
117 . I PXK>0 D
118 .. D MES^XPDUTL(" Adding protocol "_SDAMNAME_" to extended action protocol "_PXKNAME)
119 .. S DA(1)=PXK
120 .. I $O(^ORD(101,DA(1),10,"B",SDAM,0))>0 D MES^XPDUTL(" ... already there") Q
121 .. S DIC="^ORD(101,"_DA(1)_",10,"
122 .. S X=SDAMNAME
123 .. D ^DIC
124 Q
125 ;
126 ;
127PACKAGE ;Remove the old package entries that are no longer used.
128 N PACKAGE,NAME
129 N DA,DIC,DIK
130 D BMES^XPDUTL("Deleting old package file entries & Deleting old Order Parameters.")
131 F NAME="PCE PATIENT/IHS SUBSET" D
132 . K DA,DIC
133 . S DIC=9.4
134 . S DIC(0)="IOSX"
135 . S X=NAME
136 . D ^DIC
137 . I +Y>0 D
138 .. S PACKAGE=+Y
139 .. I $O(^ORD(100.99,1,5,PACKAGE,""))]"" D
140 ... ;Remove the Order Parameter entry for this package.
141 ... K DIK
142 ... S DIK="^ORD(100.99,1,5,"
143 ... S DA(1)=1,DA=PACKAGE
144 ... D MES^XPDUTL(" Deleting Order Parameter for package -- "_NAME)
145 ... I DA>0 D ^DIK
146 .. D MES^XPDUTL(" Deleting Package ++ "_NAME)
147 .. K DIK
148 .. S DIK="^DIC(9.4,"
149 .. S DA=PACKAGE
150 .. D ^DIK
151 Q
152 ;
153QUE ; Queue job to populate IHS Patient File #9000001
154 N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK,ZTSAVE
155 N PXPTLOC,DINUM,PXPTLAST
156 D GETLOC^PXPTPOST
157 I 'PXPTLOC D Q
158 . D MES^XPDUTL($C(7)_$C(7)_"Could not start the task job.")
159 . D MES^XPDUTL("You should start it by doing: D QUE^PXPTPOST at the programmers prompt.")
160 S PXPTLAST=$P($G(^PX(815,1,"PXPT")),"^",2)
161 I PXPTLAST>0 S $P(^PX(815,1,"PXPT"),"^",2)=0
162Q1 D BMES^XPDUTL("Populating the Patient/IHS File #9000001 via the following queued job ... ")
163 S ZTRTN="LOAD^PXXDPT",ZTDESC="Patient File (#9000001) Population",ZTIO=""
164 S ZTDESC="Populating the Patient/IHS File"
165 S ZTDTH=$H,ZTIO=""
166 D ^%ZTLOAD
167 I $D(ZTSK) D MES^XPDUTL("The job is task # "_ZTSK)
168 I '$D(ZTSK) D MES^XPDUTL("Could not start the task job.") D BMES^XPDUTL("You should start it by doing: D QUE^PXPTPOST at the programmers prompt.")
169 D MES^XPDUTL("")
170 Q
171 ;
Note: See TracBrowser for help on using the repository browser.