source: WorldVistAEHR/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXCEPRV.m@ 1000

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

initial load of WorldVistAEHR

File size: 5.2 KB
Line 
1PXCEPRV ;ISL/dee - Used to edit and display V PROVIDER ;5/10/05 6:23pm
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**7,27,124**;Aug 12, 1996
3 ;
4 Q
5 ;
6 ;Line with the line label "FORMAT"
7 ;;Long name~File Number~Node Subscripts~Allow Duplicate entries (1=yes, 0=no)~File global name
8 ; 1 2 3 4 5
9 ;
10 ;Followning lines:
11 ;;Node~Piece~,Field Number~Edit Label~Display Label~Display Routine~Edit Routine~Help Text for DIR("?")~Set of PXCEKEYS that can Edit~D if Detail Display Only~
12 ; 1 ~ 2 ~ 3 ~ 4 ~ 5 ~ 6 ~ 7 ~ 8 ~ 9 ~ 10
13 ;The Display & Edit routines are for special caces.
14 ; (The .01 field cannot have a special edit.)
15 ;
16FORMAT ;;Provider~9000010.06~0,12,811,812~0~^AUPNVPRV
17 ;;0~1~.01~Provider: ~Provider: ~$$DISPLY01^PXCEPRV~EPROV^PXCEPRV~^D HELP^PXCEHELP~~B
18 ;;0~4~.04~Is this Provider Primary: ~Primary: ~$$DISPPRIM^PXCEPRV~EPRIMSEC^PXCEPRV~~~N
19 ;;0~5~.05~Is this Provider Attending: ~Attending: ~~EATTEND^PXCEPRV~~~N
20 ;;
21 ;
22 ;The interface for AICS to get list on form for help.
23INTRFACE ;;SD SELECT PROVIDER
24 ;
25 ;********************************
26 ;Special cases for display.
27 ;
28DISPPRIM(PXCEPRIM) ;
29 Q $S(PXCEPRIM="P":$$EXTERNAL^DILFD(9000010.06,".04","",PXCEPRIM,"PXCEDILF"),1:"")
30 ;
31 ;********************************
32 ;Special cases for edit.
33 ;
34EPROV ;
35 K DIRUT
36 N DIC,DA,PXPRVDT
37 S PXPRVDT=+^TMP("PXK",$J,"VST",1,0,"AFTER")
38 I $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))'="" D
39 . N DIERR,PXCEDILF,PXCEINT,PXCEEXT
40 . S PXCEINT=$P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))
41 . S PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$P(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
42 . S DIC("B")=$S('$D(DIERR):PXCEEXT,1:PXCEINT)
43 S DIC=200
44 S DIC(0)="AEMQ"
45 S DIC("A")=$P(PXCETEXT,"~",4)
46 S DIC("S")="I $$ACTIVPRV^PXAPI(Y,PXPRVDT)"
47 D ^DIC
48 K DIR
49 I $D(DUOUT)!$D(DTOUT)!(X="") S DIRUT=1 Q
50 Q:$D(DIRUT)
51 S:'($D(X)#2) X=+Y
52 Q
53 ;
54EPRIMSEC ;For Primary/Secondary field only allows one primary.
55 ; Also used by V-POV
56 K Y,DTOUT,DUOUT,PXCEPRIM
57 ;See if there is already a primary provider in V Provider for this Visit
58 S PXCEPRIM=$$PRIMSEC^PXUTL1(PXCEVIEN,PXCEAUPN,$P(PXCETEXT,"~",1),$P(PXCETEXT,"~",2))
59 I 'PXCEPRIM S Y="PRIMARY"
60 I $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))'="" D
61 . N DIERR,PXCEDILF,PXCEEXT,PXCEINT
62 . S PXCEINT=$P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))
63 . S PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$P(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
64 . S Y=$S('$D(DIERR):PXCEEXT,1:PXCEINT)
65 I $D(Y),'PXCEPRIM!($E(Y)="P") D
66 . S DIR("B")=$S($E(Y)="P":"YES",1:"NO")
67 . S DIR(0)="YAO"
68 . S DIR("A")=$P(PXCETEXT,"~",4)
69 . S:$P(PXCETEXT,"~",8)]"" DIR("?")=$P(PXCETEXT,"~",8)
70 . D ^DIR
71 . K DIR,DA
72 . S Y=$S(Y:"P",1:"S")
73 E S Y="S"
74 I $D(DTOUT)!$D(DUOUT) S (PXCEEND,PXCEQUIT)=1 Q ;This field is required.
75 S $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))=$P(Y,"^")
76 Q
77 ;
78EATTEND ;Attending/Operating field only ask for Attending
79 S DIR("B")=$S($P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))="A":"YES",1:"NO")
80 S DIR(0)="YAO"
81 S DIR("A")=$P(PXCETEXT,"~",4)
82 S:$P(PXCETEXT,"~",8)]"" DIR("?")=$P(PXCETEXT,"~",8)
83 D ^DIR
84 K DIR,DA
85 I X="@" S Y="@"
86 E I $D(DTOUT)!$D(DUOUT) S PXCEEND=1 Q
87 E I +Y S Y="A"
88 E I $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))="A" S Y="@"
89 E S Y=""
90 S $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))=$P(Y,"^")
91 Q
92 ;
93EPROV12 ;
94 K DIRUT
95 N DIC,DA,PXPRVDT
96 S PXPRVDT=+^TMP("PXK",$J,"VST",1,0,"AFTER")
97 I $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))'="" D
98 . N DIERR,PXCEDILF,PXCEINT,PXCEEXT
99 . S PXCEINT=$P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))
100 . S PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$P(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
101 . S DIC("B")=$S('$D(DIERR):PXCEEXT,1:PXCEINT)
102 S DIC=200
103 S DIC(0)="AEMQ"
104 S DIC("A")=$P(PXCETEXT,"~",4)
105 S DIC("S")="I $$ACTIVPRV^PXAPI(Y,PXPRVDT)"
106 D ^DIC
107 K DIR
108 I $D(DUOUT)!$D(DTOUT) S PXCEEND=1 Q
109 Q:X=""
110 S $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))=$P(Y,"^")
111 ;S:'($D(X)#2) X=+Y
112 Q
113 ;
114 ;********************************
115PERCLASS(PXCEPRV) ;Returns text for person class
116 N PXCEPERC
117 S PXCEPERC=$$OCCUP^PXBGPRV(PXCEPRV,+^AUPNVSIT(PXCEVIEN,0),"",2)
118 G PRCL
119DPERCLAS(PXCECLAS) ;Returns text for person class
120 N PXCEPERC
121 S PXCEPERC=$S(PXCECLAS>0:$$OCCUP^PXBGPRV("","","",2,PXCECLAS),1:"")
122PRCL ;
123 I PXCEPERC="" S PXCEPERC="## No Person Class ##"
124 E I PXCEPERC=-1 S PXCEPERC="!! No Person Class Defined !!"
125 E I PXCEPERC=-2 S PXCEPERC="** No Active Person Class **"
126 E I +PXCEPERC<0 S PXCEPERC=""
127 Q PXCEPERC
128 ;
129 ;********************************
130 ;Display text for the .01 field which is a pointer to ^ICPT.
131 ;(Must have is called by ASK^PXCEVFI2 and DEL^PXCEVFI2.)
132DISPLY01(PXCEPRV) ;
133 N DIERR,PXCEDILF,PXCEEPRV,PXCEEPS,PXCEEAO,PXCEPERC,PXCERET
134 S PXCEEPRV=$$EXTERNAL^DILFD(9000010.06,".01","",$P(PXCEPRV,"^",1),"PXCEDILF")
135 S PXCEEPS=$$EXTERNAL^DILFD(9000010.06,".04","",$P(PXCEPRV,"^",4),"PXCEDILF")
136 S PXCEEAO=$$EXTERNAL^DILFD(9000010.06,".05","",$P(PXCEPRV,"^",5),"PXCEDILF")
137 S PXCEPERC=$$DPERCLAS($P(PXCEPRV,"^",6))
138 S PXCERET=PXCEEPRV_" "_$S($E(PXCEEPS)="P":PXCEEPS_" ",1:"")_$S(PXCEEAO]"":PXCEEAO_" ",1:"")
139 S PXCERET=PXCERET_$E(PXCEPERC,1,(65-$L(PXCERET)))
140 Q PXCERET
141 ;
Note: See TracBrowser for help on using the repository browser.