source: WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUCPT.m@ 1195

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

initial load of WorldVistAEHR

File size: 1.2 KB
Line 
1ECXUCPT ;ALB/TJL-CPT INQUIRY FOR MYSTERY FEEDER KEYS ; 10/15/03 2:12pm
2 ;;3.0;DSS EXTRACTS;**49**;July 1, 2003
3 ;
4EN ; entry point
5 N X,Y,DATE,ECRUN,QFLG
6 S QFLG=0
7 ; get today's date
8 D NOW^%DTC S DATE=X,Y=$E(%,1,12) D DD^%DT S ECRUN=$P(Y,"@") K %DT
9 D BEGIN
10 F D SELECT W @IOF Q:QFLG
11 Q
12 ;
13BEGIN ; display report description
14 W @IOF
15 W !,"This inquiry allows the user to select a CPT code, then displays"
16 W !,"the Short Name, Category, and Description for the selected code."
17 W !!
18 Q
19 ;
20SELECT ; user inputs for CPT Code
21 N OUT,DIC,X,Y,DIR,ECXARR,ECXERR,ECXIEN
22 S DIC="^ICPT(",DIC(0)="AZEMQ" D ^DIC
23 I Y<0 S QFLG=1 Q
24 S ECXIEN=+Y
25 D GETS^DIQ(81,ECXIEN,".01;2;3;50*","E","ECXARR","ECXERR")
26 I $D(ECXERR) W !,"CPT Code Error." S QFLG=1 Q
27 D PRINT
28 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1
29 Q
30 ;
31PRINT ; display results of inquiry
32 N LN,DA,DESCDA
33 S $P(LN,"-",80)=""
34 W !!,"CPT Inquiry",?54,"Date: ",ECRUN,!,LN,!
35 S DA=ECXIEN S DA=DA_","
36 W !,"CPT Code: ",ECXARR(81,DA,.01,"E")
37 W ?30,"Short Name: ",ECXARR(81,DA,2,"E")
38 W !!,"Category: ",ECXARR(81,DA,3,"E")
39 W !!,"Description: "
40 F LN=1:1 S DESCDA=LN_","_DA Q:'$D(ECXARR(81.01,DESCDA,.01,"E")) D
41 .W ECXARR(81.01,DESCDA,.01,"E"),!
42 W !!!
43 Q
44 ;
Note: See TracBrowser for help on using the repository browser.