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

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

initial load of WorldVistAEHR

File size: 5.3 KB
Line 
1PXBGCPT2 ;ISL/JVS,ESW - DOUBLE ?? GATHERING OF CPT CODES ; 10/31/02 12:05pm
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,19,108,149**;Aug 12, 1996
3 ;
4 ;
5 ;
6 W !,"NOT" Q
7 ;
8DOUBLE(FROM) ;--Entry
9 ;
10 N FILE,FIELD,TITLE,HEADING,SUB,CODE,NAME,START,SCREEN,BACK,NUM
11 N SCREEN,TEMP,FIRST
12 S BACK="",NUM=0,SCREEN=""
13 D LOC
14 I $D(DIC("S")) S SCREEN=DIC("S")
15 ;
16START ;
17 ;
18 S TITLE="- - A L L P R O C E D U R E (CPT CODES) - -"
19 ;
20 D SETUP
21 D LIST^DIC(FILE,"",FIELD,BACK,10,.START,"","",SCREEN,"","^TMP(""PXBTANA"",$J)","^TMP(""PXBTANA"",$J)")
22 ;
23 D LOC,HEAD,SUB
24 ;
25PROMPT ;--PROMPT
26 D WIN17^PXBCC(PXBCNT),LOC^PXBCC(15,1)
27 W !!,"Enter '^' to quit, '-' for previous page."
28 S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to continue: "
29 S DIR("?")="Enter ITEM 'No' to select , '^' to quit, '-' for previous page."
30 S DIR(0)="N,A,O^0:10:0^I X'?.1""-"".1""^"".2N!(+X>10) K X"
31 D ^DIR
32 I X="-" S BACK="B" D BACK G START
33 I X="" S BACK="" D FORWARD G START
34 I $G(DIRUT) K DIRUT S VAL="^C" G EXIT
35FINISH ;--FINISH
36 ;
37 S VAL=$G(^TMP("PXBTANA",$J,"DILIST",2,X))_U_$G(^TMP("PXBTANA",$J,"DILIST","ID",X,FIRST))_"--"_$G(^TMP("PXBTANA",$J,"DILIST","ID",X,SECOND))
38EXIT ;--EXIT
39 K DIR,^TMP("PXBTANA",$J),^TMP("PXBTOTAL",$J)
40 Q VAL
41 ;
42DOUBLE1(FROM) ;--Entry
43 ;
44NEW ;
45 N FILE,FIELD,TITLE,HEADING,SUB,CODE,NAME,START,SCREEN,CNT,OK,INDEX,CYCLE
46 N TOTAL,FIRST,SUB2
47 ;---SETUP
48 S BACK="",INDEX=""
49 S START=DATA,SUB=0,SUB2=0
50 ;
51START1 ;--RECYCLE
52 S TITLE="- - S E L E C T E D P R O C E D U R E S (CPT CODES) - -"
53 S FILE=81
54 S FIELD=".01;2"
55 N TMP,LL,TT
56 S LL=$L(DATA),TT="0000"
57 I DATA?1.4N!(DATA?1A.3N) D
58 .S START=$O(^ICPT("B",DATA_$E(TT,1,5-LL)),-1)
59 I DATA?5N!(DATA?1A4N)!(DATA?4N1A) D
60 .S START=$O(^ICPT("B",START),-1)
61XXX W IOCUOFF,IOCUF,IOCUF
62 N TMP
63 S SUBT=START,TOTAL=0 F S SUBT=$O(^ICPT("B",SUBT)) Q:SUBT'[DATA D
64 .I '$$CPTSCREN^PXBUTL($O(^ICPT("B",SUBT,0)),IDATE) Q
65 .S TOTAL=TOTAL+1 S PXBMOD=TOTAL#100 D WAIT^PXBUTL
66 .S ^TMP("PXBTOTAL",$J,"DILIST","ID",TOTAL,.01)=SUBT
67 .S ^TMP("PXBTOTAL",$J,"DILIST","ID",TOTAL,2)=$P($$CPT^ICPTCOD($O(^ICPT("B",SUBT,0)),IDATE),U,3)
68 .S TMP(SUBT)=""
69 I DATA?1.4N!(DATA?.3N1A) D
70 .S START=$O(^ICPT("B",$E(TT,1,5-LL)_DATA),-1)
71 .S SUBT=START F S SUBT=$O(^ICPT("B",SUBT)) Q:SUBT'[DATA D
72 ..Q:$D(TMP(SUBT))
73 ..I '$$CPTSCREN^PXBUTL($O(^ICPT("B",SUBT,0)),IDATE) Q
74 ..S TOTAL=TOTAL+1 S PXBMOD=TOTAL#100 D WAIT^PXBUTL
75 ..S ^TMP("PXBTOTAL",$J,"DILIST","ID",TOTAL,.01)=SUBT
76 ..S ^TMP("PXBTOTAL",$J,"DILIST","ID",TOTAL,2)=$P($$CPT^ICPTCOD($O(^ICPT("B",SUBT,0)),IDATE),U,3)
77 W IOCUON
78 ;
79 ;
80 ;
81 I DATA?2.A W IOCUOFF,IOCUF,IOCUF S SUBT=$O(^ICPT("C",DATA),-1) F S SUBT=$O(^ICPT("C",SUBT)) Q:SUBT'[DATA D
82 .N IEN,CODE
83 .S IEN="" F S IEN=$O(^ICPT("C",SUBT,IEN)) Q:IEN="" D
84 ..S CODE=$P(^ICPT(IEN,0),U) I '$$CPTSCREN^PXBUTL(CODE,IDATE) Q
85 ..S TOTAL=TOTAL+1 S PXBMOD=TOTAL#100 D WAIT^PXBUTL
86 ..S ^TMP("PXBTOTAL",$J,"DILIST","ID",TOTAL,.01)=$P(^ICPT(IEN,0),U)
87 ..S ^TMP("PXBTOTAL",$J,"DILIST","ID",TOTAL,2)=SUBT_", "_$P($$CPT^ICPTCOD(IEN,IDATE),U,3)
88 W IOCUON
89 K SUBT
90 ;
91 ;
92 ;
93 ;--NO MATCH
94 I TOTAL=0 D
95 .I DATA?1A W ! D HELP^PXBUTL0("CPT4")
96 .I DATA'?1A W ! D HELP^PXBUTL0("CPTM")
97 .S ERROR=1,CYCL=1
98 I TOTAL=0 Q TOTAL
99 ;
100 ;--LIST
101 S HEADING="W !,""ITEM"",?6,""CODE"",?15,""DESCRIPTION "",IOINHI,TOTAL,"" MATCHES"",IOINLOW"
102LIST ;-DISPLAY LIST TO THE SCREEN
103 I TOTAL=1 S X=1 G VAL
104 D LOC W !
105 X HEADING
106 S SUB=SUB-1
107 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
108 .S CODE=$G(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,.01))
109 .S NAME=$E($G(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,2)),1,64)
110 .W !,SUB,?6,CODE,?15,NAME
111 ;
112 ;--one
113 I TOTAL=1 G PRMPT2
114 ;
115PRMPT ;--PROMPT
116 D WIN17^PXBCC(PXBCNT)
117 D LOC^PXBCC(15,1)
118 W !
119 I SUB>0 W !,"Enter '^' to quit"
120 E I TOTAL>10 W !," END OF LIST"
121 I SUB>0 S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to continue: "
122 E S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to exit: "
123 S DIR("?")="Enter ITEM 'No' to select , '^' to quit"
124 S DIR(0)="N,A,O^0:"_SUB2_":0^I X'?.1""^"".N K X"
125 D ^DIR
126 I X="",SUB>0 G LIST
127 I X="",SUB'>0 S X="^"
128VAL ;--VAL equal value
129 S VAL=$G(^TMP("PXBTOTAL",$J,"DILIST",2,X))_U_$G(^TMP("PXBTOTAL",$J,"DILIST","ID",X,.01))_"--"_$G(^TMP("PXBTOTAL",$J,"DILIST","ID",X,2))
130EXITNEW ;--EXIT
131 K DIR,DIRUT,^TMP("PXBTANA",$J),^TMP("PXBTOTAL",$J)
132 K TANA,TOTAL
133 Q VAL
134 Q
135 ;
136 ;--SUBROUTINES
137BACK ;
138 S START=$G(^TMP("PXBTANA",$J,"DILIST",1,1))
139 S START("IEN")=$G(^TMP("PXBTANA",$J,"DILIST",2,1))
140 Q
141FORWARD ;
142 S START=$G(^TMP("PXBTANA",$J,"DILIST",1,10))
143 S START("IEN")=$G(^TMP("PXBTANA",$J,"DILIST",2,10))
144 Q
145LOC ;--LOCATE CURSOR
146 D LOC^PXBCC(3,1) ;--LOCATE THE CURSOR
147 W IOEDEOP ;--CLEAR THE PAGE
148 Q
149HEAD ;--HEAD
150 W !,IOCUU,IOBON,"HELP SCREEN",IOSGR0,?(IOM-$L(TITLE))\2,IOINHI,TITLE,IOINLOW,IOELEOL
151 Q
152SUB ;--LIST
153 I $P(^TMP("PXBTANA",$J,"DILIST",0),U)=0 W !!," E N D O F L I S T" Q
154 X HEADING
155 S SUB=0,CNT=0 F S SUB=$O(^TMP("PXBTANA",$J,"DILIST","ID",SUB)) Q:SUB'>0 S CNT=CNT+1 D
156 .S CODE=$G(^TMP("PXBTANA",$J,"DILIST","ID",SUB,FIRST))
157 .S NAME=$G(^TMP("PXBTANA",$J,"DILIST","ID",SUB,SECOND))
158 .W !,SUB,?6,CODE,?15,NAME
159 Q
160SETUP ;--SET
161 S FILE=81,FIRST=.01,SECOND=2
162 S FIELD=FIRST_";"_SECOND
163 S HEADING="W !,""ITEM"",?6,""CODE"",?15,""DESCRIPTION"""
164 Q
165PRMPT2 ;--Yes and No prompt
166 D WIN17^PXBCC(PXBCNT)
167 D LOC^PXBCC(15,1)
168 S DIR("A")="Is this the correct entry "
169 S DIR("B")="YES"
170 S DIR(0)="Y"
171 D ^DIR
172 I Y=0 S X="^"
173 I Y=1 S X=1
174 G VAL
175 ;
Note: See TracBrowser for help on using the repository browser.