source: FOIAVistA/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXBGPRV3.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 3.4 KB
Line 
1PXBGPRV3 ;ISL/JVS - DOUBLE ?? GATHERING OF CLINIC PROVIDER ;11/5/96 14:23
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**7,11**;Aug 12, 1996
3 ;
4 ;
5 ;
6 W !,"THIS IS NOT AN ENTRY POINT" Q
7 ;
8 ;
9DOUBLE1(FROM) ;--Entry point
10 ;
11NEW ;
12 ;
13 N FILE,FIELD,TITLE,HEADING,SUB,CODE,NAME,START,SCREEN,CNT,OK,INDEX,CYCLE
14 N TOTAL,PRV,CNT,PXBPMT,SUB2
15 ;---SETUP VARIABLES
16 S BACK="",INDEX=""
17 S START=DATA,SUB=0,SUB2=0
18 ;
19START1 ;--RECYCLE POINT
20 S TITLE="- - C L I N I C P R O V I D E R S - -"
21 ;
22 D PRV^PXBUTL2(CLINIC)
23 ;
24 I '$D(PXBPMT) S TOTAL=0
25 I $D(PXBPMT) D
26 .S (PRV,CNT)="" F S PRV=$O(PXBPMT("PRV",PRV)) Q:PRV="" S CNT=CNT+1 D
27 ..S ^TMP("PXBTOTAL",$J,"DILIST","ID",CNT,.01)=PRV
28 ..S ^TMP("PXBTOTAL",$J,"DILIST",2,CNT)=$O(PXBPMT("PRV",PRV,0))
29 I $D(CNT) S TOTAL=CNT
30 ;
31 ;--DISPLAY IF NO MATCH FOUND
32 I TOTAL=0 W IOCUU,IOCUU,!,IOELEOL D
33 .D LOC W !
34 .S RESULTS="NO PROVIDERS ARE SET UP FOR THIS CLINIC" W !!!,?(IOM-$L(RESULTS))\2,RESULTS D HELP1^PXBUTL1("CON") R OK:DTIME
35 I TOTAL=0 Q TOTAL
36 ;
37 ;
38 ;----DISPLAY LIST TO THE SCREEN
39 S HEADING="W !,""ITEM"",?6,""NAME "",IOINHI,TOTAL,"" MATCHES"",IOINLOW,?30,"" PERSON CLASS IN NEW PERSON FILE"""
40LIST ;-DISPLAY LIST TO THE SCREEN
41 D LOC W !
42 X HEADING
43 S SUB=SUB-1
44 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
45 .S NAME=$G(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,.01))
46 .S TYPE=$$OCCUP^PXBGPRV($G(^TMP("PXBTOTAL",$J,"DILIST",2,SUB)),+$P($G(^AUPNVSIT(PXBVST,0)),"^",1),"",2) D
47 ..N Y,DATE
48 ..S Y=+$P($G(^AUPNVSIT(PXBVST,0)),"^",1) X ^DD("DD") S DATE=$P(Y,"@",1)
49 ..I +TYPE=-2 S TYPE="*** CLASS not 'ACTIVE' on "_DATE_"***"
50 ..I +TYPE=-1 S TYPE=""
51 .W !,SUB,?6,$E(NAME,1,20),?30,$E(TYPE,1,45)
52 ;
53 ;----If There is only one selection go to proper prompting
54 I TOTAL=1 G PRMPT2
55 ;
56PRMPT ;---WRITE PROMPT HERE
57 D WIN17^PXBCC(PXBCNT)
58 D LOC^PXBCC(15,1)
59 W !
60 I SUB>0 W !,"Enter '^' to quit"
61 E I TOTAL>10 W !," END OF LIST"
62 I SUB>0 S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to continue: "
63 E S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to exit: "
64 S DIR("?")="Enter ITEM 'No' to select , '^' to quit"
65 S DIR(0)="N,A,O^0:"_SUB2_":0^I X'?.1""^"".N K X"
66 D ^DIR
67 I X="",SUB>0 G LIST
68 I X="",SUB'>0 S X="^"
69VAL ;-----Set the VAL equal to the value
70 S VAL=$G(^TMP("PXBTOTAL",$J,"DILIST",2,X))_"^"_$G(^TMP("PXBTOTAL",$J,"DILIST","ID",X,.01))
71EXITNEW ;--EXIT
72 K DIR,^TMP("PXBTANA",$J),^TMP("PXBTOTAL",$J)
73 K TANA,TOTAL
74 Q VAL
75 Q
76 ;
77 ;-----------------SUBROUTINES--------------
78BACK ;
79 S START=$G(^TMP("PXBTANA",$J,"DILIST",1,1))
80 S START("IEN")=$G(^TMP("PXBTANA",$J,"DILIST",2,1))
81 Q
82FORWARD ;
83 S START=$G(^TMP("PXBTANA",$J,"DILIST",1,10))
84 S START("IEN")=$G(^TMP("PXBTANA",$J,"DILIST",2,10))
85 Q
86LOC ;--LOCATE CURSOR
87 D LOC^PXBCC(3,1) ;--LOCATE THE CURSOR
88 W IOEDEOP ;--CLEAR THE PAGE
89 Q
90HEAD ;--HEAD
91 W !,IOCUU,IOBON,"HELP SCREEN",IOSGR0,?(IOM-$L(TITLE))\2,IOINHI,TITLE,IOINLOW,IOELEOL
92 Q
93SUB ;--DISPLAY LIST TO THE SCREEN
94 I $P(^TMP("PXBTANA",$J,"DILIST",0),"^",1)=0 W !!," E N D O F L I S T" Q
95 X HEADING
96 S SUB=0,CNT=0 F S SUB=$O(^TMP("PXBTANA",$J,"DILIST","ID",SUB)) Q:SUB'>0 S CNT=CNT+1 D
97 .S NAME=$G(^TMP("PXBTANA",$J,"DILIST","ID",SUB,.01))
98 .W !,SUB,?6,NAME
99 Q
100SETUP ;-SETP VARIABLES
101 S FILE=200,FIELD=.01 D
102 S HEADING="W !,""ITEM"",?6,""NAME"""
103 Q
104PRMPT2 ;-----Yes and No prompt if onlyi choice
105 D WIN17^PXBCC(PXBCNT)
106 D LOC^PXBCC(15,1)
107 S DIR("A")="Is this the correct entry "
108 S DIR("B")="YES"
109 S DIR(0)="Y"
110 D ^DIR
111 I Y=0 S X="^"
112 I Y=1 S X=1
113 G VAL
Note: See TracBrowser for help on using the repository browser.