source: IHS-VA_UTILITIES-XB/trunk/XBFUNC1.m@ 1166

Last change on this file since 1166 was 642, checked in by Sam Habiel, 15 years ago

Modified directory structure; moved routines.

File size: 1.6 KB
Line 
1XBFUNC1 ; IHS/ADC/GTH - FUNCTION LIBRARY CONTINUED ; [ 02/07/97 3:02 PM ]
2 ;;4.0;XB;;Jul 20, 2009;Build 2
3 ;
4PROVCLS(PROV,FORM) ;PEP - Retrieve Provider Class from New Person File
5 I $G(PROV)="" Q ""
6 I '$D(^VA(200,PROV)) Q ""
7 NEW X,Z,Y,CLS,DIC,DR,DA,DIQ
8 S DIC=200,DR="53.5",DA=PROV,DIQ="CLS"
9 S:$G(FORM)="I" DIQ(0)="I"
10 D ENDIQ1
11 S CLS=$S($G(FORM)="I":CLS(200,PROV,"53.5","I"),1:CLS(200,PROV,"53.5"))
12 Q $S(CLS="":"UNKNOWN",1:CLS)
13 ;
14PROVCLSC(PROV) ;PEP - Retrieve Provider Class Code given New Person File IEN
15 I $G(PROV)="" Q ""
16 I '$D(^VA(200,PROV)) Q ""
17 NEW X,Z,Y,CODE,DIC,DR,DA,DIQ,CLASS
18 S CLASS=$$PROVCLS^XBFUNC1(PROV,"I")
19 I CLASS="UNKNOWN" Q "UNKNOWN"
20 S DIC=7,DR="9999999.01",DA=CLASS,DIQ="CODE"
21 D ENDIQ1
22 S CODE=CODE(7,CLASS,"9999999.01")
23 Q $S(CODE="":"UNKNOWN",1:CODE)
24 ;
25PROVAFFL(PROV,FORM) ;PEP - Retrieve provider affiliation in int or ext format
26 I $G(PROV)="" Q ""
27 I '$D(^VA(200,PROV)) Q ""
28 NEW X,Z,Y,AFFL,DIC,DR,DA,DIQ
29 S DIC=200,DR="9999999.01",DA=PROV,DIQ="AFFL"
30 S:$G(FORM)="I" DIQ(0)="I"
31 D ENDIQ1
32 S AFFL=$S($G(FORM)="I":AFFL(200,PROV,"9999999.01","I"),1:AFFL(200,PROV,"9999999.01"))
33 Q AFFL
34 ;
35PROVCODE(PROV) ;PEP - Retrieve provider code
36 I $G(PROV)="" Q ""
37 I '$D(^VA(200,PROV)) Q ""
38 NEW X,Z,Y,CODE,DIC,DR,DA,DIQ
39 S DIC=200,DR="9999999.02",DA=PROV,DIQ="CODE",DIQ(0)="E"
40 D ENDIQ1
41 Q CODE(200,PROV,"9999999.02","E")
42 ;
43PROVINI(PROV) ;PEP - Retrieve provider initials
44 I '$G(PROV) Q ""
45 I '$D(^VA(200,PROV)) Q ""
46 NEW X,Z,Y,INIT,DIC,DR,DA,DIQ
47 S DIC=200,DR="1",DA=PROV,DIQ="INIT",DIQ(0)="E"
48 D ENDIQ1
49 Q INIT(200,PROV,"1","E")
50 ;
51ENDIQ1 ;
52 NEW CLASS,FORM,PROV,X,Y,Z
53 D EN^DIQ1
54 Q
55 ;
Note: See TracBrowser for help on using the repository browser.