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

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

initial load of WorldVistAEHR
File size: 3.3 KB
Line 
1DG53446P ;ALB/MM - Add HOSPICE TREATING SPECIALTY ; 5/21/02 2:28pm
2 ;;5.3;Registration;**446**;May 20, 2002
3 ;base program: DG53176P
4 ;
5EN ;Add Observation Treating Specialties to the SPECIALITY file (#42.4)
6 N DGI,DGERR,DGSPEC,DGIFN,DGQUES
7 S DGIFN=0
8 F DGI=1:1 S DGSPEC=$P($T(TRSP+DGI),";;",2) Q:DGSPEC="QUIT" D
9 .D TSPEC
10 .S DGQUES=$P(DGSPEC,U,9)
11 .D FAC
12 .Q
13 Q
14TSPEC ;Add treating specialty to SPECIALTY File (#42.4)
15 D BMES^XPDUTL(">>>"_$P(DGSPEC,U,2)_">>>")
16 N DA,DGFILE,DGMULT,DIC,DIE,DGDA1,DINUM,DLAYGO,DR,X,Y
17 S DGERR=0
18 S DIC="^DIC(42.4,"
19 S DIC(0)="LX"
20 S DINUM=$P(DGSPEC,U)
21 S X=$P(DGSPEC,U,2)
22 S DLAYGO=42.4
23 D ^DIC
24 S (DGIFN,DGDA1)=Y
25 I +DGIFN=-1 D Q
26 .D MES^XPDUTL(" Entry not added to SPECIALTY File (#42.4). No further updating will occur.")
27 .D MES^XPDUTL(" Please contact Customer Service for assistance.")
28 .Q
29 I $P(DGIFN,U,3)'=1&(+DGIFN'=$P(DGSPEC,U)) D Q
30 .D MES^XPDUTL(" Entry exists in SPECIALTY File (#42.4), but with a different PTF Code #.")
31 .D MES^XPDUTL(" No further updating will occur. Please review entry.")
32 .S DGERR=1
33 .Q
34 D MES^XPDUTL(" Entry "_$S($P(DGIFN,U,3)=1:"added to",1:"exists in")_" SPECIALTY File (#42.4).")
35 D MES^XPDUTL(" Updating SPECIALTY File fields.")
36 S DIE=DIC
37 S DR="1///"_$P(DGSPEC,U,3)_";3///"_$P(DGSPEC,U,4)_";4///"_$P(DGSPEC,U,5)_";5///"_$P(DGSPEC,U,6)_";6///"_$P(DGSPEC,U,7)
38 S DA=+DGIFN
39 D ^DIE
40 S DGFILE=42.4
41 S DGMULT=10
42 S DIC="^DIC(42.4,"_+DGIFN_",""E"","
43 D MULT
44 Q
45FAC ;Add treating specialty to Facility Treating Specialty file (#45.7)
46 I $G(XPDQUES(DGQUES))'=1 D Q
47 .D BMES^XPDUTL(" Answered NO to install question. Specialty will not be added to FACILITY")
48 .D MES^XPDUTL(" TREATING SPECIALTY File (#45.7).")
49 .Q
50 I +DGIFN<0 D Q
51 .D BMES^XPDUTL(" Treating specialty not found in SPECIALTY File (#42.4). Cannot")
52 .D MES^XPDUTL(" be added to FACILITY TREATING SPECIALTY File (#45.7).")
53 .Q
54 I DGERR=1 D Q
55 .D BMES^XPDUTL(" Answered YES to install question. SPECIALITY File (#42.4) does not")
56 .D MES^XPDUTL(" contain the expected PTF Code #. Cannot update FACILITY TREATING")
57 .D MES^XPDUTL(" SPECIALTY File (#45.7).")
58 .Q
59 N DA,DGFILE,DGMULT,DIC,DIE,DLAYGO,DR,X,Y
60 S DIC="^DIC(45.7,"
61 S DIC(0)="LXZ"
62 S DLAYGO=45.7
63 S X=$P(DGSPEC,U,2)
64 D ^DIC
65 S DGDA1=Y
66 I +DGDA1=-1 D BMES^XPDUTL(" Entry not added to FACILITY TREATING SPECIALTY File(#45.7).") Q
67 I $P(DGDA1,U,3)'=1&($P(Y(0),U,2)'=$P(DGSPEC,U)) D Q
68 .D BMES^XPDUTL(" Entry exists in FACILITY TREATING SPECIALTY File (#45.7), but with")
69 .D MES^XPDUTL(" a different PTF Code #. No further updating will occur.")
70 .D MES^XPDUTL(" Please review entry.")
71 .Q
72 D BMES^XPDUTL(" Entry "_$S($P(DGDA1,U,3)=1:"added to",1:"exists in")_" FACILITY TREATING SPECIALTY File (#45.7).")
73 D MES^XPDUTL(" Updating SPECIALTY field...")
74 S DIE=DIC
75 S DA=+DGDA1
76 S DR="1////"_$P(DGSPEC,U)
77 D ^DIE
78 S DGFILE=45.7
79 S DGMULT=100
80 S DIC="^DIC(45.7,"_+DGDA1_",""E"","
81 D MULT
82 Q
83MULT ;Add Effective Date
84 N DA,DIE,DR
85 S DA(1)=+DGDA1
86 S DIC(0)="LX"
87 S DIC("P")=$P(^DD(DGFILE,DGMULT,0),"^",2)
88 S X=3020701
89 D ^DIC
90 S DA=+Y
91 I +Y=-1 D MES^XPDUTL(" Effective date not added.") Q
92 D MES^XPDUTL(" Effective date added.")
93 S DIE=DIC
94 S DR=".02///Y"
95 D ^DIE
96 Q
97TRSP ;PTF code^Speciality^Print Name^Service^Ask Psych^Billing Bedsection^CDR^^Ques#
98 ;;96^HOSPICE^HOSPICE^NH^N^NURSING HOME CARE^1425^^POS1
99 ;;QUIT
100 Q
Note: See TracBrowser for help on using the repository browser.