source: FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUA4A72.m@ 1764

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

initial load of FOIAVistA 6/30/08 version

File size: 4.0 KB
Line 
1XUA4A72 ;SFISC/RWF - Person class API's ;08/05/2004 15:53
2 ;;8.0;KERNEL;**27,49,74,132,222,300,327,357**;Jul 10, 1995;Build 2
3 ; Entry Points (DBIA 1625)
4 ; $$GET - Returns active class, given duz and date.
5 ; $$IEN2CODE - Returns VA CODE from PERSON CLASS file, given IEN.
6 ; $$CODE2TXT - Returns HCFA text from PERSON CLASS file, given IEN
7 ; or VA CODE.
8 Q ;No access from top.
9GET(IEN,DATE) ;sr. Get the active class on a date
10 ;IEN of user.
11 N X1,Y1,D
12 S:$G(DATE)="" DATE=DT S D=DATE
13 ;The return is file 200 ien_^_NODE
14 S X1=$$GETUE(IEN,DATE) I X1'>0 Q X1
15 S X1=$P(X1,"^",2,99) ;or X1=^VA(200,IEN,"USC1",+X1,0)
16 S Y1=$G(^USC(8932.1,+X1,0))
17 ;IEN^Occupation^specialty^sub-specialty^Effective date^expiration date^VA Code^specialty code
18 Q +X1_U_$P(Y1,U,1,3)_U_$P(X1,U,2,3)_U_$P(Y1,U,6)_U_$P(Y1,U,9)
19 ;
20IEN2CODE(IEN) ;sr. Get the code for an IEN
21 Q $P($G(^USC(8932.1,+$G(IEN),0)),U,6)
22 ;
23IEN2DATA(IEN) ;Get person class data for an IEN
24 Q $G(^USC(8932.1,+$G(IEN),0))
25 ;
26CODE2TXT(CODE) ;sr. Convert IEN or V-code to text
27 I CODE?1"V"1.N S CODE=$$VCLK(CODE)
28 Q $P($G(^USC(8932.1,+CODE,0)),U,1,3)
29 ;
30VCLK(X) ;Lookup a V-code, Return IEN
31 Q $O(^USC(8932.1,"F",X,0))
32 ;
33GETUE(IEN,DATE) ;private, Get the user entry
34 N D,X,Y,XUOK
35 Q:'$D(^VA(200,+$G(IEN),0)) -1
36 Q:$O(^VA(200,IEN,"USC1",0))="" -1
37 S XUOK=0
38 S D=$O(^VA(200,IEN,"USC1","AD",DATE))
39 F S D=$O(^VA(200,IEN,"USC1","AD",D),-1) Q:D="" D Q:XUOK
40 . S Y=""
41 . F S Y=$O(^VA(200,IEN,"USC1","AD",D,Y),-1) Q:'Y D Q:XUOK
42 . . S X=$G(^VA(200,IEN,"USC1",Y,0))
43 . . I $P(X,U,2),DATE'<$P(X,U,2),DATE'>$P(X,U,3)!($P(X,U,3)="") S XUOK=1
44 Q $S(XUOK:Y_U_X_U_U,1:-2)
45 ;
46REMOVE ;Allow privileged user to remove a wrong entry in the users file.
47 N XUDA,XUDA1,XUWT,%
48 S XUDA1=+$$LOOKUP^XUSER Q:XUDA1'>0
49 W !,"This user has the following Person Class enties:"
50 S XUWT=^DD(8932.1,0,"ID","WRITE")
51 F XUDA=0:0 S XUDA=$O(^VA(200,XUDA1,"USC1",XUDA)) Q:XUDA'>0 S %=+$G(^(XUDA,0)) I %>0 W !,$P(^USC(8932.1,%,0),U) X XUWT
52 S DIR(0)="Y",DIR("A")="Are you sure you want to remove ALL these entries" D ^DIR Q:$D(DIRUT)!(Y'=1)
53 F XUDA=0:0 S XUDA=$O(^VA(200,XUDA1,"USC1",XUDA)) Q:XUDA'>0 S DIK="^VA(200,DA(1),""USC1"",",DA=XUDA,DA(1)=XUDA1 D ^DIK
54 Q
55 ;
56TERM(IEN,DATE) ;Called from XUSTERM, Set the expiration date for a user being terminated.
57 N Y1
58 Q:$G(DATE)'>0
59 S Y1=$$GETUE(IEN,DATE)
60 I Y1'>0!$L($P(Y1,"^",4)) Q
61 D OLD(IEN,+Y1,DATE)
62 Q
63 ;
64SET01 ;Called from the X-ref on the .01 field
65 Q:$P(^VA(200,DA(1),"USC1",DA,0),U,2)>0
66 S $P(^VA(200,DA(1),"USC1",DA,0),U,2)=DT ;Trigger date
67 D UPDATE(200.05,2,DT)
68 ;
69SET2 ;Call from the X-ref on the Effective Date field
70 N L,REC
71 S L=$O(^VA(200,DA(1),"USC1",DA),-1) Q:L'>0
72 S REC=^VA(200,DA(1),"USC1",L,0)
73 I $P(REC,U,3)="" D OLD(DA(1),L,$$MAX^XLFMTH(X,$P(REC,U,2))) ;Inactivate the old one
74 Q
75KILL2 ;Call from the X-ref on the Effective Date field
76 N L
77 S L=$O(^VA(200,DA(1),"USC1",DA),-1) Q:L'>0
78 I $P(^VA(200,DA(1),"USC1",L,0),U,3)=X D OLD(DA(1),L,"")
79 Q
80 ;
81OLD(D0,D1,DATE) ;Inactivate the old one (Expiration Date)
82 N DA,X
83 S $P(^VA(200,D0,"USC1",D1,0),U,3)=DATE ;Inactivate the old one
84 S DA(1)=D0,DA=D1 D UPDATE(200.05,3,DATE)
85 Q
86UPDATE(DIH,DIG,DIV,DIU) ;file,field,new value,old value
87 S DIV=$G(DIV),DIU=$G(DIU),DIV(0)=DA(1),DIV(1)=DA
88 D ^DICR:$O(^DD(DIH,DIG,1,0))>0
89 Q
90DDS1 ;Called from Pre-action person class field
91 N %,XUDA,XU
92 I X]"" S %=^USC(8932.1,X,0),XU(1)=$P(%,U,1),XU(2)=" "_$P(%,U,2),XU(3)=" "_$P(%,U,3) D HLP^DDSUTL(.XU)
93 Q:DA'>0 M XUDA=DA N DA ;Hide DA
94 S %=$$GET^DDSVAL(DIE,.XUDA,3,"","I"),%=$S(%>0:1,1:0)
95 D UNED^DDSUTL(2,,,%),UNED^DDSUTL(3,,,%)
96 Q
97DDS2 ;Called from effective date on form
98 N %,XUDA M XUDA=DA N DA ;Hide DA
99 S XUDA=$O(^VA(200,XUDA(1),"USC1",XUDA),-1) Q:XUDA'>0
100 S %=$$GET^DDSVAL(DIE,.XUDA,3,"","I") Q:%&(%<X) ;Already has value
101 D PUT^DDSVAL(DIE,.XUDA,3,X,"","I")
102 Q
103DDS3(%) ;Data validation
104 I %=2,$$GET^DDSVAL(DIE,.DA,3,"","I")]"" D
105 . S DDSERROR=1
106 . D HLP^DDSUTL("This field is uneditable because Expired Date already has data")
107 . Q
108 I %=3,DDSOLD]"",X'=DDSOLD D
109 . S DDSERROR=1
110 . D HLP^DDSUTL("You cannot change the value of this field.")
111 . Q
112 Q
Note: See TracBrowser for help on using the repository browser.