source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLRP4.m@ 663

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

initial load of WorldVistAEHR
File size: 7.5 KB
RevLine 
[613]1SDWLRP4 ;IOFO BAY PINES/TEH - WAITING LIST - MERGE RPC;06/28/2002 ; 26 Aug 2002 1:25 PM
2 ;;5.3;scheduling;**263**;AUG 13 1993;Build 4
3 ;Modified from FOIA VISTA,
4 ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU
5 ;General Public License See attached copy of the License.
6 ;
7 ;This program is free software; you can redistribute it and/or modify
8 ;it under the terms of the GNU General Public License as published by
9 ;the Free Software Foundation; either version 2 of the License, or
10 ;(at your option) any later version.
11 ;
12 ;This program is distributed in the hope that it will be useful,
13 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;GNU General Public License for more details.
16 ;
17 ;You should have received a copy of the GNU General Public License along
18 ;with this program; if not, write to the Free Software Foundation, Inc.,
19 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
20 ;
21INPUT(SDWLRES,SDWLSTR) ;
22 ;
23 ;
24 ; Input:
25 ; SDWLSTR = location of data = ^TMP("SDWLG",$J,i,0)
26 ; (R) = Required Field
27 ; (O) = Optional
28 ;
29 ; .01 2 3 4 5 9 10 11 23 22
30 ; SSN (R)^ORIGINATING DATE^INSTITUTION^TYPE (R)^^TYPE MOD^ORGINATING USER (R)^PRIORITY^REQUEST BY^CURRENT STATUS^DESIRED DATE
31 ; 1 2 3 4 6/7/8/9 10 11 12 17 16
32 ;
33 ; Output:
34 ; SDWLRES = -1^MESSAGE Failed
35 ; SDWLRES = 1^IEN Saved to ^SDWL(409.3,IEN,0)
36 ;
37 ;
38 K ^TMP("SDWLIN",$J),^TMP("SDWLOUT",$J),^TMP("DIERR",$J),D
39 I '$G(SDWLSTR) S SDWLRES="-1^Data String Missing^Failed" Q
40 I $P(SDWLSTR,U)="" S SDWLRES="-1^No SSN^Failed" Q
41 I $P(SDWLSTR,U,3)="" S SDWLRES="-1^No Insitution^Failed" Q
42 I $P(SDWLSTR,U,4)="" S SDWLRES="-1^No Type^Failed" Q
43 I $P(SDWLSTR,U,6)="",$P(SDWLSTR,U,7)="",$P(SDWLSTR,U,8)="",$P(SDWLSTR,U,9)="" S SDWLRES="-1^No Type Modifier^Failed" Q
44 I $P(SDWLSTR,U,11)'="",$$DCHK($P(SDWLSTR,U,11))<1 S SDWLRES="-1^Invalid Date^Failed" Q
45 S $P(SDWLSTR,U)=$TR($P(SDWLSTR,U),"-","")
46 D NEW
47 I $P(SDWLRES,U,1)<0 Q
48 D FDA I SDWLRES<0 D DEL Q
49 D SET I SDWLRES<0 D DEL Q
50 D CLEAN^DILF K ^TMP("SDWLIN",$J),^TMP("SDWLOUT",$J)
51 Q
52NEW ;Get IEN from ^SDWL(409.3,IEN,0).
53 N SDWLTP,SDWL6,SDWL6P,SDWL7,SDWL7P,SDWL8,SDWL8P,SDWL9,SDWL9P,SDWLMOD,SDWLTP,SDWLIN,SDWLDFN
54 N SDWLPRI,SDWLODUZ,SDWLRBY
55 S SDWLRES=""
56 I $P(SDWLSTR,U,4) D
57 .S SDWLTP=+$P(SDWLSTR,U,4),(SDWL6,SDWL7,SDWL8,SDWL9)="",SDWLMOD=0 D
58 ..I SDWLTP=1 S SDWL6=$P(SDWLSTR,U,6),SDWL6=$O(^SCTM(404.51,"B",SDWL6,"")) I SDWL6'="" S SDWL6P=$O(^SCTM(404.51,"B",SDWL6,0)),SDWLMOD=1
59 ..I SDWLTP=2 S SDWL7=$P(SDWLSTR,U,7),SDWL7=$O(^SCTM(404.57,"B",SDWL7,"")) I SDWL7'="" S SDWL7P=$O(^SCTM(404.57,"B",SDWL7,0)),SDWLMOD=1
60 ..I SDWLTP=3 S SDWL8=$P(SDWLSTR,U,8),SDWL80="" F S SDWL80=$O(^DIC(40.7,"B",SDWL8,SDWL80)) Q:SDWL80="" D
61 ...I $D(^SDWL(409.31,"B",SDWL80)) S SDWL8=$O(^SDWL(409.31,"B",SDWL80,0)),$P(SDWLSTR,U,8)=SDWL8,SDWLMOD=1
62 ..I SDWLTP=4 S SDWL9=$P(SDWLSTR,U,9),SDWL90="" F SDWL90=$O(^SC("B",SDWL9,SDWL90)) Q:SDWL90="" D
63 ...I $D(^SDWL(409.32,"B",SDWL90)) S SDWL9=$O(^SDWL(409.32,"B",SDWL90,0)),$P(SDWLSTR,U,9)=SDWL9,SDWLMOD=1
64 I 'SDWLMOD S SDWLRES="-1^No Type Mod found^Failed" Q
65 S SDWLIN=$P(SDWLSTR,U,3) I SDWLIN="" S SDWLRES="-1^No Institution^Failed" Q
66 S SDWLIN=$O(^DIC(4,"B",SDWLIN,0)) I SDWLIN="" S SDWLRES="-1^Invalid Institution^Failed" Q
67 S SDWLDFN=$P(SDWLSTR,U,1) S D="SSN",DIC(0)="MNZ",X=SDWLDFN,D="SSN",DIC=2 D IX^DIC I Y<0 S SDWLRES="-1^SSN failed" Q
68 S SDWLDFN=+Y
69 I SDWLDFN="" S SDWLRES="-1^Invalid SSN^Failed" Q
70 I $$DUP(SDWLDFN) S SDWLRES="-1^Duplicate^Failed" Q
71 S SDWLPRI=$S($P(SDWLSTR,U,11)="":"A",1:"F")
72 S SDWLODUZ=.5,SDWLRBY=2
73 I SDWLTP=1!(SDWLTP=2) S SDWLPRI="A",SDWLRBY=""
74 S SDWLSTRN=SDWLTP_"^"_SDWLPRI_"^"_SDWLODUZ_"^"_SDWLRBY_"^"_SDWL6_"^"_SDWL7_"^"_SDWL8_"^"_SDWL9
75 S DIC(0)="LX",X=SDWLDFN,DIC="^SDWL(409.3," D FILE^DICN I Y<0 S SDWLRES="-1^IEN failed^Failed" Q
76 S SDWLDFN=$P(Y,U,2),SDWLDA=+Y,SDWLDUZ=$P(SDWLSTR,U,9)
77 S DIE="^SDWL(409.3,",DA=SDWLDA
78 I SDWLPRI="F" D
79 .S DR="22///"_$P(SDWLSTR,U,11) D ^DIE
80 I SDWLPRI="A",SDWLTP=3!(SDWLTP=4) D
81 .S DR="22///^S X=DT" D ^DIE
82 S DR="1////^S X=DT" D ^DIE
83 S DR="2////^S X=SDWLIN" D ^DIE
84 S DR="23////^S X=""O""",DIE="^SDWL(409.3," D ^DIE K DIE,DR,DA
85 ;
86 ;SET DATE OF DEATH
87 ;
88 S X=$$GET1^DIQ(2,SDWLDFN_",",".351") I X'="" D
89 .S DA=SDWLDA
90 .S DR="19////^S X=DT",DIE="^SDWL(409.3," D ^DIE
91 .S DR="20////^S X=DUZ" D ^DIE
92 .S DR="23////^S X=""C""" D ^DIE
93 .S DR="21////^S X=""D""" D ^DIE K DIE,DR,DA
94 ;
95 ;DETERMINE ENROLLEE STATUS
96 ;
97 ;SDWLE=1 = NEW ENROLLEE
98 ;SDWLE=2 = ESTABLISHED
99 ;SDWLE=3 = PRIOR ENROLLEE
100 ;SDWLE=4 = UNDETERMINED
101 ;
102 S SDWLDE=+$H,SDWLE=1,SDWLEE=0 D SB1
103 G SB0:SDWLE=2
104 S SDWLRNE=$$ENROLL^EASWTAPI(SDWLDFN) S SDWLRNED=$P(SDWLRNE,U,3)
105 I SDWLRNED S X=SDWLRNED D H^%DTC S SDWLDS=%H S SDWLDE=+$H,SDWLDET=SDWLDE-SDWLDS I SDWLDET<366 S SDWLE=1
106 I $D(SDWLDET),SDWLDET>365 S SDWLE=3
107 I 'SDWLRNE S SDWLE=4
108SB0 S SDWLRNE=$S(SDWLE=1:"N",SDWLE=2:"E",SDWLE=3:"P",SDWLE=4:"U")
109 ;-Code here for filling in 409.3
110 S DR="27////^S X=SDWLRNE",DIE="^SDWL(409.3,",DA=SDWLDA D ^DIE
111 S DR="9////^S X=DUZ" D ^DIE K DIE,DA,DR,%H
112 Q
113SB1 I '$D(^DGCN(391.91,"B",SDWLDFN)) S SDWLE=3 Q
114 S SDWLX="" F S SDWLX=$O(^DGCN(391.91,"B",SDWLDFN,SDWLX)) Q:SDWLX="" D
115 .S SDWLY=$G(^DGCN(391.91,SDWLX,0)),SDWLD=$P(^(0),U,3) I SDWLD S X=SDWLD D H^%DTC S SDWLEE=SDWLDE-%H I SDWLEE<730 S SDWLE=2
116 .I $D(SDWLEE),SDWLEE>730 S SDWLE=3
117 Q
118FDA ;Get data from SDWLSTR string and set FDA.
119 S SDWLF=409.3
120 S SDWLVAL="" F SDWLI=1,2,3,4,5,6,7,8 S SDWLVAL=$P(SDWLSTRN,"^",SDWLI) D
121 .S SDWLFLD=SDWLI D
122 ..S SDWLFLD=$S(SDWLFLD=1:4,SDWLFLD=2:10,SDWLFLD=3:9,SDWLFLD=4:11,SDWLFLD=5:5,SDWLFLD=6:6,SDWLFLD=7:7,SDWLFLD=8:8)
123 .S SDWLFLG="F",SDWLIEN=$$IENS^DILF(SDWLDA) ;,SDWLVAL=$$EXTERNAL^DILFD(SDWLF,SDWLFLD,,SDWLVAL,"SDWLMSG")
124 .I $D(SDWLMSG) M SDWLRES=SDWLMSG S SDWLRES=-1 Q
125 .D FDA^DILF(SDWLF,SDWLIEN,SDWLFLD,"",SDWLVAL,"^TMP(""SDWLIN"",$J)")
126 .S SDWLRES=1 M SDWLRES("SDWLIN")=^TMP("SDWLIN",$J)
127 Q
128VAL ;Validate fields
129 ;
130 D VALS^DIE(,"^TMP(""SDWLIN"",$J)","^TMP(""SDWLOUT"",$J)","SDWLMSG")
131 I $G(SDWLMSG("DIERR")) S SDWLRES=-1 Q
132 M SDWLRES("SDWLOUT")=^TMP("SDWLOUT",$J)
133 Q
134 ;
135SET ;Input data to file ^SDWL(409.3,IEN,0)
136 D UPDATE^DIE(,"^TMP(""SDWLIN"",$J)","SDWLMSG")
137 I $G(SDWLMSG("DIERR")) S SDWLRES=-1 Q
138 K DIC,DA
139 S SDWLRES=1_"^"_$G(SDWLDA)
140 Q
141DEL S DA=SDWLDA,DIK="^SDWL(409.3," D ^DIK K DIK,DA
142 S SDWLRES="-1^Entry "_SDWLDA_" Deleted"
143 Q
144DUP(IEN) ;Duplicate Check
145 ;if institution, wait list type, and wait list modifier are the same it's a duplicate
146 ;SDWLV1 : IEN in 409.3
147 ;SDWLV2 : Zero node of 409.3
148 ;SDWLV3 : Wait List Type Modifier value passed in
149 ;SDWLV4 : Wait List Type Modifier value in current record
150 ;SDWLIN : Institution value passed in checked against piece 3 of current record
151 ;SDWLSTR : Incoming value string
152 ; Wait List Type piece 4 of SDWLSTR (incoming value) checked against piece 5
153 ; of SDWLV2 (zero node of current record
154 N SDWLV1,SDWLV2,SDWLV3,SDWLV4,SDWLV5
155 S (SDWLV1,SDWLV5)=0
156 F S SDWLV1=$O(^SDWL(409.3,"B",IEN,SDWLV1)) Q:('SDWLV1!SDWLV5) D
157 . S SDWLV2=$G(^SDWL(409.3,SDWLV1,0)) Q:SDWLV2=""
158 . S SDWLV3=$S($P(SDWLSTR,U,4)=1:SDWL6,$P(SDWLSTR,U,4)=2:SDWL7,$P(SDWLSTR,U,4)=3:SDWL8,$P(SDWLSTR,U,4)=4:SDWL9,1:0)
159 . S SDWLV4=$S($P(SDWLV2,U,5)=1:$P(SDWLV2,U,6),$P(SDWLV2,U,5)=2:$P(SDWLV2,U,7),$P(SDWLV2,U,5)=3:$P(SDWLV2,U,8),$P(SDWLV2,U,5)=4:$P(SDWLV2,U,9),1:0)
160 . I $P(SDWLV2,U,3)=SDWLIN,$P(SDWLSTR,U,4)=$P(SDWLV2,U,5),SDWLV3=SDWLV4 S SDWLV5=1 Q
161 Q SDWLV5
162DCHK(VALID) ;Check for valid DESIRED DATE
163 N X
164 S X=VALID,%DT="X" D ^%DT
165 Q Y
Note: See TracBrowser for help on using the repository browser.