source: WorldVistAEHR/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXBGPRV2.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: 6.5 KB
Line 
1PXBGPRV2 ;ISL/JVS - DOUBLE ?? GATHERING OF PROVIDER ; 7/12/07 10:38am
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**7,11,19,105,186**;Aug 12, 1996;Build 3
3 ;
4 ;
5 ;
6 W !,"THIS IS NOT AN ENTRY POINT" Q
7 ;
8DOUBLE(FROM) ;--Entry point
9 ;
10 ; WHAT = The same WHAT as sent in from the API
11 ; FROM = Exactly which prompt is asking for the list
12 ; SCREEN = Same as the DIC("S") screen used by file man
13 ; START = The starting point as to what to look up
14 ;
15 N FILE,FIELD,TITLE,HEADING,SUB,CODE,NAME,START,SCREEN,BACK,NUM,TEMP
16 ;
17 S BACK="",NUM=0,SCREEN=""
18 D LOC
19 I $D(DIC("S")) S SCREEN=DIC("S")
20 ;
21START ;--RECYCLE POINT
22 ;
23 S TITLE="- - A L L P R O V I D E R S - -"
24 ;
25 D SETUP
26 ;
27 ; begin patch *186*
28 S:$G(SCREEN)="" SCREEN="I $$ACTIVPRV^PXAPI(Y,$G(IDATE,DT))"
29 ;D LIST^DIC(FILE,"",FIELD,BACK,10,.START,"","","","","^TMP(""PXBTANA"",$J)","^TMP(""PXBTANA"",$J)")
30 D LIST^DIC(FILE,"",FIELD,BACK,10,.START,"","",SCREEN,"","^TMP(""PXBTANA"",$J)","^TMP(""PXBTANA"",$J)")
31 ; end patch *186*
32 ;
33 D LOC,HEAD,SUB
34 ;
35PROMPT ;---WRITE PROMPT HERE
36 D WIN17^PXBCC(PXBCNT),LOC^PXBCC(15,1)
37 I $G(START)'="" W !!,"Enter '^' to quit, '-' for previous page."
38 I $G(START)'="" S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to continue: "
39 I $G(START)="" S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to exit: "
40 S DIR("?")="Enter ITEM 'No' to select , '^' to quit, '-' for previous page."
41 S DIR(0)="N,A,O^0:10:0^I X'?.1""-"".1""^"".2N!(+X>10) K X"
42 D ^DIR
43 I X="",$G(START)="" S X="^",DIRUT=1
44 I X="-" S BACK="B" D BACK G START
45 I X="" S BACK="" D FORWARD G START
46 I $G(DIRUT) K DIRUT S VAL="^P" G EXIT
47FINISH ;--FINISH SETTING A VARIBLE TO SELECTED ITEM
48 ;
49 S VAL=$G(^TMP("PXBTANA",$J,"DILIST",2,X))_"^"_$G(^TMP("PXBTANA",$J,"DILIST","ID",X,.01))
50EXIT ;--EXIT
51 K DIR,^TMP("PXBTANA",$J),^TMP("PXBTOTAL",$J)
52 Q VAL
53 ;
54DOUBLE1(FROM) ;--Entry point
55 ;
56NEW ;
57 ;
58 N FILE,FIELD,TITLE,HEADING,SUB,CODE,NAME,START,SCREEN,CNT,OK,INDEX,CYCLE
59 N TOTAL,TEMP,SUB2,VANUMBER,PXBVA
60 ;---SETUP VARIABLES
61 ; begin patch *186*
62 ; S BACK="",INDEX="",TOTAL1=0
63 S BACK="",INDEX="",TOTAL=0
64 ; end patch *186*
65 S START=DATA,SUB=0,SUB2=0
66 ;
67START1 ;--RECYCLE POINT
68 S TITLE="- - S E L E C T E D P R O V I D E R S - -"
69 S FILE=200
70 S FIELD="@;.01" ; FIELD=.01 TEJ *105 CHANGE PARM 12/14/2000
71RELOOK ;----ADJUST THE DATA FOR LOOKUP IF NECESSARY
72 I DATA?.AP S START=$O(^VA(200,"B",DATA),-1)
73 I DATA?1AP S DATA="*"
74 I DATA?1A4N S START=$O(^VA(200,"BS5",DATA),-1) S INDEX="BS5"
75 ;----------------
76 ; begin patch *186*
77 ;S SCREEN=""
78 S SCREEN="I $$ACTIVPRV^PXAPI(Y,$G(IDATE,DT))"
79 ; end patch *186*
80 ;
81 D LIST^DIC(FILE,"",FIELD,BACK,"",.START,DATA,INDEX,SCREEN,"","^TMP(""PXBTOTAL"",$J)","^TMP(""PXBTOTAL"",$J)")
82 S TOTAL=$P(^TMP("PXBTOTAL",$J,"DILIST",0),"^",1)
83 ;-------------VA NUMBER------------------
84 S PXBVA=0 F S PXBVA=$O(^TMP("PXBTOTAL",$J,"DILIST",2,PXBVA)) Q:PXBVA="" S VANUMBER($G(^TMP("PXBTOTAL",$J,"DILIST",2,PXBVA)))=""
85 S START=$O(^VA(200,"PS2",DATA),-1)
86 I DATA=+DATA S START=DATA_" "
87 F S START=$O(^VA(200,"PS2",START)) Q:START'[DATA D
88 .Q:$D(VANUMBER($O(^VA(200,"PS2",START,0))))
89 .N IEN
90 .S TOTAL=TOTAL+1
91 .S (IEN,^TMP("PXBTOTAL",$J,"DILIST",2,TOTAL))=$O(^VA(200,"PS2",START,0))
92 .S ^TMP("PXBTOTAL",$J,"DILIST","ID",TOTAL,.01)=$P($G(^VA(200,IEN,0)),"^",1)
93 ;----------END VA NUMBERS-----------------
94 ;
95 ;--DISPLAY IF NO MATCH FOUND
96 I TOTAL=0 D
97 .D WIN17^PXBCC(PXBCNT)
98 .I DATA?1AP W ! D HELP^PXBUTL0("CPT4")
99 .I DATA'?1AP W ! D HELP^PXBUTL0("PRVM")
100 .S ERROR=1,CYCL=1
101 I TOTAL=0 Q TOTAL
102 ;
103 ;
104 ;----DISPLAY LIST TO THE SCREEN
105 S HEADING="W !,""ITEM"",?6,""NAME"",?30,""PERSON CLASS IN NEW PERSON FILE"""
106LIST ;-DISPLAY LIST TO THE SCREEN
107 ;---NEW CODE PATCH 11
108 N PXBTYPE
109 I TOTAL=1 D I PXBTYPE>0 S X=1 G VAL
110 .S PXBTYPE=$$GET^XUA4A72($G(^TMP("PXBTOTAL",$J,"DILIST",2,1)),+$P($P($G(^AUPNVSIT(PXBVST,0)),U),"."))
111 ;-----END NEW CODE---
112 ;I TOTAL=1 S X=1 G VAL
113 D LOC W !
114 X HEADING
115 S SUB=SUB-1
116 S NUM=0 F S SUB=$O(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB)) S NUM=NUM+1 Q:NUM=11 Q:SUB'>0 S SUB2=SUB2+1 D
117 .;---CHANGED
118 .N NAME,TYPE
119 .S NAME=$G(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,.01))
120 .S TYPE=$$OCCUP^PXBGPRV($G(^TMP("PXBTOTAL",$J,"DILIST",2,SUB)),+$P($G(^AUPNVSIT(PXBVST,0)),"^",1),"",2) D
121 ..N Y,DATE
122 ..S Y=+$P($G(^AUPNVSIT(PXBVST,0)),"^",1) X ^DD("DD") S DATE=$P(Y,"@",1)
123 ..I +TYPE=-2 S TYPE="*** CLASS not 'ACTIVE' on "_DATE_"***"
124 ..I +TYPE=-1 S TYPE=""
125 .W !,SUB,?6,$E(NAME,1,20),?30,$E(TYPE,1,45)
126 ;----------
127 ;
128 ;----If There is only one selection go to proper prompting
129 I TOTAL=1 G PRMPT2
130 ;
131PRMPT ;---WRITE PROMPT HERE
132 D WIN17^PXBCC(PXBCNT)
133 D LOC^PXBCC(15,1)
134 W !
135 I SUB>0 W !,"Enter '^' to quit"
136 E I TOTAL>10 W !," END OF LIST"
137 I SUB>0 S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to continue: "
138 E S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to exit: "
139 S DIR("?")="Enter ITEM 'No' to select , '^' to quit"
140 S DIR(0)="N,A,O^0:"_SUB2_":0^I X'?.1""^"".N K X"
141 D ^DIR
142 I X="",SUB>0 G LIST
143 I X="",SUB'>0 S X="^"
144VAL ;-----Set the VAL equal to the value
145 S VAL=$G(^TMP("PXBTOTAL",$J,"DILIST",2,X))_"^"_$G(^TMP("PXBTOTAL",$J,"DILIST","ID",X,.01))
146 I FROM="PL",TOTAL=1 W $G(^TMP("PXBTOTAL",$J,"DILIST","ID",X,.01))
147EXITNEW ;--EXIT
148 K DIR,^TMP("PXBTOTAL",$J),^TMP("PXBTANA",$J)
149 K TANA,TOTAL
150 Q VAL
151 Q
152 ;
153 ;-----------------SUBROUTINES--------------
154BACK ;
155 S START=$G(^TMP("PXBTANA",$J,"DILIST",1,1))
156 S START("IEN")=$G(^TMP("PXBTANA",$J,"DILIST",2,1))
157 Q
158FORWARD ;
159 S START=$G(^TMP("PXBTANA",$J,"DILIST",1,10))
160 S START("IEN")=$G(^TMP("PXBTANA",$J,"DILIST",2,10))
161 Q
162LOC ;--LOCATE CURSOR
163 D LOC^PXBCC(3,1) ;--LOCATE THE CURSOR
164 W IOEDEOP ;--CLEAR THE PAGE
165 Q
166HEAD ;--HEAD
167 W !,IOCUU,IOBON,"HELP SCREEN",IOSGR0,?(IOM-$L(TITLE))\2,IOINHI,TITLE,IOINLOW,IOELEOL
168 Q
169SUB ;--DISPLAY LIST TO THE SCREEN
170 N TYPE
171 I $P(^TMP("PXBTANA",$J,"DILIST",0),"^",1)=0 W !!," E N D O F L I S T" Q
172 X HEADING
173 S SUB=0,CNT=0 F S SUB=$O(^TMP("PXBTANA",$J,"DILIST","ID",SUB)) Q:SUB'>0 S CNT=CNT+1 D
174 .S NAME=$G(^TMP("PXBTANA",$J,"DILIST","ID",SUB,.01))
175 .S TYPE=$$OCCUP^PXBGPRV($G(^TMP("PXBTANA",$J,"DILIST",2,SUB)),+$P($G(^AUPNVSIT(PXBVST,0)),"^",1),"",2) D
176 ..N Y,DATE
177 ..S Y=+$P($G(^AUPNVSIT(PXBVST,0)),"^",1) X ^DD("DD") S DATE=$P(Y,"@",1)
178 ..I +TYPE=-2 S TYPE="*** CLASS not 'ACTIVE' on "_DATE_"***"
179 ..I +TYPE=-1 S TYPE=""
180 .W !,SUB,?6,$E(NAME,1,20),?30,$E(TYPE,1,45)
181 Q
182SETUP ;-SETP VARIABLES
183 S FILE=200,FIELD="@;.01" ; FIELD=.01 TEJ *105 CHANGE PARM 12/14/2000
184 S HEADING="W !,""ITEM"",?6,""NAME"",?30,""PERSON CLASS IN NEW PERSON FILE"""
185 Q
186PRMPT2 ;-----Yes and No prompt if onlyi choice
187 D WIN17^PXBCC(PXBCNT)
188 D LOC^PXBCC(15,1)
189 S DIR("A")="Is this the correct entry "
190 S DIR("B")="YES"
191 S DIR(0)="Y"
192 D ^DIR
193 I Y=0 S X="^"
194 I Y=1 S X=1
195 G VAL
Note: See TracBrowser for help on using the repository browser.