SDWLE3 ;IOFO BAY PINES/TEH - WAITING LIST-ENTER/EDIT;06/12/2002 ; 12/14/05 1:28pm ; Compiled April 25, 2006 10:42:02
;;5.3;scheduling;**263,417,446**;AUG 13 1993;Build 77
;
;
;******************************************************************
; CHANGE LOG
;
; DATE PATCH DESCRIPTION
; ---- ----- -----------
; 08/01/2005 SD*5.3*417 Permit multiple teams
; 04/21/2006 SD*5.3*446 Inter-Facility Transfer
;
;
EN ;
;ASK FOR SPECIFIC TEAM (404.51)
K DIR,DIC,DR,DIE,SDTMENT S (DA,SDTMENT)=SDWLDA K SDWLTH,SDWLMAX
S SDWLYN=5,SDWLTYE=1,SDWLVBR="SDWLST"
I $D(SDWLST),'SDWLST K SDWLST
I $G(SDWLCP3)'="" D
.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
.I 'Y!(Y["^") S DUOUT=1 Q
I $D(DUOUT),DUOUT G END
D GETLIST
S SDWLERR=0,SDWLY="Team",SDWLVAR=$S($D(SDWLST):SDWLST,1:0),SDWLSCR=""
S SDWLVBR="SDWLST"
EN1 W ! S SDWLS=SDWLY,SDWLX=$S(SDWLTYE=1:"T",SDWLTYE=2:"P",1:""),SDWLSX=" "_SDWLS
S SDWLF="SCTM(404.51,"
S SDWLA=0 F S SDWLA=$O(^SCTM(404.58,"B",SDWLA)) Q:SDWLA="" D
.I $D(SDWLCT),SDWLCT=SDWLA Q
.I $P($G(^SCTM(404.51,SDWLA,0)),U,7)'=SDWLIN Q
.I +$$ACTTM^SCMCTMU(SDWLA)=0 S SDWLTH(SDWLA)=""
.S SDWLMAX=0,X=$$TEAMCNT^SCAPMCU1(SDWLA,DT),SDWLMAX(SDWLA)="" D
..I X<$P($G(^SCTM(404.51,SDWLA,0)),U,8) K SDWLMAX(SDWLA)
N SDWLT S SDWLT=0 F S SDWLT=$O(SDWLPLST(1,SDWLT)) Q:SDWLT<1 K SDWLMAX(SDWLT)
S SDWLSCR="I $P(^(0),U,7)=SDWLIN,'$D(SDWLTH(+Y)),$D(SDWLMAX(+Y)),'$D(SDWLPLST(SDWLTYE,+Y,SDWLIN))"
D EN2 G END:$D(DUOUT)
;DA=SDWLDA, see EN
S DR="5////^S X=SDWLVAR",DIE=409.3 D ^DIE
N FLG D FLAGS(.FLG,DFN,SDWLVAR)
I 'FLG S DA=SDTMENT,DIE=409.3 D
.S SDINTR=FLG(1),SDREJ=FLG(2),SDMTM=FLG(3)
.S DR="32////^S X=SDREJ;34////^S X=SDINTR;38////^S X=SDMTM" D ^DIE
;
S @SDWLVBR=SDWLVAR
I $D(SDWLVARO),SDWLVARO,SDWLVAR'=SDWLVARO D DELPOS
G END
EN2 ;-DIR READ
I '$D(SDWLDATA),$D(SDWLMAX)'=11 W !,"No TEAMS are available for this INSTITUTION.",! S DUOUT="" Q
K DIR,DR,DIE,DIC,DUOUT
S DIR("?")="^S X=""?"",DIC(""S"")=""I $P(^SCTM(404.51,+Y,0),U,7)=SDWLIN,'$D(SDWLTH(+Y)),$D(SDWLMAX(+Y)),'$D(SDWLPLST(1,+Y,SDWLINE))"" S DIC=404.51,DIC(0)=""EQMNZ"" D ^DIC"
I $D(SDWLVAR),SDWLVAR S X=SDWLVAR,SDWLMPX=$$EXTERNAL^DILFD(409.3,SDWLYN,,SDWLVAR),DIR("B")=SDWLMPX,SDWLVARO=SDWLVAR K X
S DIR(0)="FAO",DIR("A")="Select "_SDWLY_": "
D ^DIR
I X["^" S DUOUT=1 Q
S DUOUT=$S(X=0:1,X="@":1,$D(DTOUT):1,1:0) I 'DUOUT K DUOUT
I X="@" W *7," No deleting allowing." G EN2
S DIC("S")=SDWLSCR
S DIC(0)="EMNZ",DIC=404.51 D ^DIC I $D(DTOUT) S DUOUT=1
I $D(DUOUT) Q
I Y<0 W "??" G EN2
S SDWLVAR=+Y
Q
;identify flags
FLAGS(FLG,DFN,TEAM) ;
N SDTEAM S SDTEAM=$G(TEAM)
; check if transfer and if multiple teams in institution
S SDCNT=0,SDINTR=0,SDREJ=0,SDMTM=0 D
.S SDWLIN=$P($G(^SCTM(404.51,TEAM,0)),U,7)
.I $P(^SCTM(404.51,TEAM,0),U,5)'=1 Q ; cannot be primary care provider team
.;identify INTRA-transfer
.;- is patient assigned to PC provider?
.I $$GETALL^SCAPMCA(DFN) D
..I $G(^TMP("SC",$J,DFN,"PCPOS",0)) S SDTM=$P(^(1),U,3) I SDTM>0 D
...I $P($G(^SCTM(404.51,SDTM,0)),U,7)'=SDWLIN S SDINTR=1 D ; inter transfer ; different institution
..I '$G(^TMP("SC",$J,DFN,"PCPOS",0)) D
...;check available PCMM teams in other institutions and if so set up rejection flag
...S SDINS=""
...F S SDINS=$O(^SCTM(404.51,"AINST",SDINS)) Q:SDINS="" I SDINS'=SDWLIN D Q:SDREJ
....S SDCNT=0,SDT=""
....F S SDT=$O(^SCTM(404.51,"AINST",SDINS,SDT)) Q:SDT="" D Q:SDREJ
.....I $$ACTTM^SCMCTMU(SDT,DT)&($P($G(^SCTM(404.51,SDT,0)),U,5))&'$P($G(^SCTM(404.51,SDT,0)),U,10) D
......S SCTMCT=$$TEAMCNT^SCAPMCU1(SDT) ;currently assigned
......S SCTMMAX=$P($$GETEAM^SCAPMCU3(SDT),"^",8) ;maximum set
......I SCTMCT<SCTMMAX S SDREJ=1
..;find all teams from institution SDWLIN
..I SDINTR S SDCNT=0,SDT="" D
...F S SDT=$O(^SCTM(404.51,"AINST",SDWLIN,SDT)) Q:SDT="" I $P(^SCTM(404.51,SDT,0),U,5)=1 S TEAM(SDT)="",SDCNT=SDCNT+1
S FLG(1)=SDINTR,FLG(2)=SDREJ,FLG(3)=SDMTM
I SDCNT>1 S SDMTM=1,FLG(3)=SDMTM,FLG=1 S SDCC="" F S SDCC=$O(TEAM(SDCC)) Q:SDCC="" S TEAM=SDCC N DR,Y D WMT
I SDCNT>1 S TEAM=$G(SDTEAM) Q
I SDCNT'>1 N DR,Y S FLG=0 S TEAM=$G(SDTEAM) Q
WMT D INPUT^SDWLRP1(.RES,DFN_U_1_U_TEAM_U_U_DUZ_"^^"_U_SDINTR_U_SDREJ_U_SDMTM)
;I $G(RES) S OK=0,DA=+$P(RES,U,2),DIE="^SDWL(409.3,",DR="25;S OK=1" D ^DIE I '$G(OK) S DIK=DIE D ^DIK W !,"Wait list entry deleted"
Q
GETLIST ;GET LIST OF TEAM ASSIGNMENTS - SD*5.3*417
N SDWLDAX,X,Z,SDWLIN K SDWLPLST S SDWLPLST=""
S SDWLDAX=0 F S SDWLDAX=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDAX)) Q:SDWLDAX="" D
.S Z=$G(^SDWL(409.3,SDWLDAX,0)),X=$P(Z,U,5),SDWLINE=+$P(Z,U,3) Q:X'=1&(X'=2) D
..S Y=+$S(X=1:$P(Z,U,6),X=2:$P(Z,U,7),1:0) Q:'Y D
...I $P(Z,U,17)["O" S SDWLPLST(X,Y,SDWLINE)="" I $D(SDWLST),SDWLST=+Y K SDWLPLST(X,Y,SDWLINE)
S Y=0 F S Y=$O(SDWLCPT(Y)) Q:Y="" D
.S SDWLPLST(1,Y,SDWLINE)="" I $D(SDWLST),SDWLST=+Y K SDWLPLST(1,Y,SDWLINE)
Q
DELPOS ;DELETE POSITIONS FOR OLD TEAM
S SDWLA=0,CNT=0 F S SDWLA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLA)) Q:SDWLA<1 D
.S X=$G(^SDWL(409.3,SDWLA,0)) Q:$P(X,U,7)=""
.I $P(X,U,5)'=2 Q
.I $P(X,U,17)["C" Q
.S SDWLPX=+$P(X,U,7) I $P($G(^SCTM(404.57,SDWLPX,0)),U,2)'=SDWLVARO Q
.S CNT=CNT+1,^XTMP("SDWLE3",$J,CNT)=SDWLA_";"_X W !
I 'CNT Q
W !,"This patient has one or more Wait List entries for PCMM Positions",!
W !,"Wait List Type",?30,"Waiting For",?45,"Institution",?60,"Date Entered",!
S Y=0 F S Y=$O(^XTMP("SDWLE3",$J,Y)) Q:Y<1 S X=$G(^XTMP("SDWLE3",$J,Y)),SDWLIEN=$P(X,";",1) D
.W !,$$GET1^DIQ(409.3,SDWLIEN,4),?30,$$GET1^DIQ(409.3,SDWLIEN,6),?45,$$GET1^DIQ(409.3,SDWLIEN,2),?60,$$GET1^DIQ(409.3,SDWLIEN,1)
W ! S SDWLET=$$EXTERNAL^DILFD(409.3,SDWLYN,,SDWLVARO)
K DIR S DIR("?",1)="This patient has one or more Wait List entries for PCMM positions."
S DIR("?",2)="By answering 'YES' you will close the Wait List entries which were listed."
S DIR("?")="Answer 'NO' to keep those Wait List entries open."
S DIR("A")="Do you wish to close these POSITION(S) entries? ",DIR(0)="Y",DIR("B")="YES" D ^DIR
I 'Y W *7," No POSITIONS closed." Q
N DA S SDWLA=0 F S SDWLA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLA)) Q:SDWLA<1 D
.S X=$G(^SDWL(409.3,SDWLA,0)) Q:$P(X,U,7)="" D
..S SDWLP=$P(X,U,7) I $P(^SCTM(404.57,SDWLP,0),U,2)=SDWLVARO D
...K DIE,DIC,DR,DICR,DIR S DA=SDWLA,SDWLDISP="NN"
...S DIE="^SDWL(409.3,",DR="21////^S X=SDWLDISP" D ^DIE
...S DR="19////^S X=DT" D ^DIE
...S DR="20////^S X=SDWLDUZ" D ^DIE
...S DR="23////""C""" D ^DIE
Q
END K SDWLA,SDWLMAX,SDWLTH,SDWLSCR,DIR,DIC,DIE,DR,SDWLPLST,SDWLDAX,DTOUT,SDWLCP3,SDWLINE
K X,Y,Z,SDWLPLST,SDWLB,SDWLA,SDWLSX,SDWLS,SDWLVBR,SDWLVAR,SDWLSCR,SDWLF,SDWLYN,SDWLMPX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLE3 6974 printed Oct 16, 2024@19:02:55 Page 2
SDWLE3 ;IOFO BAY PINES/TEH - WAITING LIST-ENTER/EDIT;06/12/2002 ; 12/14/05 1:28pm ; Compiled April 25, 2006 10:42:02
+1 ;;5.3;scheduling;**263,417,446**;AUG 13 1993;Build 77
+2 ;
+3 ;
+4 ;******************************************************************
+5 ; CHANGE LOG
+6 ;
+7 ; DATE PATCH DESCRIPTION
+8 ; ---- ----- -----------
+9 ; 08/01/2005 SD*5.3*417 Permit multiple teams
+10 ; 04/21/2006 SD*5.3*446 Inter-Facility Transfer
+11 ;
+12 ;
EN ;
+1 ;ASK FOR SPECIFIC TEAM (404.51)
+2 KILL DIR,DIC,DR,DIE,SDTMENT
SET (DA,SDTMENT)=SDWLDA
KILL SDWLTH,SDWLMAX
+3 SET SDWLYN=5
SET SDWLTYE=1
SET SDWLVBR="SDWLST"
+4 IF $DATA(SDWLST)
IF 'SDWLST
KILL SDWLST
+5 IF $GET(SDWLCP3)'=""
Begin DoDot:1
+6 WRITE !,"This patient is already on the ",SDWLCP3,"."
SET DIR(0)="Y^A0"
SET DIR("B")="NO"
SET DIR("A")="Are you sure you want to continue"
DO ^DIR
+7 IF 'Y!(Y["^")
SET DUOUT=1
QUIT
End DoDot:1
+8 IF $DATA(DUOUT)
IF DUOUT
GOTO END
+9 DO GETLIST
+10 SET SDWLERR=0
SET SDWLY="Team"
SET SDWLVAR=$SELECT($DATA(SDWLST):SDWLST,1:0)
SET SDWLSCR=""
+11 SET SDWLVBR="SDWLST"
EN1 WRITE !
SET SDWLS=SDWLY
SET SDWLX=$SELECT(SDWLTYE=1:"T",SDWLTYE=2:"P",1:"")
SET SDWLSX=" "_SDWLS
+1 SET SDWLF="SCTM(404.51,"
+2 SET SDWLA=0
FOR
SET SDWLA=$ORDER(^SCTM(404.58,"B",SDWLA))
if SDWLA=""
QUIT
Begin DoDot:1
+3 IF $DATA(SDWLCT)
IF SDWLCT=SDWLA
QUIT
+4 IF $PIECE($GET(^SCTM(404.51,SDWLA,0)),U,7)'=SDWLIN
QUIT
+5 IF +$$ACTTM^SCMCTMU(SDWLA)=0
SET SDWLTH(SDWLA)=""
+6 SET SDWLMAX=0
SET X=$$TEAMCNT^SCAPMCU1(SDWLA,DT)
SET SDWLMAX(SDWLA)=""
Begin DoDot:2
+7 IF X<$PIECE($GET(^SCTM(404.51,SDWLA,0)),U,8)
KILL SDWLMAX(SDWLA)
End DoDot:2
End DoDot:1
+8 NEW SDWLT
SET SDWLT=0
FOR
SET SDWLT=$ORDER(SDWLPLST(1,SDWLT))
if SDWLT<1
QUIT
KILL SDWLMAX(SDWLT)
+9 SET SDWLSCR="I $P(^(0),U,7)=SDWLIN,'$D(SDWLTH(+Y)),$D(SDWLMAX(+Y)),'$D(SDWLPLST(SDWLTYE,+Y,SDWLIN))"
+10 DO EN2
if $DATA(DUOUT)
GOTO END
+11 ;DA=SDWLDA, see EN
+12 SET DR="5////^S X=SDWLVAR"
SET DIE=409.3
DO ^DIE
+13 NEW FLG
DO FLAGS(.FLG,DFN,SDWLVAR)
+14 IF 'FLG
SET DA=SDTMENT
SET DIE=409.3
Begin DoDot:1
+15 SET SDINTR=FLG(1)
SET SDREJ=FLG(2)
SET SDMTM=FLG(3)
+16 SET DR="32////^S X=SDREJ;34////^S X=SDINTR;38////^S X=SDMTM"
DO ^DIE
End DoDot:1
+17 ;
+18 SET @SDWLVBR=SDWLVAR
+19 IF $DATA(SDWLVARO)
IF SDWLVARO
IF SDWLVAR'=SDWLVARO
DO DELPOS
+20 GOTO END
EN2 ;-DIR READ
+1 IF '$DATA(SDWLDATA)
IF $DATA(SDWLMAX)'=11
WRITE !,"No TEAMS are available for this INSTITUTION.",!
SET DUOUT=""
QUIT
+2 KILL DIR,DR,DIE,DIC,DUOUT
+3 SET DIR("?")="^S X=""?"",DIC(""S"")=""I $P(^SCTM(404.51,+Y,0),U,7)=SDWLIN,'$D(SDWLTH(+Y)),$D(SDWLMAX(+Y)),'$D(SDWLPLST(1,+Y,SDWLINE))"" S DIC=404.51,DIC(0)=""EQMNZ"" D ^DIC"
+4 IF $DATA(SDWLVAR)
IF SDWLVAR
SET X=SDWLVAR
SET SDWLMPX=$$EXTERNAL^DILFD(409.3,SDWLYN,,SDWLVAR)
SET DIR("B")=SDWLMPX
SET SDWLVARO=SDWLVAR
KILL X
+5 SET DIR(0)="FAO"
SET DIR("A")="Select "_SDWLY_": "
+6 DO ^DIR
+7 IF X["^"
SET DUOUT=1
QUIT
+8 SET DUOUT=$SELECT(X=0:1,X="@":1,$DATA(DTOUT):1,1:0)
IF 'DUOUT
KILL DUOUT
+9 IF X="@"
WRITE *7," No deleting allowing."
GOTO EN2
+10 SET DIC("S")=SDWLSCR
+11 SET DIC(0)="EMNZ"
SET DIC=404.51
DO ^DIC
IF $DATA(DTOUT)
SET DUOUT=1
+12 IF $DATA(DUOUT)
QUIT
+13 IF Y<0
WRITE "??"
GOTO EN2
+14 SET SDWLVAR=+Y
+15 QUIT
+16 ;identify flags
FLAGS(FLG,DFN,TEAM) ;
+1 NEW SDTEAM
SET SDTEAM=$GET(TEAM)
+2 ; check if transfer and if multiple teams in institution
+3 SET SDCNT=0
SET SDINTR=0
SET SDREJ=0
SET SDMTM=0
Begin DoDot:1
+4 SET SDWLIN=$PIECE($GET(^SCTM(404.51,TEAM,0)),U,7)
+5 ; cannot be primary care provider team
IF $PIECE(^SCTM(404.51,TEAM,0),U,5)'=1
QUIT
+6 ;identify INTRA-transfer
+7 ;- is patient assigned to PC provider?
+8 IF $$GETALL^SCAPMCA(DFN)
Begin DoDot:2
+9 IF $GET(^TMP("SC",$JOB,DFN,"PCPOS",0))
SET SDTM=$PIECE(^(1),U,3)
IF SDTM>0
Begin DoDot:3
+10 ; inter transfer ; different institution
IF $PIECE($GET(^SCTM(404.51,SDTM,0)),U,7)'=SDWLIN
SET SDINTR=1
Begin DoDot:4
End DoDot:4
End DoDot:3
+11 IF '$GET(^TMP("SC",$JOB,DFN,"PCPOS",0))
Begin DoDot:3
+12 ;check available PCMM teams in other institutions and if so set up rejection flag
+13 SET SDINS=""
+14 FOR
SET SDINS=$ORDER(^SCTM(404.51,"AINST",SDINS))
if SDINS=""
QUIT
IF SDINS'=SDWLIN
Begin DoDot:4
+15 SET SDCNT=0
SET SDT=""
+16 FOR
SET SDT=$ORDER(^SCTM(404.51,"AINST",SDINS,SDT))
if SDT=""
QUIT
Begin DoDot:5
+17 IF $$ACTTM^SCMCTMU(SDT,DT)&($PIECE($GET(^SCTM(404.51,SDT,0)),U,5))&'$PIECE($GET(^SCTM(404.51,SDT,0)),U,10)
Begin DoDot:6
+18 ;currently assigned
SET SCTMCT=$$TEAMCNT^SCAPMCU1(SDT)
+19 ;maximum set
SET SCTMMAX=$PIECE($$GETEAM^SCAPMCU3(SDT),"^",8)
+20 IF SCTMCT<SCTMMAX
SET SDREJ=1
End DoDot:6
End DoDot:5
if SDREJ
QUIT
End DoDot:4
if SDREJ
QUIT
End DoDot:3
+21 ;find all teams from institution SDWLIN
+22 IF SDINTR
SET SDCNT=0
SET SDT=""
Begin DoDot:3
+23 FOR
SET SDT=$ORDER(^SCTM(404.51,"AINST",SDWLIN,SDT))
if SDT=""
QUIT
IF $PIECE(^SCTM(404.51,SDT,0),U,5)=1
SET TEAM(SDT)=""
SET SDCNT=SDCNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+24 SET FLG(1)=SDINTR
SET FLG(2)=SDREJ
SET FLG(3)=SDMTM
+25 IF SDCNT>1
SET SDMTM=1
SET FLG(3)=SDMTM
SET FLG=1
SET SDCC=""
FOR
SET SDCC=$ORDER(TEAM(SDCC))
if SDCC=""
QUIT
SET TEAM=SDCC
NEW DR,Y
DO WMT
+26 IF SDCNT>1
SET TEAM=$GET(SDTEAM)
QUIT
+27 IF SDCNT'>1
NEW DR,Y
SET FLG=0
SET TEAM=$GET(SDTEAM)
QUIT
WMT DO INPUT^SDWLRP1(.RES,DFN_U_1_U_TEAM_U_U_DUZ_"^^"_U_SDINTR_U_SDREJ_U_SDMTM)
+1 ;I $G(RES) S OK=0,DA=+$P(RES,U,2),DIE="^SDWL(409.3,",DR="25;S OK=1" D ^DIE I '$G(OK) S DIK=DIE D ^DIK W !,"Wait list entry deleted"
+2 QUIT
GETLIST ;GET LIST OF TEAM ASSIGNMENTS - SD*5.3*417
+1 NEW SDWLDAX,X,Z,SDWLIN
KILL SDWLPLST
SET SDWLPLST=""
+2 SET SDWLDAX=0
FOR
SET SDWLDAX=$ORDER(^SDWL(409.3,"B",SDWLDFN,SDWLDAX))
if SDWLDAX=""
QUIT
Begin DoDot:1
+3 SET Z=$GET(^SDWL(409.3,SDWLDAX,0))
SET X=$PIECE(Z,U,5)
SET SDWLINE=+$PIECE(Z,U,3)
if X'=1&(X'=2)
QUIT
Begin DoDot:2
+4 SET Y=+$SELECT(X=1:$PIECE(Z,U,6),X=2:$PIECE(Z,U,7),1:0)
if 'Y
QUIT
Begin DoDot:3
+5 IF $PIECE(Z,U,17)["O"
SET SDWLPLST(X,Y,SDWLINE)=""
IF $DATA(SDWLST)
IF SDWLST=+Y
KILL SDWLPLST(X,Y,SDWLINE)
End DoDot:3
End DoDot:2
End DoDot:1
+6 SET Y=0
FOR
SET Y=$ORDER(SDWLCPT(Y))
if Y=""
QUIT
Begin DoDot:1
+7 SET SDWLPLST(1,Y,SDWLINE)=""
IF $DATA(SDWLST)
IF SDWLST=+Y
KILL SDWLPLST(1,Y,SDWLINE)
End DoDot:1
+8 QUIT
DELPOS ;DELETE POSITIONS FOR OLD TEAM
+1 SET SDWLA=0
SET CNT=0
FOR
SET SDWLA=$ORDER(^SDWL(409.3,"B",SDWLDFN,SDWLA))
if SDWLA<1
QUIT
Begin DoDot:1
+2 SET X=$GET(^SDWL(409.3,SDWLA,0))
if $PIECE(X,U,7)=""
QUIT
+3 IF $PIECE(X,U,5)'=2
QUIT
+4 IF $PIECE(X,U,17)["C"
QUIT
+5 SET SDWLPX=+$PIECE(X,U,7)
IF $PIECE($GET(^SCTM(404.57,SDWLPX,0)),U,2)'=SDWLVARO
QUIT
+6 SET CNT=CNT+1
SET ^XTMP("SDWLE3",$JOB,CNT)=SDWLA_";"_X
WRITE !
End DoDot:1
+7 IF 'CNT
QUIT
+8 WRITE !,"This patient has one or more Wait List entries for PCMM Positions",!
+9 WRITE !,"Wait List Type",?30,"Waiting For",?45,"Institution",?60,"Date Entered",!
+10 SET Y=0
FOR
SET Y=$ORDER(^XTMP("SDWLE3",$JOB,Y))
if Y<1
QUIT
SET X=$GET(^XTMP("SDWLE3",$JOB,Y))
SET SDWLIEN=$PIECE(X,";",1)
Begin DoDot:1
+11 WRITE !,$$GET1^DIQ(409.3,SDWLIEN,4),?30,$$GET1^DIQ(409.3,SDWLIEN,6),?45,$$GET1^DIQ(409.3,SDWLIEN,2),?60,$$GET1^DIQ(409.3,SDWLIEN,1)
End DoDot:1
+12 WRITE !
SET SDWLET=$$EXTERNAL^DILFD(409.3,SDWLYN,,SDWLVARO)
+13 KILL DIR
SET DIR("?",1)="This patient has one or more Wait List entries for PCMM positions."
+14 SET DIR("?",2)="By answering 'YES' you will close the Wait List entries which were listed."
+15 SET DIR("?")="Answer 'NO' to keep those Wait List entries open."
+16 SET DIR("A")="Do you wish to close these POSITION(S) entries? "
SET DIR(0)="Y"
SET DIR("B")="YES"
DO ^DIR
+17 IF 'Y
WRITE *7," No POSITIONS closed."
QUIT
+18 NEW DA
SET SDWLA=0
FOR
SET SDWLA=$ORDER(^SDWL(409.3,"B",SDWLDFN,SDWLA))
if SDWLA<1
QUIT
Begin DoDot:1
+19 SET X=$GET(^SDWL(409.3,SDWLA,0))
if $PIECE(X,U,7)=""
QUIT
Begin DoDot:2
+20 SET SDWLP=$PIECE(X,U,7)
IF $PIECE(^SCTM(404.57,SDWLP,0),U,2)=SDWLVARO
Begin DoDot:3
+21 KILL DIE,DIC,DR,DICR,DIR
SET DA=SDWLA
SET SDWLDISP="NN"
+22 SET DIE="^SDWL(409.3,"
SET DR="21////^S X=SDWLDISP"
DO ^DIE
+23 SET DR="19////^S X=DT"
DO ^DIE
+24 SET DR="20////^S X=SDWLDUZ"
DO ^DIE
+25 SET DR="23////""C"""
DO ^DIE
End DoDot:3
End DoDot:2
End DoDot:1
+26 QUIT
END KILL SDWLA,SDWLMAX,SDWLTH,SDWLSCR,DIR,DIC,DIE,DR,SDWLPLST,SDWLDAX,DTOUT,SDWLCP3,SDWLINE
+1 KILL X,Y,Z,SDWLPLST,SDWLB,SDWLA,SDWLSX,SDWLS,SDWLVBR,SDWLVAR,SDWLSCR,SDWLF,SDWLYN,SDWLMPX
+2 QUIT
