source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPW241.m@ 1742

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

initial load of FOIAVistA 6/30/08 version
File size: 3.3 KB
Line 
1SCRPW241 ;BPCIOFO/ACS - ACRP Ad Hoc Report (cont.) ;06/30/99
2 ;;5.3;Scheduling;**180,254,351**;AUG 13, 1993
3 ;
4 ;----------------------------------------------------------------
5 ; This routine was created due to the max number of bytes
6 ; being reached in SCRPW24
7 ;
8 ; This routine is called by SCRPW24, and it contains CPT API calls
9 ;
10 ;----------------------------------------------------------------
11 ;
12APAC(SDX) ;Get all procedure codes
13 ; INPUT - .SDX array reference
14 ; OUTPUT- SDX array with CPT pointer, CPT code, quantity
15 ;
16 K SDX
17 N SDY,SDI,CPTINFO,CPTCODE
18 ; array SDY will contain the CPT information
19 D GETCPT^SDOE(SDOE,"SDY")
20 ; Spin through CPT array and get CPT code and quantity
21 S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI D
22 . I $D(SDY(SDI,0)) S SDX=$P(SDY(SDI,0),U)
23 . E Q
24 . S CPTINFO=$$CPT^ICPTCOD(+SDX,+SDOE0,1)
25 . Q:CPTINFO'>0
26 . S CPTCODE=$P(CPTINFO,U,2)
27 . S SDX=SDX_U_CPTCODE_U_$P(SDY(SDI,0),U,16)
28 . I $L($P(SDX,U,2)) D APOTR(.SDX) S SDX(SDI)=SDX
29 . Q
30 Q
31 ;
32APOTR(SDX) ;Transform procedure external value
33 ; INPUT - .SDX CPT pointer
34 ; OUTPUT- SDX text string containing CPT code, CPT text
35 ;
36 N CPTINFO,CPTTEXT,ENCDT
37 S ENCDT=+$G(SDOE0)
38 I 'ENCDT D
39 .I '$G(SDOE) S ENCDT=$$NOW^XLFDT() Q
40 .D GETGEN^SDOE(SDOE,"SDY")
41 .S ENCDT=+$G(SDY(0))
42 .K SDY
43 S CPTINFO=$$CPT^ICPTCOD(+SDX,ENCDT,1)
44 Q:CPTINFO'>0
45 S CPTTEXT=$P(CPTINFO,U,3)
46 S $P(SDX,U,2)=$P(SDX,U,2)_" "_CPTTEXT
47 Q
48 ;
49APAP(SDX) ;Get ambulatory procedures (no E&M codes)
50 ; INPUT - .SDX array reference
51 ; OUTPUT- SDX array containing CPT pointer, CPT code, CPT text
52 ;
53 K SDX
54 N SDY,SDI,CPTINFO,CPTCODE
55 D GETCPT^SDOE(SDOE,"SDY")
56 ; Spin through CPT array and get CPT code
57 S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI D
58 . I $D(SDY(SDI,0)) S SDX=$P(SDY(SDI,0),U)
59 . E Q
60 . I '$D(^IBE(357.69,"B",SDX)) D
61 .. S CPTINFO=$$CPT^ICPTCOD(+SDX,+SDOE0,1)
62 .. Q:CPTINFO'>0
63 .. S CPTCODE=$P(CPTINFO,U,2)
64 .. S SDX=SDX_U_CPTCODE
65 .. I $L($P(SDX,U,2)) D APOTR(.SDX) S SDX(SDI)=SDX
66 .. Q
67 . Q
68 Q
69 ;
70APEM(SDX) ;Get evaluation and management codes
71 ; INPUT - .SDX array reference
72 ; OUTPUT- SDX array containing CPT pointer, CPT code, CPT text
73 ;
74 K SDX
75 N SDY,SDI,CPTINFO,CPTCODE
76 D GETCPT^SDOE(SDOE,"SDY")
77 ; Spin through CPT array and get CPT code
78 S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI D
79 . I $D(SDY(SDI,0)) S SDX=$P(SDY(SDI,0),U)
80 . E Q
81 . I $D(^IBE(357.69,"B",SDX)) D
82 .. S CPTINFO=$$CPT^ICPTCOD(+SDX,+SDOE0,1)
83 .. Q:CPTINFO'>0
84 .. S CPTCODE=$P(CPTINFO,U,2)
85 .. S SDX=SDX_U_CPTCODE
86 .. I $L($P(SDX,U,2)) D APOTR(.SDX) S SDX(SDI)=SDX
87 .. Q
88 . Q
89 Q
90 ;
91PDPE(SDX) ;Get patient's ethnicities
92 K SDX
93 N DFN,VADM,NUM,CNT,ABB,TXT
94 S DFN=$P(SDOE0,U,2)
95 I DFN D DEM^VADPT I VADM(11) S CNT=1,NUM=0 F S NUM=+$O(VADM(11,NUM)) Q:'NUM D
96 .I VADM(11,NUM) D
97 ..S TXT=$$PTR2TEXT^DGUTL4(+VADM(11,NUM),2) S:TXT="" TXT="?"
98 ..S ABB=$$PTR2CODE^DGUTL4(+$G(VADM(11,NUM,1)),3,1) S:ABB="" ABB="?"
99 ..S SDX(CNT)=+VADM(11,NUM)_"^"_TXT_" ("_ABB_")",CNT=CNT+1
100 S:$D(SDX)<10 SDX(1)="~~~NONE~~~^~~~UNANSWERED~~~"
101 Q
102 ;
103PDPR(SDX) ;Get patient's race
104 K SDX
105 N DFN,VADM,NUM,CNT,ABB,TXT
106 S DFN=$P(SDOE0,U,2)
107 I DFN D DEM^VADPT I VADM(12) S CNT=1,NUM=0 F S NUM=+$O(VADM(12,NUM)) Q:'NUM D
108 .I VADM(12,NUM) D
109 ..S TXT=$$PTR2TEXT^DGUTL4(+VADM(12,NUM),1) S:TXT="" TXT="?"
110 ..S ABB=$$PTR2CODE^DGUTL4(+$G(VADM(12,NUM,1)),3,1) S:ABB="" ABB="?"
111 ..S SDX(CNT)=+VADM(12,NUM)_"^"_TXT_" ("_ABB_")",CNT=CNT+1
112 S:$D(SDX)<10 SDX(1)="~~~NONE~~~^~~~UNANSWERED~~~"
113 Q
Note: See TracBrowser for help on using the repository browser.