| 1 | SDWLE6 ;;IOFO BAY PINES/OG - WAITING LIST-ENTER/EDIT - INTER-FACILITY TRANSFER ; Compiled January 25, 2007 09:47:40
|
|---|
| 2 | ;;5.3;scheduling;**446**;AUG 13 1993;Build 77
|
|---|
| 3 | ;
|
|---|
| 4 | ; ******************************************************************
|
|---|
| 5 | ; CHANGE LOG
|
|---|
| 6 | ;
|
|---|
| 7 | ; DATE PATCH DESCRIPTION
|
|---|
| 8 | ; ---- ----- -----------
|
|---|
| 9 | ;
|
|---|
| 10 | ;
|
|---|
| 11 | EN(SDWLDFN,SDWLERR) ; Entry Point
|
|---|
| 12 | ; Extrinsic function. Quit back one of the following values
|
|---|
| 13 | ; 0 : Inter-Facility Transfer not selected, continue with standard processing
|
|---|
| 14 | ; 1 : Inter-Facility selected, all processing performed here, quit out on return.
|
|---|
| 15 | ;
|
|---|
| 16 | ; SDWLERR passed back by reference, indicates to the calling routine
|
|---|
| 17 | ; whether to announce that the update to 409.3 was performed.
|
|---|
| 18 | ;
|
|---|
| 19 | N ICN,SDWLIFTN,SDWLONSY,SDWLTY,SSN
|
|---|
| 20 | S SDWLIFTN=0,SDWLERR=1,SDWLONSY=0
|
|---|
| 21 | S ICN=$$GET1^DIQ(2,SDWLDFN,991.01),SSN=$$GET1^DIQ(2,SDWLDFN,.09)
|
|---|
| 22 | I ICN'="",$D(^SDWL(409.36,"AICN",ICN)) S SDWLONSY=1
|
|---|
| 23 | I SSN'="",$D(^SDWL(409.36,"SSN",SSN)) S SDWLONSY=1
|
|---|
| 24 | D:SDWLONSY
|
|---|
| 25 | .N DIR,SDWLARR,SDWLI,SDWLIFN0,SDWLILM,TMP
|
|---|
| 26 | .S SDWLIFN0="",SDWLILM=23
|
|---|
| 27 | .I ICN'="" F S SDWLIFN0=$O(^SDWL(409.36,"AICN",ICN,SDWLIFN0)) Q:SDWLIFN0="" S TMP(SDWLIFN0)=""
|
|---|
| 28 | .I SSN'="" F S SDWLIFN0=$O(^SDWL(409.36,"SSN",SSN,SDWLIFN0)) Q:SDWLIFN0="" S TMP(SDWLIFN0)=""
|
|---|
| 29 | .F S SDWLIFN0=$O(TMP(SDWLIFN0)) Q:SDWLIFN0="" D
|
|---|
| 30 | ..N SDWLIL,SDWLINS,SDWLINSX,SDWLINX,TMP
|
|---|
| 31 | ..D GETS^DIQ(409.36,SDWLIFN0_",",".1;1;4",,"TMP")
|
|---|
| 32 | ..Q:"P"'[$E(TMP(409.36,SDWLIFN0_",",1))
|
|---|
| 33 | ..S SDWLINS=TMP(409.36,SDWLIFN0_",",.1),SDWLINSX=$$GET1^DIQ(4,SDWLINS,.01)
|
|---|
| 34 | ..S SDWLIL=$L(SDWLINSX) S:SDWLIL>SDWLILM SDWLILM=SDWLIL
|
|---|
| 35 | ..S SDWLARR(0)=$G(SDWLARR(0))+1
|
|---|
| 36 | ..S SDWLARR(SDWLARR(0),0)=SDWLINSX_U_TMP(409.36,SDWLIFN0_",",4)_U_SDWLIFN0_U_$$GET1^DIQ(4,SDWLINS,4,"I")
|
|---|
| 37 | ..Q
|
|---|
| 38 | .Q:'$D(SDWLARR)
|
|---|
| 39 | .W !,"This patient has the following pending Inter-Facility Transfer entr"_$S(SDWLARR(0)=1:"y",1:"ies")_":"
|
|---|
| 40 | .W !?5,"Requesting Facility",?SDWLILM+5,"Wait List Type"
|
|---|
| 41 | .F SDWLI=1:1:SDWLARR(0) W !,SDWLI,?5,$P(SDWLARR(SDWLI,0),U),?SDWLILM+5,$P(SDWLARR(SDWLI,0),U,2)
|
|---|
| 42 | .S DIR("A")="Enter a number"
|
|---|
| 43 | .S DIR("A",1)="Select to associate this EWL entry with a transfer from the listed facility "
|
|---|
| 44 | .S DIR("A",2)="or ^ to continue without selecting."
|
|---|
| 45 | .S DIR(0)="N^1:"_SDWLARR(0) D ^DIR
|
|---|
| 46 | .Q:Y="^"
|
|---|
| 47 | .S SDWLIFTN=$P(SDWLARR(Y,0),U,3),SDWLTY=$P(SDWLARR(Y,0),U,2)
|
|---|
| 48 | .Q
|
|---|
| 49 | Q:'SDWLIFTN 0 ; Continue with normal EWL enter/edit.
|
|---|
| 50 | D EN2(SDWLIFTN,SDWLDFN,SDWLTY)
|
|---|
| 51 | Q 1 ; Return true: user chose to process transfer.
|
|---|
| 52 | ;
|
|---|
| 53 | EN2(SDWLIFTN,SDWLDFN,SDWLTY) ; Entry point if transfer record is selected elsewhere.
|
|---|
| 54 | N DFN,SDWLCM,SDWLCP1,SDWLCP2,SDWLCP3,SDWLCP4,SDWLCP5,SDWLCP6,SDWLDDA,SDWLIN,SDWLOPT,SDWLPCMM,SDWLPN,SDWLPOS,SDWLSCO,SDWLSPO,SDWLSSO,SDWLSTO,SDWLTEM,SDWLTM
|
|---|
| 55 | I $G(SDWLDFN)="" W !,"Patient not entered on the system. Use Load/edit" S DIR(0)="E" D ^DIR Q
|
|---|
| 56 | L +^SDWL(409.36,SDWLIFTN):1
|
|---|
| 57 | I '$T W !,"Unable to acquire lock on transfer file" S DIR(0)="E" D ^DIR Q
|
|---|
| 58 | S DFN=SDWLDFN D PCM^SDWLE1
|
|---|
| 59 | ; Call each "P" subroutine for Wait List data items. Controlled by the value of SDWLOPT.
|
|---|
| 60 | S SDWLOPT=1,(SDWLIN,SDWLTM,SDWLPN,SDWLDDA,SDWLCM)=""
|
|---|
| 61 | F D @("P"_SDWLOPT) Q:'SDWLOPT
|
|---|
| 62 | L -^SDWL(409.36,SDWLIFTN)
|
|---|
| 63 | Q
|
|---|
| 64 | ;
|
|---|
| 65 | P1 ; Wait List Type
|
|---|
| 66 | N DIR
|
|---|
| 67 | S DIR(0)="SO^1:PCMM TEAM ASSIGNMENT;2:PCMM POSITION ASSIGNMENT"
|
|---|
| 68 | S DIR("L",1)=" Select Wait List Type:"
|
|---|
| 69 | S DIR("L",2)=" 1. "_$P($P(DIR(0),U,2),":",2)
|
|---|
| 70 | S DIR("L",3)=" 2. "_$P($P(DIR(0),U,3),":",2)
|
|---|
| 71 | I SDWLTY'="" S DIR("B")=SDWLTY
|
|---|
| 72 | D ^DIR
|
|---|
| 73 | I "^"[Y S SDWLOPT=0 Q
|
|---|
| 74 | S SDWLTY=Y,SDWLOPT=SDWLOPT+1
|
|---|
| 75 | Q
|
|---|
| 76 | ;
|
|---|
| 77 | P2 ; Institution
|
|---|
| 78 | N DIC,SDWLINL,SDWLTM
|
|---|
| 79 | I SDWLTY=1 S DIC("S")="I $D(^SCTM(404.51,""AINST"",+Y))"
|
|---|
| 80 | I SDWLTY=2 D
|
|---|
| 81 | .N SDWLI
|
|---|
| 82 | .I 'SDWLCP3 S SDWLI=0 F S SDWLI=$O(^SCTM(404.57,SDWLI)) Q:'SDWLI D
|
|---|
| 83 | ..N SDWLL
|
|---|
| 84 | ..S SDWLL=+$P($G(^SCTM(404.57,SDWLI,0)),U,2)
|
|---|
| 85 | ..S SDWLINL=+$P($G(^SCTM(404.51,+SDWLL,0)),U,7)
|
|---|
| 86 | ..S SDWLINL(SDWLINL)=""
|
|---|
| 87 | ..Q
|
|---|
| 88 | .S DIC("S")="I $D(SDWLINL(+Y))"
|
|---|
| 89 | .Q
|
|---|
| 90 | S DIC("S")=DIC("S")_",$$GET1^DIQ(4,+Y_"","",11,""I"")=""N"",$$TF^XUAF4(+Y)"
|
|---|
| 91 | I SDWLIN'="" S DIC("B")=$$EXTERNAL^DILFD(4,.01,,SDWLIN)
|
|---|
| 92 | S DIC(0)="AEQNM",DIC="4",DIC("A")="Select Institution: "
|
|---|
| 93 | D ^DIC
|
|---|
| 94 | I Y="^" S SDWLOPT=0 Q
|
|---|
| 95 | I Y<1 S SDWLOPT=SDWLOPT-1 Q
|
|---|
| 96 | I SDWLTY=1 D GETTEAMS(+Y,.SDWLTM) I '$D(SDWLTM) W !,"No TEAMS are available for this INSTITUTION." Q
|
|---|
| 97 | S SDWLIN=+Y,SDWLOPT=SDWLOPT+1
|
|---|
| 98 | Q
|
|---|
| 99 | ;
|
|---|
| 100 | P3 ; Team or Team Position
|
|---|
| 101 | N DIR,SDWLPNS
|
|---|
| 102 | I $G(SDWLCP3)'="" D I Y["^"!'Y S SDWLOPT=0 Q
|
|---|
| 103 | .N DIR
|
|---|
| 104 | .W !,"This patient is already on the ",SDWLCP3,"."
|
|---|
| 105 | .S DIR(0)="Y^A0",DIR("B")="NO",DIR("A")="Are you sure you want to continue"
|
|---|
| 106 | .D ^DIR
|
|---|
| 107 | .Q
|
|---|
| 108 | I SDWLTY=1 D Q
|
|---|
| 109 | .N DIR
|
|---|
| 110 | .I $G(SDWLTM)'="" S DIR("B")=$$EXTERNAL^DILFD(404.58,.01,,SDWLTM) ; Not sure this is ever true.
|
|---|
| 111 | .D GETTEAMS(SDWLIN,.SDWLTM)
|
|---|
| 112 | .S DIR(0)="PAO^SCTM(404.51,:EMNZ",DIR("A")="Select Team: "
|
|---|
| 113 | .S DIR("S")="I $D(SDWLTM(+Y))"
|
|---|
| 114 | .D ^DIR
|
|---|
| 115 | .I Y="^" S SDWLOPT=0 Q
|
|---|
| 116 | .I Y<1 S SDWLOPT=2 Q
|
|---|
| 117 | .S SDWLTM=+Y,SDWLOPT=SDWLOPT+1
|
|---|
| 118 | .Q
|
|---|
| 119 | I $G(SDWLPN)'="" S DIR("B")=$$EXTERNAL^DILFD(404.57,.01,,SDWLPN) ; Not sure this is ever true.
|
|---|
| 120 | D GETPSNS(.SDWLPNS) I '$D(SDWLPNS) W !,"No Positions Meet Wait List Criteria" S SDWLOPT=1 Q
|
|---|
| 121 | S DIR(0)="PAO^SCTM(404.57,:EMNZ",DIR("A")="Select Team Position: "
|
|---|
| 122 | S DIR("S")="I $D(SDWLPNS(+Y))"
|
|---|
| 123 | D ^DIR
|
|---|
| 124 | I Y="^" S SDWLOPT=0 Q
|
|---|
| 125 | I Y<1 S SDWLOPT=SDWLOPT-1 Q
|
|---|
| 126 | S SDWLPN=+Y,SDWLOPT=SDWLOPT+1
|
|---|
| 127 | Q
|
|---|
| 128 | ;
|
|---|
| 129 | P4 ; Comment
|
|---|
| 130 | N DIR
|
|---|
| 131 | S DIR(0)="FAOU^^",DIR("A")="Comments: ",DIR("B")=SDWLCM
|
|---|
| 132 | D ^DIR
|
|---|
| 133 | I Y="^" S SDWLOPT=0 Q
|
|---|
| 134 | I X="@" S SDWLOPT=SDWLOPT-1 Q
|
|---|
| 135 | S SDWLCM=$E(Y,1,60),SDWLOPT=SDWLOPT+1
|
|---|
| 136 | Q
|
|---|
| 137 | ;
|
|---|
| 138 | P5 ; Update database
|
|---|
| 139 | N DA,DIC,DIE,X,DR,SDWLDA,SDWLSCPE,SDWLSCPR,SDWLTMP
|
|---|
| 140 | ; Create new EWL entry
|
|---|
| 141 | S DIC(0)="LX",X=SDWLDFN,DIC="^SDWL(409.3," D FILE^DICN
|
|---|
| 142 | L +^SDWL(409.3,DA):1 ; This file has just been created. Is it neurotic to code for the possibility of a lock from elsewhere?
|
|---|
| 143 | I '$T W !,"Unable to acquire a lock on the Wait List file" S SDWLOPT=5 Q
|
|---|
| 144 | ; Update EWL variables.
|
|---|
| 145 | D GETS^DIQ(409.36,SDWLIFTN_",",".301;.302","I","SDWLTMP")
|
|---|
| 146 | S SDWLSCPR=$G(SDWLTMP(409.36,SDWLIFTN_",",.301,"I"))="Y"
|
|---|
| 147 | S SDWLSCPE=$G(SDWLTMP(409.36,SDWLIFTN_",",.302,"I"))
|
|---|
| 148 | S SDWLDA=DA,DIE=DIC,DR="1////^S X=DT;2////^S X=SDWLIN;4////^S X=SDWLTY"
|
|---|
| 149 | I SDWLTY=1 S DR=DR_";5////^S X=SDWLTM"
|
|---|
| 150 | I SDWLTY=2 S DR=DR_";6////^S X=SDWLPN"
|
|---|
| 151 | S DR=DR_";9////^S X=DUZ"
|
|---|
| 152 | S DR=DR_";14////^S X=SDWLSCPE"
|
|---|
| 153 | S DR=DR_";15////^S X=SDWLSCPR"
|
|---|
| 154 | S DR=DR_";22////^S X=SDWLDDA"
|
|---|
| 155 | S DR=DR_";23////O"
|
|---|
| 156 | S DR=DR_";25////^S X=SDWLCM"
|
|---|
| 157 | S DR=DR_";27////^S X="""_$$GETENRST^SDWLE6(SDWLDFN)_""""
|
|---|
| 158 | D ^DIE
|
|---|
| 159 | L -^SDWL(409.3,DA)
|
|---|
| 160 | ; Update 409.36
|
|---|
| 161 | S DIE="^SDWL(409.36,",DA=SDWLIFTN,DR="1////E;409.3////^S X=SDWLDA" D ^DIE
|
|---|
| 162 | ; Pass message back to sending facility
|
|---|
| 163 | D SENDST^SDWLIFT6(SDWLIFTN)
|
|---|
| 164 | S SDWLOPT=0,SDWLERR=0
|
|---|
| 165 | Q
|
|---|
| 166 | ;
|
|---|
| 167 | GETTEAMS(SDWLIN,SDWLTM) ; Get teams for an institution ; NB this is reworking of code in SDWLE3.
|
|---|
| 168 | N Y,SDWLST,SDWLINE,SDWLPLST,TMHSID K SDWLTM
|
|---|
| 169 | S SDWLINE=SDWLIN
|
|---|
| 170 | D GETLIST^SDWLE3
|
|---|
| 171 | S TMHSID="" ; Team history
|
|---|
| 172 | F S TMHSID=$O(^SCTM(404.58,"B",TMHSID)) Q:TMHSID="" D:$P($G(^SCTM(404.51,TMHSID,0)),U,7)=SDWLIN
|
|---|
| 173 | .N TMID ; Team
|
|---|
| 174 | .S TMID=$O(^SCTM(404.58,"B",TMHSID,":"),-1) Q:TMID=""
|
|---|
| 175 | .Q:$D(SDWLPLST(1,TMID,SDWLIN))
|
|---|
| 176 | .Q:$P($G(^SCTM(404.58,TMID,0)),U,3)=0
|
|---|
| 177 | .Q:'$$ACTTM^SCMCTMU(TMID)
|
|---|
| 178 | .I $$TEAMCNT^SCAPMCU1(TMHSID,DT)>$P($G(^SCTM(404.51,TMHSID,0)),U,8) S SDWLTM(TMHSID)=""
|
|---|
| 179 | .Q
|
|---|
| 180 | Q
|
|---|
| 181 | ;
|
|---|
| 182 | GETPSNS(SDWLPN) ; Get positions ; NB this is reworking of code in SDWLE5.
|
|---|
| 183 | N SDWLPSS,SDWLPDA,SDWLX,SDWLA,SDWLCPP,SDWLCPT K SDWLPN
|
|---|
| 184 | D GETLIST^SDWLE5
|
|---|
| 185 | Q:'$D(SDWLCPP)
|
|---|
| 186 | S SDWLA=0
|
|---|
| 187 | F S SDWLA=$O(^SCTM(404.57,SDWLA)) Q:'SDWLA D:$D(SDWLCPP(SDWLA))&'$D(SDWLPSS(SDWLA))
|
|---|
| 188 | .N X
|
|---|
| 189 | .S X=$G(^SCTM(404.57,SDWLA,0))
|
|---|
| 190 | .Q:$P(X,U,2)'=SDWLCPT
|
|---|
| 191 | .S:$P(X,U,8)'<$$PCPOSCNT^SCAPMCU1(SDWLA,DT,0)&$P(X,U,4) SDWLPN(SDWLA)=""
|
|---|
| 192 | .Q
|
|---|
| 193 | Q
|
|---|
| 194 | ;
|
|---|
| 195 | GETENRST(SDWLDFN) ; Determine enrollee status ; NB this is reworking of code in SDWLE11.
|
|---|
| 196 | N SDWLE
|
|---|
| 197 | S SDWLE=1 D
|
|---|
| 198 | .N SDWLX,SDWLY,%H
|
|---|
| 199 | .I '$D(^DGCN(391.91,"B",SDWLDFN)) S SDWLE=3 Q
|
|---|
| 200 | .; Loop backwards through the B cross reference of TREATING FACILITY LIST until there is a DATE LAST TREATED entry.
|
|---|
| 201 | .; If that is less than 730 days ago, SDWLE=2; otherwise, SDWLE=3. Then quit from the loop.
|
|---|
| 202 | .S SDWLX=""
|
|---|
| 203 | .F S SDWLX=$O(^DGCN(391.91,"B",SDWLDFN,SDWLX),-1) Q:SDWLX="" S SDWLY=$G(^DGCN(391.91,SDWLX,0)) I $P(SDWLY,U,3) S X=$P(SDWLY,U,3) D H^%DTC S SDWLE=$H-%H'<730+2 Q
|
|---|
| 204 | .Q
|
|---|
| 205 | D:SDWLE'=2
|
|---|
| 206 | .N SDWLRNE,%H
|
|---|
| 207 | .S SDWLRNE=$$ENROLL^EASWTAPI(SDWLDFN)
|
|---|
| 208 | .I $P(SDWLRNE,U,3) S X=$P(SDWLRNE,U,3) D H^%DTC S SDWLE=$H-%H>365*2+1 ; If number of days is greater than a year, SDWLE=3; otherwise, SDWLE=1.
|
|---|
| 209 | .I 'SDWLRNE S SDWLE=4
|
|---|
| 210 | .Q
|
|---|
| 211 | Q $S(SDWLE=1:"N",SDWLE=2:"E",SDWLE=3:"P",SDWLE=4:"U")
|
|---|
| 212 | ;
|
|---|
| 213 | DIS(SDWLDA) ; Action on disposition
|
|---|
| 214 | N DIE,DR,SDWLDIS,SDWLIFTN,SDWLSTA,X
|
|---|
| 215 | S SDWLIFTN=$O(^SDWL(409.36,"C",SDWLDA,"")) Q:'SDWLIFTN
|
|---|
| 216 | S SDWLDIS=$$GET1^DIQ(409.3,SDWLDA,21,"I")
|
|---|
| 217 | ; If disposition is because entered in error, reset to pending. Otherwise, set to closed.
|
|---|
| 218 | S SDWLSTA=$S(SDWLDIS="ER":"P",1:"C")
|
|---|
| 219 | S DIE="^SDWL(409.36,",DA=SDWLIFTN,DR="1///"_SDWLSTA D ^DIE
|
|---|
| 220 | ; Pass message back to sending facility
|
|---|
| 221 | D SENDST^SDWLIFT6(SDWLIFTN)
|
|---|
| 222 | Q
|
|---|
