source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDWLRP4.m@ 765

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

initial load of FOIAVistA 6/30/08 version
File size: 7.3 KB
Line 
1SDWLRP4 ;IOFO BAY PINES/TEH - WAITING LIST - MERGE RPC;06/28/2002 ; 26 Aug 2002 1:25 PM
2 ;;5.3;scheduling;**263,485,497**;AUG 13 1993;Build 3
3 ;
4INPUT(SDWLRES,SDWLSTR) ;
5 ;
6 ;
7 ; Input:
8 ; SDWLSTR = location of data = ^TMP("SDWLG",$J,i,0)
9 ; (R) = Required Field
10 ; (O) = Optional
11 ;
12 ; .01 2 3 4 5 9 10 11 23 22
13 ; SSN (R)^ORIGINATING DATE^INSTITUTION^TYPE (R)^^TYPE MOD^ORGINATING USER (R)^PRIORITY^REQUEST BY^CURRENT STATUS^DESIRED DATE
14 ; 1 2 3 4 6/7/8/9 10 11 12 17 16
15 ;
16 ; Output:
17 ; SDWLRES = -1^MESSAGE Failed
18 ; SDWLRES = 1^IEN Saved to ^SDWL(409.3,IEN,0)
19 ;
20 ;
21 K ^TMP("SDWLIN",$J),^TMP("SDWLOUT",$J),^TMP("DIERR",$J),D
22 I '$G(SDWLSTR) S SDWLRES="-1^Data String Missing^Failed" Q
23 I $P(SDWLSTR,U)="" S SDWLRES="-1^No SSN^Failed" Q
24 I $P(SDWLSTR,U,3)="" S SDWLRES="-1^No Insitution^Failed" Q
25 I $P(SDWLSTR,U,4)="" S SDWLRES="-1^No Type^Failed" Q
26 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
27 I $P(SDWLSTR,U,11)'="",$$DCHK($P(SDWLSTR,U,11))<1 S SDWLRES="-1^Invalid Date^Failed" Q
28 S $P(SDWLSTR,U)=$TR($P(SDWLSTR,U),"-","")
29 D NEW
30 I $P(SDWLRES,U,1)<0 Q
31 D FDA I SDWLRES<0 D DEL Q
32 D SET I SDWLRES<0 D DEL Q
33 D CLEAN^DILF K ^TMP("SDWLIN",$J),^TMP("SDWLOUT",$J)
34 Q
35NEW ;Get IEN from ^SDWL(409.3,IEN,0).
36 N SDWLTP,SDWL6,SDWL6P,SDWL7,SDWL7P,SDWL8,SDWL8P,SDWL9,SDWL9P,SDWLMOD,SDWLTP,SDWLIN,SDWLDFN
37 N SDWLPRI,SDWLODUZ,SDWLRBY
38 S SDWLRES=""
39 I $P(SDWLSTR,U,4) D
40 .S SDWLTP=+$P(SDWLSTR,U,4),(SDWL6,SDWL7,SDWL8,SDWL9)="",SDWLMOD=0 D
41 ..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
42 ..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
43 ..I SDWLTP=3 S SDWL8=$P(SDWLSTR,U,8),SDWL80="" F S SDWL80=$O(^DIC(40.7,"B",SDWL8,SDWL80)) Q:SDWL80="" D
44 ...I $D(^SDWL(409.31,"B",SDWL80)) S SDWL8=$O(^SDWL(409.31,"B",SDWL80,0)),$P(SDWLSTR,U,8)=SDWL8,SDWLMOD=1
45 ..I SDWLTP=4 S SDWL9=$P(SDWLSTR,U,9),SDWL90="" F SDWL90=$O(^SC("B",SDWL9,SDWL90)) Q:SDWL90="" D
46 ...I $D(^SDWL(409.32,"B",SDWL90)) S SDWL9=$O(^SDWL(409.32,"B",SDWL90,0)),$P(SDWLSTR,U,9)=SDWL9,SDWLMOD=1
47 I 'SDWLMOD S SDWLRES="-1^No Type Mod found^Failed" Q
48 S SDWLIN=$P(SDWLSTR,U,3) I SDWLIN="" S SDWLRES="-1^No Institution^Failed" Q
49 S SDWLIN=$O(^DIC(4,"B",SDWLIN,0)) I SDWLIN="" S SDWLRES="-1^Invalid Institution^Failed" Q
50 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
51 S SDWLDFN=+Y
52 I SDWLDFN="" S SDWLRES="-1^Invalid SSN^Failed" Q
53 I $$DUP(SDWLDFN) S SDWLRES="-1^Duplicate^Failed" Q
54 S SDWLPRI=$S($P(SDWLSTR,U,11)="":"A",1:"F")
55 S SDWLODUZ=.5,SDWLRBY=2
56 I SDWLTP=1!(SDWLTP=2) S SDWLPRI="A",SDWLRBY=""
57 S SDWLSTRN=SDWLTP_"^"_SDWLPRI_"^"_SDWLODUZ_"^"_SDWLRBY_"^"_SDWL6_"^"_SDWL7_"^"_SDWL8_"^"_SDWL9
58 S DIC(0)="LX",X=SDWLDFN,DIC="^SDWL(409.3," D FILE^DICN I Y<0 S SDWLRES="-1^IEN failed^Failed" Q
59 S SDWLDFN=$P(Y,U,2),SDWLDA=+Y,SDWLDUZ=$P(SDWLSTR,U,9)
60 S DIE="^SDWL(409.3,",DA=SDWLDA
61 I SDWLPRI="F" D
62 .S DR="22///"_$P(SDWLSTR,U,11) D ^DIE
63 I SDWLPRI="A",SDWLTP=3!(SDWLTP=4) D
64 .S DR="22///^S X=DT" D ^DIE
65 S DR="1////^S X=DT" D ^DIE
66 S DR="2////^S X=SDWLIN" D ^DIE
67 S DR="23////^S X=""O""",DIE="^SDWL(409.3," D ^DIE K DIE,DR,DA
68 ;
69 ;SET DATE OF DEATH
70 ;
71 S X=$$GET1^DIQ(2,SDWLDFN_",",".351") I X'="" D
72 .S DA=SDWLDA
73 .S DR="19////^S X=DT",DIE="^SDWL(409.3," D ^DIE
74 .S DR="20////^S X=DUZ" D ^DIE
75 .S DR="23////^S X=""C""" D ^DIE
76 .S DR="21////^S X=""D""" D ^DIE K DIE,DR,DA
77 ;
78 ;DETERMINE ENROLLEE STATUS
79 ;
80 ;SDWLE=1 = NEW ENROLLEE
81 ;SDWLE=2 = ESTABLISHED
82 ;SDWLE=3 = PRIOR ENROLLEE
83 ;SDWLE=4 = UNDETERMINED
84 ;
85 S SDWLDE=+$H,SDWLE=0,(SDWLEE,SDWLRNED,SDWLDB)=0 D SB1
86 G SB0:SDWLE=2
87 S SDWLRNE=$$ENROLL^EASWTAPI(SDWLDFN) G SB0:$P(SDWLRNE,U,4)="A" S SDWLRNED=$P(SDWLRNE,U,3)
88 I SDWLRNED S X=SDWLRNED D H^%DTC S SDWLDS=%H S SDWLDE=+$H,SDWLDET=SDWLDE-SDWLDS I SDWLDET<366 S SDWLE=1
89 I $D(SDWLDET),SDWLDET>365 S SDWLE=3
90 I 'SDWLRNE S SDWLE=4
91SB0 I $D(SDWLRNE),$P(SDWLRNE,U,4)="A" D
92 .I 'SDWLEE.SDWLEE>730!(SDWLEE=730) S SDWLE=4 Q
93 .I 'SDWLEE S SDWLE=4 Q
94 S SDWLRNE=$S(SDWLE=1:"N",SDWLE=2:"E",SDWLE=3:"P",SDWLE=4:"U",1:"U")
95 ;-Code here for filling in 409.3
96 S DR="27////^S X=SDWLRNE",DIE="^SDWL(409.3,",DA=SDWLDA D ^DIE
97 S DR="27.1////^S X=$S($G(SDWLRNED):SDWLRNED,$G(SDWLD):SDWLD,1:"""")" D ^DIE
98 S DR="27.2////^S X=SDWLDB" D ^DIE
99 S DR="9////^S X=DUZ" D ^DIE K DIE,DA,DR,%H
100 K SDWLRNE,SDWLD,SDWLDE,SDWLEE,SDWLDET,DIC,DIR,DR,DIE,SDWLDS,SDWLE,SDWLRNED
101 Q
102SB1 I '$D(^DGCN(391.91,"B",SDWLDFN)) N SDWLDB S SDWLE=3 Q
103 S SDWLX="" F S SDWLX=$O(^DGCN(391.91,"B",SDWLDFN,SDWLX)) Q:SDWLX="" D
104 .S SDWLY=$G(^DGCN(391.91,SDWLX,0)) D
105 ..;CHECK FOR TREATING FACILITY
106 ..I $$TF^XUAF4(+$P(SDWLY,U,2)) D
107 ...;SORT FOR LAST TREATMENT DATE
108 ...S SDWLD=$P(SDWLY,U,3) I SDWLD S SDWLDTF(9999999-SDWLD)=SDWLX
109 I '$D(SDWLDTF) Q
110 S SDWLDTF=$O(SDWLDTF(0)) I SDWLDTF S (SDWLD,X)=9999999-SDWLDTF D H^%DTC S SDWLEE=SDWLDE-%H,SDWLDB=1 I SDWLEE<730 S SDWLE=2
111 I $D(SDWLEE),SDWLEE>730 S SDWLE=3
112 K SDWLDTF
113 Q
114FDA ;Get data from SDWLSTR string and set FDA.
115 S SDWLF=409.3
116 S SDWLVAL="" F SDWLI=1,2,3,4,5,6,7,8 S SDWLVAL=$P(SDWLSTRN,"^",SDWLI) D
117 .S SDWLFLD=SDWLI D
118 ..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)
119 .S SDWLFLG="F",SDWLIEN=$$IENS^DILF(SDWLDA) ;,SDWLVAL=$$EXTERNAL^DILFD(SDWLF,SDWLFLD,,SDWLVAL,"SDWLMSG")
120 .I $D(SDWLMSG) M SDWLRES=SDWLMSG S SDWLRES=-1 Q
121 .D FDA^DILF(SDWLF,SDWLIEN,SDWLFLD,"",SDWLVAL,"^TMP(""SDWLIN"",$J)")
122 .S SDWLRES=1 M SDWLRES("SDWLIN")=^TMP("SDWLIN",$J)
123 Q
124VAL ;Validate fields
125 ;
126 D VALS^DIE(,"^TMP(""SDWLIN"",$J)","^TMP(""SDWLOUT"",$J)","SDWLMSG")
127 I $G(SDWLMSG("DIERR")) S SDWLRES=-1 Q
128 M SDWLRES("SDWLOUT")=^TMP("SDWLOUT",$J)
129 Q
130 ;
131SET ;Input data to file ^SDWL(409.3,IEN,0)
132 D UPDATE^DIE(,"^TMP(""SDWLIN"",$J)","SDWLMSG")
133 I $G(SDWLMSG("DIERR")) S SDWLRES=-1 Q
134 K DIC,DA
135 S SDWLRES=1_"^"_$G(SDWLDA)
136 Q
137DEL S DA=SDWLDA,DIK="^SDWL(409.3," D ^DIK K DIK,DA
138 S SDWLRES="-1^Entry "_SDWLDA_" Deleted"
139 Q
140DUP(IEN) ;Duplicate Check
141 ;if institution, wait list type, and wait list modifier are the same it's a duplicate
142 ;SDWLV1 : IEN in 409.3
143 ;SDWLV2 : Zero node of 409.3
144 ;SDWLV3 : Wait List Type Modifier value passed in
145 ;SDWLV4 : Wait List Type Modifier value in current record
146 ;SDWLIN : Institution value passed in checked against piece 3 of current record
147 ;SDWLSTR : Incoming value string
148 ; Wait List Type piece 4 of SDWLSTR (incoming value) checked against piece 5
149 ; of SDWLV2 (zero node of current record
150 N SDWLV1,SDWLV2,SDWLV3,SDWLV4,SDWLV5
151 S (SDWLV1,SDWLV5)=0
152 F S SDWLV1=$O(^SDWL(409.3,"B",IEN,SDWLV1)) Q:('SDWLV1!SDWLV5) D
153 . S SDWLV2=$G(^SDWL(409.3,SDWLV1,0)) Q:SDWLV2=""
154 . 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)
155 . 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)
156 . I $P(SDWLV2,U,3)=SDWLIN,$P(SDWLSTR,U,4)=$P(SDWLV2,U,5),SDWLV3=SDWLV4 S SDWLV5=1 Q
157 Q SDWLV5
158DCHK(VALID) ;Check for valid DESIRED DATE
159 N X
160 S X=VALID,%DT="X" D ^%DT
161 Q Y
Note: See TracBrowser for help on using the repository browser.