source: WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXPUTL.m@ 724

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

initial load of WorldVistAEHR

File size: 5.1 KB
Line 
1ECXPUTL ;ALB/GTS - Utilities for DSS Prosthetics Extract ;July 15, 1998
2 ;;3.0;DSS EXTRACTS;**9,14**;Dec 22, 1997
3 ;
4PDIV() ; Prompt the user for a division and return its IEN
5 ;
6 ; Output:
7 ; ECXDIV
8 ; Successful - Institution file IEN for the selected division
9 ; Unsuccessful - 0
10 ;
11 N ECXDIV,ECTMP,ECDIVCT,ECDIVSXS,ECDIVLP
12 S ECXDIV=0
13 S ECDIVSXS=$$DIV4^XUSER(.ECTMP,DUZ) ;**Set up array of user divisions
14 ;
15 ;** If the user doesn't have divisions setup
16 I 'ECDIVSXS DO
17 .S DIR(0)="FAO^1:1"
18 .S DIR("A",1)="You do not have any divisions defined in your user set up."
19 .S DIR("A",2)="Contact an ADPAC or IRM for assistance."
20 .S DIR("A")="Hit Return to continue."
21 .D ^DIR K DIR,X,Y
22 ;
23 ;** If the user does have divisions setup
24 I ECDIVSXS DO
25 .S (ECDIVCT,ECDIVLP)=0
26 .F S ECDIVLP=$O(ECTMP(ECDIVLP)) Q:(+ECDIVLP=0) DO
27 ..I $D(^RMPR(669.9,"C",ECDIVLP)) S ECDIVCT=ECDIVCT+1
28 ..I '$D(^RMPR(669.9,"C",ECDIVLP)) K ECTMP(ECDIVLP)
29 .I 'ECDIVCT DO
30 ..S DIR(0)="FAO^1:1"
31 ..S DIR("A",1)="Your division is not set up as a prosthetic division."
32 ..S DIR("A")="Hit Return to continue."
33 ..D ^DIR K DIR,X,Y
34 .I ECDIVCT=1 DO
35 ..S ECXDIV=$O(ECTMP(""))
36 ..K ECXDIC S DA=ECXDIV,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
37 ..D EN^DIQ1 S ECXSNUM=$G(ECXDIC(4,DA,99,"I"))
38 ..S ECXSNAME=$G(ECXDIC(4,DA,.01,"I"))
39 ..K DIC,DIQ,DA,DR,ECXDIC
40 ..I $L(ECXSNUM)>3 DO
41 ...K ECTMP(ECXDIV)
42 ...S DIR(0)="FAO^1:1"
43 ...S DIR("A",1)="Your division ("_ECXSNUM_") is not a prosthetic primary division."
44 ...S DIR("A",2)="Note that the Station Number ("_ECXSNUM_") is longer than 3 characters"
45 ...S DIR("A",3)=" for the Station "_ECXSNAME_"."
46 ...S DIR("A",4)="Check with IRM to identify the primary division and add it to your New Person"
47 ...S DIR("A",5)=" file entry."
48 ...S DIR("A")="Hit Return to continue."
49 ...D ^DIR K DIR,X,Y
50 ...S ECXDIV=0
51 ..K ECXSNUM,ECXSNAME
52 .I ECDIVCT>1 DO
53 ..S DIC("A")="Select Prosthetic Division: ",DIC(0)="AEQM",DIC="^DIC(4,"
54 ..S DIC("S")="I $D(ECTMP(+Y))&(+$L($P($G(^DIC(4,+Y,99)),""^"",1))=3)" D ^DIC
55 ..I '$D(DTOUT),'$D(DUOUT),Y>0 S ECXDIV=+Y
56 ..I $D(DTOUT)!($D(DUOUT))!(Y<1) DO
57 ...S DIR(0)="FAO^1:1"
58 ...S DIR("A",1)="You did not select a prosthetic division."
59 ...S DIR("A")="Hit Return to continue."
60 ...D ^DIR K DIR,X,Y
61 ...S ECXDIV=0
62 Q ECXDIV
63 ;
64PDIV2(DUZ) ; prompt user for any prosthetics division
65 ; input
66 ; DUZ - ien in file #200
67 ; Output:
68 ; ECXDIV
69 ; successful - ien file #4^station number^station name
70 ; unsuccessful - 0
71 ;
72 N ECXDIV,ECTMP,ECDIVCT,ECDIVSXS,ECDIVLP
73 S ECXDIV=0
74 S ECDIVSXS=$$DIV4^XUSER(.ECTMP,DUZ) ;**Set up array of user divisions
75 ;If the user doesn't have divisions setup
76 I 'ECDIVSXS D
77 .S DIR(0)="FAO^1:1"
78 .S DIR("A",1)="You do not have any divisions defined in your user set up."
79 .S DIR("A",2)="Contact an ADPAC or IRM for assistance."
80 .S DIR("A")="Hit Return to continue."
81 .D ^DIR K DIR,X,Y
82 ;If the user does have divisions setup
83 I ECDIVSXS D
84 .S (ECDIVCT,ECDIVLP)=0
85 .F S ECDIVLP=$O(ECTMP(ECDIVLP)) Q:(+ECDIVLP=0) D
86 ..I $D(^RMPR(669.9,"C",ECDIVLP)) S ECDIVCT=ECDIVCT+1
87 ..I '$D(^RMPR(669.9,"C",ECDIVLP)) K ECTMP(ECDIVLP)
88 .I 'ECDIVCT D
89 ..S DIR(0)="FAO^1:1"
90 ..S DIR("A",1)="Your division is not set up as a prosthetic division."
91 ..S DIR("A")="Hit Return to continue."
92 ..D ^DIR K DIR,X,Y
93 .I ECDIVCT=1 D
94 ..S ECXDIV=$O(ECTMP(""))
95 ..K ECXDIC S DA=ECXDIV,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
96 ..D EN^DIQ1
97 ..S ECXDIV=ECXDIV_U_$G(ECXDIC(4,DA,99,"I"))_U_$G(ECXDIC(4,DA,.01,"I"))
98 ..K DIC,DIQ,DA,DR,ECXDIC
99 .I ECDIVCT>1 D
100 ..S DIC("A")="Select Prosthetic Division: ",DIC(0)="AEQM",DIC="^DIC(4,"
101 ..S DIC("S")="I $D(ECTMP(+Y))" D ^DIC
102 ..I $D(DTOUT)!($D(DUOUT))!(Y<1) D Q
103 ...S DIR(0)="FAO^1:1"
104 ...S DIR("A",1)="You did not select a prosthetic division."
105 ...S DIR("A")="Hit Return to continue."
106 ...D ^DIR K DIR,X,Y
107 ...S ECXDIV=0
108 ..I '$D(DTOUT),'$D(DUOUT),Y>0 S ECXDIV=+Y D Q
109 ...K ECXDIC S DA=ECXDIV,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
110 ...D EN^DIQ1
111 ...S ECXDIV=ECXDIV_U_$G(ECXDIC(4,DA,99,"I"))_U_$G(ECXDIC(4,DA,.01,"I"))
112 ...K DIC,DIQ,DA,DR,ECXDIC
113 Q ECXDIV
114 ;
115PDIV3(DUZ,PRIME,DIV) ; user divisions in primary prosthetics division
116 ; input
117 ; DUZ - ien in file #200 (required)
118 ; PRIME - primary division - ien file #4^station number^station name (required)
119 ; DIV - array passed by reference (required)
120 ; Output:
121 ; DIV - array of 1 or more divisions associated with primary division
122 ; successful - ien file #4^station number^station name
123 ; unsuccessful - 0
124 ;
125 N ECXDIV,ECTMP,ECDIVCT,ECDIVSXS,ECDIVLP
126 S DIV(1)=0
127 S ECDIVSXS=$$DIV4^XUSER(.ECTMP,DUZ) ;**Set up array of user divisions
128 ;if the user doesn't have divisions setup
129 I 'ECDIVSXS Q
130 ;if the user does have divisions setup
131 I ECDIVSXS D
132 .S (ECDIVCT,ECDIVLP)=0
133 .F S ECDIVLP=$O(ECTMP(ECDIVLP)) Q:(+ECDIVLP=0) D
134 ..I '$D(^RMPR(669.9,"C",ECDIVLP)) K ECTMP(ECDIVLP)
135 ..I $D(^RMPR(669.9,"C",ECDIVLP)) D
136 ...S DA=ECDIVLP,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" D EN^DIQ1
137 ...;does this division belong to primary division?
138 ...I $E($G(ECXDIC(4,DA,99,"I")),1,3)'=$P(PRIME,U,2) K ECTMP(ECDIVLP) Q
139 ...S ECDIVCT=ECDIVCT+1
140 ...S DIV(ECDIVCT)=ECDIVLP_U_$G(ECXDIC(4,DA,99,"I"))_U_$G(ECXDIC(4,DA,.01,"I"))
141 K DIC,DIQ,DA,DR,ECXDIC,X,Y
142 Q
Note: See TracBrowser for help on using the repository browser.