SDWLE6 ;;IOFO BAY PINES/OG - WAITING LIST-ENTER/EDIT - INTER-FACILITY TRANSFER ; Compiled January 25, 2007 09:47:40
;;5.3;scheduling;**446**;AUG 13 1993;Build 77
;
; ******************************************************************
; CHANGE LOG
;
; DATE PATCH DESCRIPTION
; ---- ----- -----------
;
;
EN(SDWLDFN,SDWLERR) ; Entry Point
; Extrinsic function. Quit back one of the following values
; 0 : Inter-Facility Transfer not selected, continue with standard processing
; 1 : Inter-Facility selected, all processing performed here, quit out on return.
;
; SDWLERR passed back by reference, indicates to the calling routine
; whether to announce that the update to 409.3 was performed.
;
N ICN,SDWLIFTN,SDWLONSY,SDWLTY,SSN
S SDWLIFTN=0,SDWLERR=1,SDWLONSY=0
S ICN=$$GET1^DIQ(2,SDWLDFN,991.01),SSN=$$GET1^DIQ(2,SDWLDFN,.09)
I ICN'="",$D(^SDWL(409.36,"AICN",ICN)) S SDWLONSY=1
I SSN'="",$D(^SDWL(409.36,"SSN",SSN)) S SDWLONSY=1
D:SDWLONSY
.N DIR,SDWLARR,SDWLI,SDWLIFN0,SDWLILM,TMP
.S SDWLIFN0="",SDWLILM=23
.I ICN'="" F S SDWLIFN0=$O(^SDWL(409.36,"AICN",ICN,SDWLIFN0)) Q:SDWLIFN0="" S TMP(SDWLIFN0)=""
.I SSN'="" F S SDWLIFN0=$O(^SDWL(409.36,"SSN",SSN,SDWLIFN0)) Q:SDWLIFN0="" S TMP(SDWLIFN0)=""
.F S SDWLIFN0=$O(TMP(SDWLIFN0)) Q:SDWLIFN0="" D
..N SDWLIL,SDWLINS,SDWLINSX,SDWLINX,TMP
..D GETS^DIQ(409.36,SDWLIFN0_",",".1;1;4",,"TMP")
..Q:"P"'[$E(TMP(409.36,SDWLIFN0_",",1))
..S SDWLINS=TMP(409.36,SDWLIFN0_",",.1),SDWLINSX=$$GET1^DIQ(4,SDWLINS,.01)
..S SDWLIL=$L(SDWLINSX) S:SDWLIL>SDWLILM SDWLILM=SDWLIL
..S SDWLARR(0)=$G(SDWLARR(0))+1
..S SDWLARR(SDWLARR(0),0)=SDWLINSX_U_TMP(409.36,SDWLIFN0_",",4)_U_SDWLIFN0_U_$$GET1^DIQ(4,SDWLINS,4,"I")
..Q
.Q:'$D(SDWLARR)
.W !,"This patient has the following pending Inter-Facility Transfer entr"_$S(SDWLARR(0)=1:"y",1:"ies")_":"
.W !?5,"Requesting Facility",?SDWLILM+5,"Wait List Type"
.F SDWLI=1:1:SDWLARR(0) W !,SDWLI,?5,$P(SDWLARR(SDWLI,0),U),?SDWLILM+5,$P(SDWLARR(SDWLI,0),U,2)
.S DIR("A")="Enter a number"
.S DIR("A",1)="Select to associate this EWL entry with a transfer from the listed facility "
.S DIR("A",2)="or ^ to continue without selecting."
.S DIR(0)="N^1:"_SDWLARR(0) D ^DIR
.Q:Y="^"
.S SDWLIFTN=$P(SDWLARR(Y,0),U,3),SDWLTY=$P(SDWLARR(Y,0),U,2)
.Q
Q:'SDWLIFTN 0 ; Continue with normal EWL enter/edit.
D EN2(SDWLIFTN,SDWLDFN,SDWLTY)
Q 1 ; Return true: user chose to process transfer.
;
EN2(SDWLIFTN,SDWLDFN,SDWLTY) ; Entry point if transfer record is selected elsewhere.
N DFN,SDWLCM,SDWLCP1,SDWLCP2,SDWLCP3,SDWLCP4,SDWLCP5,SDWLCP6,SDWLDDA,SDWLIN,SDWLOPT,SDWLPCMM,SDWLPN,SDWLPOS,SDWLSCO,SDWLSPO,SDWLSSO,SDWLSTO,SDWLTEM,SDWLTM
I $G(SDWLDFN)="" W !,"Patient not entered on the system. Use Load/edit" S DIR(0)="E" D ^DIR Q
L +^SDWL(409.36,SDWLIFTN):1
I '$T W !,"Unable to acquire lock on transfer file" S DIR(0)="E" D ^DIR Q
S DFN=SDWLDFN D PCM^SDWLE1
; Call each "P" subroutine for Wait List data items. Controlled by the value of SDWLOPT.
S SDWLOPT=1,(SDWLIN,SDWLTM,SDWLPN,SDWLDDA,SDWLCM)=""
F D @("P"_SDWLOPT) Q:'SDWLOPT
L -^SDWL(409.36,SDWLIFTN)
Q
;
P1 ; Wait List Type
N DIR
S DIR(0)="SO^1:PCMM TEAM ASSIGNMENT;2:PCMM POSITION ASSIGNMENT"
S DIR("L",1)=" Select Wait List Type:"
S DIR("L",2)=" 1. "_$P($P(DIR(0),U,2),":",2)
S DIR("L",3)=" 2. "_$P($P(DIR(0),U,3),":",2)
I SDWLTY'="" S DIR("B")=SDWLTY
D ^DIR
I "^"[Y S SDWLOPT=0 Q
S SDWLTY=Y,SDWLOPT=SDWLOPT+1
Q
;
P2 ; Institution
N DIC,SDWLINL,SDWLTM
I SDWLTY=1 S DIC("S")="I $D(^SCTM(404.51,""AINST"",+Y))"
I SDWLTY=2 D
.N SDWLI
.I 'SDWLCP3 S SDWLI=0 F S SDWLI=$O(^SCTM(404.57,SDWLI)) Q:'SDWLI D
..N SDWLL
..S SDWLL=+$P($G(^SCTM(404.57,SDWLI,0)),U,2)
..S SDWLINL=+$P($G(^SCTM(404.51,+SDWLL,0)),U,7)
..S SDWLINL(SDWLINL)=""
..Q
.S DIC("S")="I $D(SDWLINL(+Y))"
.Q
S DIC("S")=DIC("S")_",$$GET1^DIQ(4,+Y_"","",11,""I"")=""N"",$$TF^XUAF4(+Y)"
I SDWLIN'="" S DIC("B")=$$EXTERNAL^DILFD(4,.01,,SDWLIN)
S DIC(0)="AEQNM",DIC="4",DIC("A")="Select Institution: "
D ^DIC
I Y="^" S SDWLOPT=0 Q
I Y<1 S SDWLOPT=SDWLOPT-1 Q
I SDWLTY=1 D GETTEAMS(+Y,.SDWLTM) I '$D(SDWLTM) W !,"No TEAMS are available for this INSTITUTION." Q
S SDWLIN=+Y,SDWLOPT=SDWLOPT+1
Q
;
P3 ; Team or Team Position
N DIR,SDWLPNS
I $G(SDWLCP3)'="" D I Y["^"!'Y S SDWLOPT=0 Q
.N DIR
.W !,"This patient is already on the ",SDWLCP3,"."
.S DIR(0)="Y^A0",DIR("B")="NO",DIR("A")="Are you sure you want to continue"
.D ^DIR
.Q
I SDWLTY=1 D Q
.N DIR
.I $G(SDWLTM)'="" S DIR("B")=$$EXTERNAL^DILFD(404.58,.01,,SDWLTM) ; Not sure this is ever true.
.D GETTEAMS(SDWLIN,.SDWLTM)
.S DIR(0)="PAO^SCTM(404.51,:EMNZ",DIR("A")="Select Team: "
.S DIR("S")="I $D(SDWLTM(+Y))"
.D ^DIR
.I Y="^" S SDWLOPT=0 Q
.I Y<1 S SDWLOPT=2 Q
.S SDWLTM=+Y,SDWLOPT=SDWLOPT+1
.Q
I $G(SDWLPN)'="" S DIR("B")=$$EXTERNAL^DILFD(404.57,.01,,SDWLPN) ; Not sure this is ever true.
D GETPSNS(.SDWLPNS) I '$D(SDWLPNS) W !,"No Positions Meet Wait List Criteria" S SDWLOPT=1 Q
S DIR(0)="PAO^SCTM(404.57,:EMNZ",DIR("A")="Select Team Position: "
S DIR("S")="I $D(SDWLPNS(+Y))"
D ^DIR
I Y="^" S SDWLOPT=0 Q
I Y<1 S SDWLOPT=SDWLOPT-1 Q
S SDWLPN=+Y,SDWLOPT=SDWLOPT+1
Q
;
P4 ; Comment
N DIR
S DIR(0)="FAOU^^",DIR("A")="Comments: ",DIR("B")=SDWLCM
D ^DIR
I Y="^" S SDWLOPT=0 Q
I X="@" S SDWLOPT=SDWLOPT-1 Q
S SDWLCM=$E(Y,1,60),SDWLOPT=SDWLOPT+1
Q
;
P5 ; Update database
N DA,DIC,DIE,X,DR,SDWLDA,SDWLSCPE,SDWLSCPR,SDWLTMP
; Create new EWL entry
S DIC(0)="LX",X=SDWLDFN,DIC="^SDWL(409.3," D FILE^DICN
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?
I '$T W !,"Unable to acquire a lock on the Wait List file" S SDWLOPT=5 Q
; Update EWL variables.
D GETS^DIQ(409.36,SDWLIFTN_",",".301;.302","I","SDWLTMP")
S SDWLSCPR=$G(SDWLTMP(409.36,SDWLIFTN_",",.301,"I"))="Y"
S SDWLSCPE=$G(SDWLTMP(409.36,SDWLIFTN_",",.302,"I"))
S SDWLDA=DA,DIE=DIC,DR="1////^S X=DT;2////^S X=SDWLIN;4////^S X=SDWLTY"
I SDWLTY=1 S DR=DR_";5////^S X=SDWLTM"
I SDWLTY=2 S DR=DR_";6////^S X=SDWLPN"
S DR=DR_";9////^S X=DUZ"
S DR=DR_";14////^S X=SDWLSCPE"
S DR=DR_";15////^S X=SDWLSCPR"
S DR=DR_";22////^S X=SDWLDDA"
S DR=DR_";23////O"
S DR=DR_";25////^S X=SDWLCM"
S DR=DR_";27////^S X="""_$$GETENRST^SDWLE6(SDWLDFN)_""""
D ^DIE
L -^SDWL(409.3,DA)
; Update 409.36
S DIE="^SDWL(409.36,",DA=SDWLIFTN,DR="1////E;409.3////^S X=SDWLDA" D ^DIE
; Pass message back to sending facility
D SENDST^SDWLIFT6(SDWLIFTN)
S SDWLOPT=0,SDWLERR=0
Q
;
GETTEAMS(SDWLIN,SDWLTM) ; Get teams for an institution ; NB this is reworking of code in SDWLE3.
N Y,SDWLST,SDWLINE,SDWLPLST,TMHSID K SDWLTM
S SDWLINE=SDWLIN
D GETLIST^SDWLE3
S TMHSID="" ; Team history
F S TMHSID=$O(^SCTM(404.58,"B",TMHSID)) Q:TMHSID="" D:$P($G(^SCTM(404.51,TMHSID,0)),U,7)=SDWLIN
.N TMID ; Team
.S TMID=$O(^SCTM(404.58,"B",TMHSID,":"),-1) Q:TMID=""
.Q:$D(SDWLPLST(1,TMID,SDWLIN))
.Q:$P($G(^SCTM(404.58,TMID,0)),U,3)=0
.Q:'$$ACTTM^SCMCTMU(TMID)
.I $$TEAMCNT^SCAPMCU1(TMHSID,DT)>$P($G(^SCTM(404.51,TMHSID,0)),U,8) S SDWLTM(TMHSID)=""
.Q
Q
;
GETPSNS(SDWLPN) ; Get positions ; NB this is reworking of code in SDWLE5.
N SDWLPSS,SDWLPDA,SDWLX,SDWLA,SDWLCPP,SDWLCPT K SDWLPN
D GETLIST^SDWLE5
Q:'$D(SDWLCPP)
S SDWLA=0
F S SDWLA=$O(^SCTM(404.57,SDWLA)) Q:'SDWLA D:$D(SDWLCPP(SDWLA))&'$D(SDWLPSS(SDWLA))
.N X
.S X=$G(^SCTM(404.57,SDWLA,0))
.Q:$P(X,U,2)'=SDWLCPT
.S:$P(X,U,8)'<$$PCPOSCNT^SCAPMCU1(SDWLA,DT,0)&$P(X,U,4) SDWLPN(SDWLA)=""
.Q
Q
;
GETENRST(SDWLDFN) ; Determine enrollee status ; NB this is reworking of code in SDWLE11.
N SDWLE
S SDWLE=1 D
.N SDWLX,SDWLY,%H
.I '$D(^DGCN(391.91,"B",SDWLDFN)) S SDWLE=3 Q
.; Loop backwards through the B cross reference of TREATING FACILITY LIST until there is a DATE LAST TREATED entry.
.; If that is less than 730 days ago, SDWLE=2; otherwise, SDWLE=3. Then quit from the loop.
.S SDWLX=""
.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
.Q
D:SDWLE'=2
.N SDWLRNE,%H
.S SDWLRNE=$$ENROLL^EASWTAPI(SDWLDFN)
.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.
.I 'SDWLRNE S SDWLE=4
.Q
Q $S(SDWLE=1:"N",SDWLE=2:"E",SDWLE=3:"P",SDWLE=4:"U")
;
DIS(SDWLDA) ; Action on disposition
N DIE,DR,SDWLDIS,SDWLIFTN,SDWLSTA,X
S SDWLIFTN=$O(^SDWL(409.36,"C",SDWLDA,"")) Q:'SDWLIFTN
S SDWLDIS=$$GET1^DIQ(409.3,SDWLDA,21,"I")
; If disposition is because entered in error, reset to pending. Otherwise, set to closed.
S SDWLSTA=$S(SDWLDIS="ER":"P",1:"C")
S DIE="^SDWL(409.36,",DA=SDWLIFTN,DR="1///"_SDWLSTA D ^DIE
; Pass message back to sending facility
D SENDST^SDWLIFT6(SDWLIFTN)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLE6 9013 printed Dec 13, 2024@03:02:34 Page 2
SDWLE6 ;;IOFO BAY PINES/OG - WAITING LIST-ENTER/EDIT - INTER-FACILITY TRANSFER ; Compiled January 25, 2007 09:47:40
+1 ;;5.3;scheduling;**446**;AUG 13 1993;Build 77
+2 ;
+3 ; ******************************************************************
+4 ; CHANGE LOG
+5 ;
+6 ; DATE PATCH DESCRIPTION
+7 ; ---- ----- -----------
+8 ;
+9 ;
EN(SDWLDFN,SDWLERR) ; Entry Point
+1 ; Extrinsic function. Quit back one of the following values
+2 ; 0 : Inter-Facility Transfer not selected, continue with standard processing
+3 ; 1 : Inter-Facility selected, all processing performed here, quit out on return.
+4 ;
+5 ; SDWLERR passed back by reference, indicates to the calling routine
+6 ; whether to announce that the update to 409.3 was performed.
+7 ;
+8 NEW ICN,SDWLIFTN,SDWLONSY,SDWLTY,SSN
+9 SET SDWLIFTN=0
SET SDWLERR=1
SET SDWLONSY=0
+10 SET ICN=$$GET1^DIQ(2,SDWLDFN,991.01)
SET SSN=$$GET1^DIQ(2,SDWLDFN,.09)
+11 IF ICN'=""
IF $DATA(^SDWL(409.36,"AICN",ICN))
SET SDWLONSY=1
+12 IF SSN'=""
IF $DATA(^SDWL(409.36,"SSN",SSN))
SET SDWLONSY=1
+13 if SDWLONSY
Begin DoDot:1
+14 NEW DIR,SDWLARR,SDWLI,SDWLIFN0,SDWLILM,TMP
+15 SET SDWLIFN0=""
SET SDWLILM=23
+16 IF ICN'=""
FOR
SET SDWLIFN0=$ORDER(^SDWL(409.36,"AICN",ICN,SDWLIFN0))
if SDWLIFN0=""
QUIT
SET TMP(SDWLIFN0)=""
+17 IF SSN'=""
FOR
SET SDWLIFN0=$ORDER(^SDWL(409.36,"SSN",SSN,SDWLIFN0))
if SDWLIFN0=""
QUIT
SET TMP(SDWLIFN0)=""
+18 FOR
SET SDWLIFN0=$ORDER(TMP(SDWLIFN0))
if SDWLIFN0=""
QUIT
Begin DoDot:2
+19 NEW SDWLIL,SDWLINS,SDWLINSX,SDWLINX,TMP
+20 DO GETS^DIQ(409.36,SDWLIFN0_",",".1;1;4",,"TMP")
+21 if "P"'[$EXTRACT(TMP(409.36,SDWLIFN0_",",1))
QUIT
+22 SET SDWLINS=TMP(409.36,SDWLIFN0_",",.1)
SET SDWLINSX=$$GET1^DIQ(4,SDWLINS,.01)
+23 SET SDWLIL=$LENGTH(SDWLINSX)
if SDWLIL>SDWLILM
SET SDWLILM=SDWLIL
+24 SET SDWLARR(0)=$GET(SDWLARR(0))+1
+25 SET SDWLARR(SDWLARR(0),0)=SDWLINSX_U_TMP(409.36,SDWLIFN0_",",4)_U_SDWLIFN0_U_$$GET1^DIQ(4,SDWLINS,4,"I")
+26 QUIT
End DoDot:2
+27 if '$DATA(SDWLARR)
QUIT
+28 WRITE !,"This patient has the following pending Inter-Facility Transfer entr"_$SELECT(SDWLARR(0)=1:"y",1:"ies")_":"
+29 WRITE !?5,"Requesting Facility",?SDWLILM+5,"Wait List Type"
+30 FOR SDWLI=1:1:SDWLARR(0)
WRITE !,SDWLI,?5,$PIECE(SDWLARR(SDWLI,0),U),?SDWLILM+5,$PIECE(SDWLARR(SDWLI,0),U,2)
+31 SET DIR("A")="Enter a number"
+32 SET DIR("A",1)="Select to associate this EWL entry with a transfer from the listed facility "
+33 SET DIR("A",2)="or ^ to continue without selecting."
+34 SET DIR(0)="N^1:"_SDWLARR(0)
DO ^DIR
+35 if Y="^"
QUIT
+36 SET SDWLIFTN=$PIECE(SDWLARR(Y,0),U,3)
SET SDWLTY=$PIECE(SDWLARR(Y,0),U,2)
+37 QUIT
End DoDot:1
+38 ; Continue with normal EWL enter/edit.
if 'SDWLIFTN
QUIT 0
+39 DO EN2(SDWLIFTN,SDWLDFN,SDWLTY)
+40 ; Return true: user chose to process transfer.
QUIT 1
+41 ;
EN2(SDWLIFTN,SDWLDFN,SDWLTY) ; Entry point if transfer record is selected elsewhere.
+1 NEW DFN,SDWLCM,SDWLCP1,SDWLCP2,SDWLCP3,SDWLCP4,SDWLCP5,SDWLCP6,SDWLDDA,SDWLIN,SDWLOPT,SDWLPCMM,SDWLPN,SDWLPOS,SDWLSCO,SDWLSPO,SDWLSSO,SDWLSTO,SDWLTEM,SDWLTM
+2 IF $GET(SDWLDFN)=""
WRITE !,"Patient not entered on the system. Use Load/edit"
SET DIR(0)="E"
DO ^DIR
QUIT
+3 LOCK +^SDWL(409.36,SDWLIFTN):1
+4 IF '$TEST
WRITE !,"Unable to acquire lock on transfer file"
SET DIR(0)="E"
DO ^DIR
QUIT
+5 SET DFN=SDWLDFN
DO PCM^SDWLE1
+6 ; Call each "P" subroutine for Wait List data items. Controlled by the value of SDWLOPT.
+7 SET SDWLOPT=1
SET (SDWLIN,SDWLTM,SDWLPN,SDWLDDA,SDWLCM)=""
+8 FOR
DO @("P"_SDWLOPT)
if 'SDWLOPT
QUIT
+9 LOCK -^SDWL(409.36,SDWLIFTN)
+10 QUIT
+11 ;
P1 ; Wait List Type
+1 NEW DIR
+2 SET DIR(0)="SO^1:PCMM TEAM ASSIGNMENT;2:PCMM POSITION ASSIGNMENT"
+3 SET DIR("L",1)=" Select Wait List Type:"
+4 SET DIR("L",2)=" 1. "_$PIECE($PIECE(DIR(0),U,2),":",2)
+5 SET DIR("L",3)=" 2. "_$PIECE($PIECE(DIR(0),U,3),":",2)
+6 IF SDWLTY'=""
SET DIR("B")=SDWLTY
+7 DO ^DIR
+8 IF "^"[Y
SET SDWLOPT=0
QUIT
+9 SET SDWLTY=Y
SET SDWLOPT=SDWLOPT+1
+10 QUIT
+11 ;
P2 ; Institution
+1 NEW DIC,SDWLINL,SDWLTM
+2 IF SDWLTY=1
SET DIC("S")="I $D(^SCTM(404.51,""AINST"",+Y))"
+3 IF SDWLTY=2
Begin DoDot:1
+4 NEW SDWLI
+5 IF 'SDWLCP3
SET SDWLI=0
FOR
SET SDWLI=$ORDER(^SCTM(404.57,SDWLI))
if 'SDWLI
QUIT
Begin DoDot:2
+6 NEW SDWLL
+7 SET SDWLL=+$PIECE($GET(^SCTM(404.57,SDWLI,0)),U,2)
+8 SET SDWLINL=+$PIECE($GET(^SCTM(404.51,+SDWLL,0)),U,7)
+9 SET SDWLINL(SDWLINL)=""
+10 QUIT
End DoDot:2
+11 SET DIC("S")="I $D(SDWLINL(+Y))"
+12 QUIT
End DoDot:1
+13 SET DIC("S")=DIC("S")_",$$GET1^DIQ(4,+Y_"","",11,""I"")=""N"",$$TF^XUAF4(+Y)"
+14 IF SDWLIN'=""
SET DIC("B")=$$EXTERNAL^DILFD(4,.01,,SDWLIN)
+15 SET DIC(0)="AEQNM"
SET DIC="4"
SET DIC("A")="Select Institution: "
+16 DO ^DIC
+17 IF Y="^"
SET SDWLOPT=0
QUIT
+18 IF Y<1
SET SDWLOPT=SDWLOPT-1
QUIT
+19 IF SDWLTY=1
DO GETTEAMS(+Y,.SDWLTM)
IF '$DATA(SDWLTM)
WRITE !,"No TEAMS are available for this INSTITUTION."
QUIT
+20 SET SDWLIN=+Y
SET SDWLOPT=SDWLOPT+1
+21 QUIT
+22 ;
P3 ; Team or Team Position
+1 NEW DIR,SDWLPNS
+2 IF $GET(SDWLCP3)'=""
Begin DoDot:1
+3 NEW DIR
+4 WRITE !,"This patient is already on the ",SDWLCP3,"."
+5 SET DIR(0)="Y^A0"
SET DIR("B")="NO"
SET DIR("A")="Are you sure you want to continue"
+6 DO ^DIR
+7 QUIT
End DoDot:1
IF Y["^"!'Y
SET SDWLOPT=0
QUIT
+8 IF SDWLTY=1
Begin DoDot:1
+9 NEW DIR
+10 ; Not sure this is ever true.
IF $GET(SDWLTM)'=""
SET DIR("B")=$$EXTERNAL^DILFD(404.58,.01,,SDWLTM)
+11 DO GETTEAMS(SDWLIN,.SDWLTM)
+12 SET DIR(0)="PAO^SCTM(404.51,:EMNZ"
SET DIR("A")="Select Team: "
+13 SET DIR("S")="I $D(SDWLTM(+Y))"
+14 DO ^DIR
+15 IF Y="^"
SET SDWLOPT=0
QUIT
+16 IF Y<1
SET SDWLOPT=2
QUIT
+17 SET SDWLTM=+Y
SET SDWLOPT=SDWLOPT+1
+18 QUIT
End DoDot:1
QUIT
+19 ; Not sure this is ever true.
IF $GET(SDWLPN)'=""
SET DIR("B")=$$EXTERNAL^DILFD(404.57,.01,,SDWLPN)
+20 DO GETPSNS(.SDWLPNS)
IF '$DATA(SDWLPNS)
WRITE !,"No Positions Meet Wait List Criteria"
SET SDWLOPT=1
QUIT
+21 SET DIR(0)="PAO^SCTM(404.57,:EMNZ"
SET DIR("A")="Select Team Position: "
+22 SET DIR("S")="I $D(SDWLPNS(+Y))"
+23 DO ^DIR
+24 IF Y="^"
SET SDWLOPT=0
QUIT
+25 IF Y<1
SET SDWLOPT=SDWLOPT-1
QUIT
+26 SET SDWLPN=+Y
SET SDWLOPT=SDWLOPT+1
+27 QUIT
+28 ;
P4 ; Comment
+1 NEW DIR
+2 SET DIR(0)="FAOU^^"
SET DIR("A")="Comments: "
SET DIR("B")=SDWLCM
+3 DO ^DIR
+4 IF Y="^"
SET SDWLOPT=0
QUIT
+5 IF X="@"
SET SDWLOPT=SDWLOPT-1
QUIT
+6 SET SDWLCM=$EXTRACT(Y,1,60)
SET SDWLOPT=SDWLOPT+1
+7 QUIT
+8 ;
P5 ; Update database
+1 NEW DA,DIC,DIE,X,DR,SDWLDA,SDWLSCPE,SDWLSCPR,SDWLTMP
+2 ; Create new EWL entry
+3 SET DIC(0)="LX"
SET X=SDWLDFN
SET DIC="^SDWL(409.3,"
DO FILE^DICN
+4 ; This file has just been created. Is it neurotic to code for the possibility of a lock from elsewhere?
LOCK +^SDWL(409.3,DA):1
+5 IF '$TEST
WRITE !,"Unable to acquire a lock on the Wait List file"
SET SDWLOPT=5
QUIT
+6 ; Update EWL variables.
+7 DO GETS^DIQ(409.36,SDWLIFTN_",",".301;.302","I","SDWLTMP")
+8 SET SDWLSCPR=$GET(SDWLTMP(409.36,SDWLIFTN_",",.301,"I"))="Y"
+9 SET SDWLSCPE=$GET(SDWLTMP(409.36,SDWLIFTN_",",.302,"I"))
+10 SET SDWLDA=DA
SET DIE=DIC
SET DR="1////^S X=DT;2////^S X=SDWLIN;4////^S X=SDWLTY"
+11 IF SDWLTY=1
SET DR=DR_";5////^S X=SDWLTM"
+12 IF SDWLTY=2
SET DR=DR_";6////^S X=SDWLPN"
+13 SET DR=DR_";9////^S X=DUZ"
+14 SET DR=DR_";14////^S X=SDWLSCPE"
+15 SET DR=DR_";15////^S X=SDWLSCPR"
+16 SET DR=DR_";22////^S X=SDWLDDA"
+17 SET DR=DR_";23////O"
+18 SET DR=DR_";25////^S X=SDWLCM"
+19 SET DR=DR_";27////^S X="""_$$GETENRST^SDWLE6(SDWLDFN)_""""
+20 DO ^DIE
+21 LOCK -^SDWL(409.3,DA)
+22 ; Update 409.36
+23 SET DIE="^SDWL(409.36,"
SET DA=SDWLIFTN
SET DR="1////E;409.3////^S X=SDWLDA"
DO ^DIE
+24 ; Pass message back to sending facility
+25 DO SENDST^SDWLIFT6(SDWLIFTN)
+26 SET SDWLOPT=0
SET SDWLERR=0
+27 QUIT
+28 ;
GETTEAMS(SDWLIN,SDWLTM) ; Get teams for an institution ; NB this is reworking of code in SDWLE3.
+1 NEW Y,SDWLST,SDWLINE,SDWLPLST,TMHSID
KILL SDWLTM
+2 SET SDWLINE=SDWLIN
+3 DO GETLIST^SDWLE3
+4 ; Team history
SET TMHSID=""
+5 FOR
SET TMHSID=$ORDER(^SCTM(404.58,"B",TMHSID))
if TMHSID=""
QUIT
if $PIECE($GET(^SCTM(404.51,TMHSID,0)),U,7)=SDWLIN
Begin DoDot:1
+6 ; Team
NEW TMID
+7 SET TMID=$ORDER(^SCTM(404.58,"B",TMHSID,":"),-1)
if TMID=""
QUIT
+8 if $DATA(SDWLPLST(1,TMID,SDWLIN))
QUIT
+9 if $PIECE($GET(^SCTM(404.58,TMID,0)),U,3)=0
QUIT
+10 if '$$ACTTM^SCMCTMU(TMID)
QUIT
+11 IF $$TEAMCNT^SCAPMCU1(TMHSID,DT)>$PIECE($GET(^SCTM(404.51,TMHSID,0)),U,8)
SET SDWLTM(TMHSID)=""
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
GETPSNS(SDWLPN) ; Get positions ; NB this is reworking of code in SDWLE5.
+1 NEW SDWLPSS,SDWLPDA,SDWLX,SDWLA,SDWLCPP,SDWLCPT
KILL SDWLPN
+2 DO GETLIST^SDWLE5
+3 if '$DATA(SDWLCPP)
QUIT
+4 SET SDWLA=0
+5 FOR
SET SDWLA=$ORDER(^SCTM(404.57,SDWLA))
if 'SDWLA
QUIT
if $DATA(SDWLCPP(SDWLA))&'$DATA(SDWLPSS(SDWLA))
Begin DoDot:1
+6 NEW X
+7 SET X=$GET(^SCTM(404.57,SDWLA,0))
+8 if $PIECE(X,U,2)'=SDWLCPT
QUIT
+9 if $PIECE(X,U,8)'<$$PCPOSCNT^SCAPMCU1(SDWLA,DT,0)&$PIECE(X,U,4)
SET SDWLPN(SDWLA)=""
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
GETENRST(SDWLDFN) ; Determine enrollee status ; NB this is reworking of code in SDWLE11.
+1 NEW SDWLE
+2 SET SDWLE=1
Begin DoDot:1
+3 NEW SDWLX,SDWLY,%H
+4 IF '$DATA(^DGCN(391.91,"B",SDWLDFN))
SET SDWLE=3
QUIT
+5 ; Loop backwards through the B cross reference of TREATING FACILITY LIST until there is a DATE LAST TREATED entry.
+6 ; If that is less than 730 days ago, SDWLE=2; otherwise, SDWLE=3. Then quit from the loop.
+7 SET SDWLX=""
+8 FOR
SET SDWLX=$ORDER(^DGCN(391.91,"B",SDWLDFN,SDWLX),-1)
if SDWLX=""
QUIT
SET SDWLY=$GET(^DGCN(391.91,SDWLX,0))
IF $PIECE(SDWLY,U,3)
SET X=$PIECE(SDWLY,U,3)
DO H^%DTC
SET SDWLE=$HOROLOG-%H'<730+2
QUIT
+9 QUIT
End DoDot:1
+10 if SDWLE'=2
Begin DoDot:1
+11 NEW SDWLRNE,%H
+12 SET SDWLRNE=$$ENROLL^EASWTAPI(SDWLDFN)
+13 ; If number of days is greater than a year, SDWLE=3; otherwise, SDWLE=1.
IF $PIECE(SDWLRNE,U,3)
SET X=$PIECE(SDWLRNE,U,3)
DO H^%DTC
SET SDWLE=$HOROLOG-%H>365*2+1
+14 IF 'SDWLRNE
SET SDWLE=4
+15 QUIT
End DoDot:1
+16 QUIT $SELECT(SDWLE=1:"N",SDWLE=2:"E",SDWLE=3:"P",SDWLE=4:"U")
+17 ;
DIS(SDWLDA) ; Action on disposition
+1 NEW DIE,DR,SDWLDIS,SDWLIFTN,SDWLSTA,X
+2 SET SDWLIFTN=$ORDER(^SDWL(409.36,"C",SDWLDA,""))
if 'SDWLIFTN
QUIT
+3 SET SDWLDIS=$$GET1^DIQ(409.3,SDWLDA,21,"I")
+4 ; If disposition is because entered in error, reset to pending. Otherwise, set to closed.
+5 SET SDWLSTA=$SELECT(SDWLDIS="ER":"P",1:"C")
+6 SET DIE="^SDWL(409.36,"
SET DA=SDWLIFTN
SET DR="1///"_SDWLSTA
DO ^DIE
+7 ; Pass message back to sending facility
+8 DO SENDST^SDWLIFT6(SDWLIFTN)
+9 QUIT
