source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDOEDX.m@ 731

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

initial load of FOIAVistA 6/30/08 version

File size: 2.6 KB
Line 
1SDOEDX ;ALB/MJK - ACRP DX APIs For An Encounter ;8/12/96
2 ;;5.3;Scheduling;**131**;Aug 13, 1993
3 ;
4DX(SDOE,SDERR) ; -- SDOE ASSIGNED A DIAGNOSIS
5 ; API ID: 64
6 ;
7 ;
8 N SDOK
9 S SDOK=0
10 ;
11 ; -- do validation checks
12 IF '$$VALOE^SDOEOE(.SDOE,$G(SDERR)) G DXQ
13 IF $$OLD^SDOEUT(SDOE) S SDOK=$$OLDDX(SDOE) G DXQ
14 ;
15 S SDOK=$$DX^PXAPIOE($$VIEN^SDOEUT(.SDOE),$G(SDERR))
16DXQ Q SDOK
17 ;
18 ;
19GETDX(SDOE,SDDX,SDERR) ; -- SDOE GET DIAGNOSES
20 ; API ID: 56
21 ;
22 ;
23GETDXG ; -- goto entry point
24 ;
25 ; -- do validation checks
26 IF '$$VALOE^SDOEOE(.SDOE,$G(SDERR)) G GETDXQ
27 IF $$OLD^SDOEUT(SDOE) D OLDDXS(SDOE,.SDDX) G GETDXQ
28 ;
29 D GETDX^PXAPIOE($$VIEN^SDOEUT(.SDOE),.SDDX,$G(SDERR))
30GETDXQ Q
31 ;
32 ;
33FINDDX(SDOE,SDDXID,SDERR) ; -- SDOE FIND DIAGNOSIS
34 ; API ID: 70
35 ;
36 ;
37 N SDDXS,SDOK,I
38 S SDDXS="SDDXS"
39 ;
40 ; -- do validation checks
41 IF '$$VALDX(.SDDXID,$G(SDERR)) S SDOK=0 G FINDDXQ
42 ;
43 D GETDX(.SDOE,.SDDXS,$G(SDERR))
44 S (I,SDOK)=0
45 F S I=$O(SDDXS(I)) Q:'I S SDOK=(+SDDXS(I)=SDDXID) Q:SDOK
46FINDDXQ Q SDOK
47 ;
48 ;
49GETPDX(SDOE,SDERR) ; -- SDOE GET PRIMARY DIAGNOSIS
50 ; API ID: 73
51 ;
52 ;
53 N SDDXS,I,SDPDX,CNT
54 S SDDXS="SDDXS"
55 D GETDX(.SDOE,.SDDXS,$G(SDERR))
56 ;
57 ; -- how many are primaries / kill secondaries from array
58 S (CNT,I)=0
59 F S I=$O(SDDXS(I)) Q:'I S X=$P(SDDXS(I),"^",12) S:X="P" CNT=CNT+1 K:X'="P" SDDXS(I)
60 S SDPDX=+$G(SDDXS(+$O(SDDXS(0))))
61 ;
62 ; -- check for too many primaries & build error msg
63 IF CNT>1 D
64 . N DFN,DFN0,SDIN,SDOUT,Y,I,VA
65 . ;
66 . S SDPDX=0
67 . S DFN=+$P($G(^SCE(+SDOE,0)),"^",2)
68 . S DFN0=$G(^DPT(DFN,0))
69 . D PID^VADPT6
70 . ;
71 . S SDIN("ID")=SDOE,SDOUT("ID")=SDOE
72 . S SDIN("DFN")=DFN,SDOUT("DFN")=DFN
73 . S SDIN("PATNAME")=$P(DFN0,"^"),SDOUT("PATNAME")=$P(DFN0,"^")
74 . S SDIN("PID")=VA("PID"),SDOUT("PID")=VA("PID")
75 . ;
76 . S I=0,Y=""
77 . F S I=$O(SDDX(I)) Q:'I S Y=$P($G(^ICD9(+SDDXS,0)),"^")_" "
78 . S SDIN("CODES")=Y,SDOUT("CODES")=Y
79 . ;
80 . D BLD^SDQVAL(4096800.025,.SDIN,.SDOUT,$G(SDERR))
81 ;
82GETPDXQ Q SDPDX
83 ;
84 ;
85VALDX(SDDXID,SDERR) ; -- validate dx input
86 ;
87 ; -- do checks
88 IF SDDXID,$D(^ICD9(SDDXID,0)) Q 1
89 ;
90 ; -- build error msg
91 N SDIN,SDOUT
92 S SDIN("ID")=SDDXID
93 S SDOUT("ID")=SDDXID
94 D BLD^SDQVAL(4096800.004,.SDIN,.SDOUT,$G(SDERR))
95 Q 0
96 ;
97 ;
98OLDDX(SDOE) ; -- at least one dx for OLD encounter?
99 Q ($O(^SDD(409.43,"OE",+SDOE,0))>0)
100 ;
101OLDDXS(SDOE,SDARY) ; -- get DX's for OLD encounter
102 N SDIEN,SDCNT,Y,X
103 S (SDIEN,SDCNT)=0
104 F S SDIEN=$O(^SDD(409.43,"OE",SDOE,SDIEN)) Q:'SDIEN D
105 . S SDCNT=SDCNT+1,X=$G(^SDD(409.43,SDIEN,0))
106 . S $P(Y,U,1)=+X ; -- dx ien
107 . S $P(Y,U,12)=$S($P(X,"^",3)=1:"P",1:"S") ; -- primary dx?
108 . S @SDARY@(SDIEN)=Y
109 S @SDARY=SDCNT
110 Q
111 ;
Note: See TracBrowser for help on using the repository browser.