source: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSD40031.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 4.4 KB
Line 
1YSD40031 ;DALISC/LJA/MJD - Repoint MR data continued... ;12/09/93 16:45 [ 04/08/94 11:59 AM ]
2 ;;5.01;MENTAL HEALTH;;Dec 30, 1994
3 ;;
4 ;
5REP ; Repoint MR data (Called from ^YSD40030)
6 ;
7 ; Key Variables...
8 ; YSD4IEN -- req --> YSD4CFLG Conversion flag
9 ; (^MR ien) --> YSD4FND Number of Modifiers found
10 ; --> YSD4CONV Number of Modifiers converted
11 ;
12 S (YSD4CFLG,YSD4FND,YSD4CONV)=0
13 ;
14 ; DX node. (Field# 103 - DSM-III DIAGNOSIS)
15 S YSD4MIEN=0
16 F S YSD4MIEN=$O(^MR(+YSD4IEN,"DX",YSD4MIEN)) QUIT:YSD4MIEN'>0 D
17 . I '$D(^MR(+YSD4IEN,"DX",+YSD4MIEN,0)) D QUIT
18 . . D NOW^%DTC
19 . . D PED^YSD4E010(%,"Invalid data structure",90,"DX",+YSD4IEN,+YSD4MIEN,+YSD4DIEN)
20 .
21 . S YSD4DIEN=+$G(^MR(+YSD4IEN,"DX",+YSD4MIEN,0)) QUIT:YSD4DIEN'>0 D DX
22 ;
23 ;
24 ; DX1 node. (Field#'s 102 - PRIN DSM-III DIAG, 102.6 - X DXM-III DIAG)
25 S YSD4DX1=$G(^MR(+YSD4IEN,"DX1"))
26 I $P(YSD4DX1,U,2)>0!($P(YSD4DX1,U,4)>0) D DX1
27 ;
28 ;
29 ; PDX node. (Field# 99.06PA:.01 - PAST PRINCIPAL DX)
30 S YSD4MIEN=0
31 F S YSD4MIEN=$O(^MR(+YSD4IEN,"PDX",YSD4MIEN)) QUIT:YSD4MIEN'>0 D
32 . I '$D(^MR(+YSD4IEN,"PDX",+YSD4MIEN,0)) D QUIT
33 . . D NOW^%DTC
34 . . D PED^YSD4E010(%,"Invalid data structure",90,"PDX",+YSD4IEN,+YSD4MIEN,+YSD4DIEN)
35 .
36 . S YSD4DIEN=+$G(^MR(+YSD4IEN,"PDX",+YSD4MIEN,0)) QUIT:YSD4DIEN'>0 D PDX
37 ;
38 ;
39 ; XDX node. (Field# 90.07PA:.01 - PAST X DIAGNOSIS)
40 S YSD4MIEN=0
41 F S YSD4MIEN=$O(^MR(+YSD4IEN,"XDX",YSD4MIEN)) QUIT:YSD4MIEN'>0 D
42 . I '$D(^MR(+YSD4IEN,"XDX",+YSD4MIEN,0)) D QUIT
43 . . D NOW^%DTC
44 . . D PED^YSD4E010(%,"Invalid data structure",90,"XDX",+YSD4IEN,+YSD4MIEN,+YSD4DIEN)
45 . S YSD4DIEN=+$G(^MR(+YSD4IEN,"XDX",+YSD4MIEN,0)) QUIT:YSD4DIEN'>0 D XDX
46 ;
47 ;
48 ; If YSD4FND>0 and YSD4CONV=0 NO DSM qualifiers match
49 ; Change status to ERROR
50 ; return control to (REPOINT^YSD40030)
51 ;
52 I YSD4FND>0&(YSD4CONV=0) D QUIT ;->
53 . S $P(^YSD(627.99,+YSD4CIEN,0),U,2)="E"
54 ;
55 ; Change Status to CONVERTED
56 S $P(^YSD(627.99,+YSD4CIEN,0),U,2)="C",YSD4CFLG=1
57 QUIT
58 ;
59DX ;
60 ; YSD4DIEN,YSD4IEN,YSD4MIEN -- req
61 ; YSD4NDN - New DSM file number
62 ;
63 S YSD4FND=YSD4FND+1
64 ;
65 ; Get DSM pointer for DSM3 entry
66 S YSD4NDN=$$NDN(+YSD4DIEN)
67 ;
68 ; Quit if not found...
69 I 'YSD4NDN D QUIT ;->
70 . D NOW^%DTC
71 . D PED^YSD4E010(%,"New DSM # not found",90,"DX",+YSD4IEN,+YSD4MIEN,+YSD4DIEN)
72 ;
73 ; Record value in Conversion file
74 S ^YSD(627.99,+YSD4CIEN,"DX",+YSD4MIEN,0)=+YSD4DIEN
75 ;
76 ; Convert now...
77 K ^MR(+YSD4IEN,"DX","B",YSD4DIEN,+YSD4MIEN)
78 S ^MR(+YSD4IEN,"DX","B",YSD4NDN,+YSD4MIEN)=""
79 S $P(^MR(+YSD4IEN,"DX",+YSD4MIEN,0),U)=+YSD4NDN
80 S YSD4CONV=YSD4CONV+1
81 QUIT
82 ;
83DX1 ;
84 ; YSD4DX1,YSD4IEN -- req
85 ;
86 N YSD4HDX1
87 S YSD4HDX1=YSD4DX1,(YSD4DX1F,YSD4DX1C)=0
88 ;
89 F YSD4P=2,4 S YSD4DIEN=$P(YSD4DX1,U,+YSD4P) I YSD4DIEN>0 D
90 . S YSD4FND=YSD4FND+1,YSD4DX1F=YSD4DX1F+1
91 . S YSD4NDN=$$NDN(+YSD4DIEN)
92 . I YSD4NDN'>0 D QUIT ;->
93 . . D NOW^%DTC
94 . . D PED^YSD4E010(%,"New DSM # not found on piece "_YSD4P_" of this node",90,"DX1",+YSD4IEN,"",+YSD4DIEN)
95 .
96 . S $P(YSD4DX1,U,+YSD4P)=YSD4NDN
97 . S YSD4CONV=YSD4CONV+1,YSD4DX1C=YSD4DX1C+1
98 ;
99 ; If DX1 node is found and no qualifier exist QUIT
100 ;
101 QUIT:YSD4DX1F>0&(YSD4DX1C=0) ;->
102 ;
103 ; Record Conversion file data...
104 ; 2nd & 4th pieces repointed... Now, store changes...
105 ;
106 S ^YSD(627.99,+YSD4CIEN,"DX1")=YSD4HDX1,^MR(+YSD4IEN,"DX1")=YSD4DX1
107 ;
108 QUIT
109 ;
110PDX ;
111 S YSD4FND=YSD4FND+1
112 ;
113 ; YSD4DIEN,YSD4IEN,YSD4MIEN -- req
114 ; YSD4NDN - New DSM file number
115 ;
116 S YSD4NDN=$$NDN(+YSD4DIEN)
117 ;
118 ; New DSM # found?
119 I 'YSD4NDN D QUIT ;->
120 . D NOW^%DTC
121 . D PED^YSD4E010(%,"New DSM # not found",90,"PDX",+YSD4IEN,+YSD4MIEN,+YSD4DIEN)
122 ;
123 ; Record value in Conversion file
124 ; Set ^MR node...
125 ;
126 S ^YSD(627.99,+YSD4CIEN,"PDX",+YSD4MIEN,0)=+YSD4DIEN,$P(^MR(+YSD4IEN,"PDX",+YSD4MIEN,0),U)=+YSD4NDN
127 ;
128 ; Note! No B xref exists on this field
129 ;
130 S YSD4CONV=YSD4CONV+1
131 QUIT
132 ;
133XDX ;
134 S YSD4FND=YSD4FND+1
135 ;
136 ; YSD4DIEN,YSD4IEN,YSD4MIEN -- req
137 ; YSD4NDN - New DSM file number
138 ;
139 S YSD4NDN=$$NDN(+YSD4DIEN)
140 ;
141 I 'YSD4NDN D QUIT ;->
142 . D NOW^%DTC
143 . D PED^YSD4E010(%,"New DSM # not found",90,"XDX",+YSD4IEN,+YSD4MIEN,+YSD4DIEN)
144 ;
145 ; Record value in Conversion file
146 ; Set ^MR node...
147 ;
148 S ^YSD(627.99,+YSD4CIEN,"XDX",+YSD4MIEN,0)=+YSD4DIEN,$P(^MR(+YSD4IEN,"XDX",+YSD4MIEN,0),U)=+YSD4NDN
149 ;
150 ; Note! No B xref exists on this field
151 ;
152 S YSD4CONV=YSD4CONV+1
153 QUIT
154 ;
155NDN(ONO) QUIT +$P($G(^DIC(627,+$G(ONO),0)),U,4)
156 ;
157EOR ;YSD40031 - Repoint MR data continued... ;12/9/93 10:03
Note: See TracBrowser for help on using the repository browser.