SDWLPL ;IOFO BAY PINES/DMR,ESW - WAIT LIST PICK LIST ; December 10, 2008 10:46:16 ; ; Compiled December 12, 2008 12:59:34
;;5.3;PIMS;**327,394,417,446,1015,1016**;JUN 30, 2012;Build 20
;
;
;09/23/2006 Patch SD*5.3*417 Upper/Lower case usage.
;SD*5.3*446 - Included M - matched appointments
;
I '$D(^SDWL(409.3,"B",DFN)) Q
S NN=""
W !,"This patient is currently on the Wait List."
;
ANS1 ;
S DIR("B")="NO",DIR("A")="Do you want to display open Wait list entries? (Y or N): ",DIR(0)="Y^AO" D ^DIR
K DIR
Q:'Y
;
ANS2(DFN,ANS2) ;
N STR S ANS2=" ",STR=",A,S,C,"
F Q:STR[ANS2!(ANS2="^") D
TST .W !!,"Display Open Wait List entries selection:",!
.S DIR(0)="S^A:ALL;C:Matching Appt CLINIC;S:matching Appt SPECIALTY",DIR("B")="A",DIR("A")="Select Entry or ""^"" to QUIT " D ^DIR S ANS2=Y
.IF ANS2'="A"&(ANS2'="S")&(ANS2'="C")&(ANS2'="^") W !!,"PLEASE ENTER 'A' for All entries, 'C' for clinic or 'S' for current specialty/stop code or '^' to quit."
K DIR
Q:ANS2="^"
D INIT(DFN,ANS2) I '$D(^TMP($J,"SDWLPL")) W !!,"No selected open EWL entry has been found!" Q
DISPLAY ;
D LIST(ANS2,DFN)
Q
;
INIT(DFN,ANS2,FLG) ;
; ANS2: A - ALL
; S - All Specialties
; C - All Clinics
; M - Matches stop codes only
; FLG: (optional)
; NR - do not diplay entries with NON REMOVAL REASON - in check out
S (INST,SCODE,CLINIC,DENTER,REQBY,DESIRD,SCPRI,IEN,SSN)="" K ^TMP("SDWLPL",$J),^TMP($J,"SDWLPL")
F S IEN=$O(^SDWL(409.3,"B",DFN,IEN)) Q:IEN="" D
.Q:$$GET1^DIQ(409.3,IEN_",",23,"I")="C"
.;I $G(FLG)="NR" Q:$$GET1^DIQ(409.3,IEN_",",18,"I")'="" ; include non-removed for 'NR flag
.;Q:$$GET1^DIQ(409.3,IEN_",",18,"I")'="" ;
.S ^TMP("SDWLPL",$J,IEN)=$G(^SDWL(409.3,IEN,0)) S DENTER="",DENTER=$P($G(^TMP("SDWLPL",$J,IEN)),"^",2)
.S (WLTYPE,TYPE,WLTN,NUM)="",TYPE=$P($G(^TMP("SDWLPL",$J,IEN)),"^",5)
.IF DENTER'=""&(TYPE'="") D
..IF ANS2="A" D ARAY1
..IF ANS2="S" D ARAY2
..IF ANS2="C" D ARAY3
..IF ANS2="M" D ARAY4
;
K ANS1,NN,INST,SCODE,CLINIC,DENTER,REQBY,DESIRD,SCPRI
K CLINIC,WLTYPE,TYPE,WLTN,NUM,REC
Q
;
ARAY1 ;
IF TYPE=1 S WLTYPE="PCMM TEAM",NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",6),WLTNI=$$GET1^DIQ(404.51,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(404.51,NUM_",",.01)
IF TYPE=2 S WLTYPE="PCMM POSITION",NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",7),WLTNI=$$GET1^DIQ(404.57,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(404.57,NUM_",",.01)
IF TYPE=3 S WLTYPE="SERV/SPECIALTY",NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",8),WLTNI=$$GET1^DIQ(409.31,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(409.31,NUM_",",.01)
IF TYPE=4 S WLTYPE="CLINIC",NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",9),WLTNI=$$GET1^DIQ(409.32,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(409.32,NUM_",",.01)
D SAVE(TYPE,WLTNI,IEN)
Q
;
ARAY2 ;
IF TYPE=3 D
.S SCODE=+$P($G(^TMP($J,"APPT",1)),U,13),NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",8),WLTNI=$$GET1^DIQ(409.31,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(409.31,NUM_",",.01)
.;Q:SCODE'=WLTNI
.S WLTYPE="SERV/SPECIAL"
.D SAVE(TYPE,WLTNI,IEN)
Q
;
ARAY3 ;
IF TYPE=4 D
.S CLINIC=+$P($G(^TMP($J,"APPT",1)),U,2),NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",9),WLTNI=$$GET1^DIQ(409.32,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(409.32,NUM_",",.01)
.;Q:CLINIC'=WLTNI
.S WLTYPE="CLINIC"
.D SAVE(TYPE,WLTNI,IEN)
Q
ARAY4 ;identify both clinic and specialties EWL matching by stop code with entered appointment
S SCODE=+$P($G(^TMP($J,"APPT",1)),U,13)
IF TYPE=3 D Q
.S NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",8),WLTNI=$$GET1^DIQ(409.31,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(409.31,NUM_",",.01)
.Q:SCODE'=WLTNI
.S WLTYPE="SERV/SPECIAL"
.D SAVE(TYPE,WLTNI,IEN)
IF TYPE=4 D
.N SDCLSC
.S NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",9),WLTNI=$$GET1^DIQ(409.32,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(409.32,NUM_",",.01)
.S SDCLSC=$$GET1^DIQ(44,WLTNI_",",8,"I") ; STOP CODE
.Q:SCODE'=SDCLSC
.S WLTYPE="CLINIC"
.D SAVE(TYPE,WLTNI,IEN)
Q
;
SAVE(TYPE,WLTNI,IEN) ;
S REQBY=$P($G(^TMP("SDWLPL",$J,IEN)),"^",12)
S INST=$P($G(^TMP("SDWLPL",$J,IEN)),"^",3)
N DESIRED S DESIRED=$P($G(^TMP("SDWLPL",$J,IEN)),"^",16)
S SCPRI=$E($$GET1^DIQ(409.3,IEN_",",15)) ;SC priority
N NAME,SSN S NAME=$$GET1^DIQ(2,DFN_",",.01),SSN=$$GET1^DIQ(2,DFN_",",.09)
N SDBY S SDBY=$$GET1^DIQ(409.3,IEN_",",11),SDBY=$E(SDBY,1,3)
N SDNR S SDNR=$$GET1^DIQ(409.3,IEN_",",18,"E") ; non removal reason
S NN=$O(^TMP($J,"SDWLPL",""),-1)+1
S ^TMP($J,"SDWLPL",NN)=IEN_U_WLTYPE_U_SCPRI_U_WLTN_U_INST_U_DENTER_U_SDBY_U_DESIRED
;
N SPIEC S SPIEC=$S(TYPE=4:9,TYPE=3:10,TYPE=2:11,TYPE=1:12)
S $P(^TMP($J,"SDWLPL",NN),U,SPIEC)=WLTNI
S $P(^TMP($J,"SDWLPL",NN),U,13)=SDNR
K ^TMP("SDWLPL",$J,IEN)
Q
;
LIST(ANS2,DFN) ;
W:$D(IOF) @IOF
;D APPTD^SDWLEVAL ;display appointment(s) again
W !,"=========================================================================="
N NAME,SSN S NAME=$$GET1^DIQ(2,DFN_",",.01),SSN=$$GET1^DIQ(2,DFN_",",.09)
;W !!,$S(ANS2="A":" All",ANS2="C":" All Clinics",ANS2="M":" Matched Entries:",ANS2="S":" All Specialties",1:" All")
W !," Open EWL entries matching appointment specialty"
W !,"------------------------------" I ANS2'="A" W "-----------"
W !,"EW List Type SC/P Waiting for Institution Orig Date By Des. Date Reopen"
W !,"--------------------------------------------------------------------------------"
S (REC,NUM)=""
F S NUM=$O(^TMP($J,"SDWLPL",NUM)) Q:NUM="" S REC=^TMP($J,"SDWLPL",NUM) D
.S IEN=+REC N SDP,SDR D
..S SDP=$E($$GET1^DIQ(409.3,IEN_",",10)) ;priority
..S SDR=$$GET1^DIQ(409.3,IEN_",",29,"I") ;reopen reason
.N SDINS,SDIN S SDINS=$P(REC,"^",5) S SDIN=$$GET1^DIQ(4,SDINS_",",.01,"I")
.W !,NUM_". ",$E($P(REC,"^",2),1,12),?16,$P(REC,"^",3)_"/"_SDP,?21,$E($P(REC,U,4),1,13),?35,SDIN,?47,$$FMTE^XLFDT($P(REC,"^",6),8),?59,$P(REC,"^",7),?63,$$FMTE^XLFDT($P(REC,"^",8),8),?77,SDR
.N SDUP,SDLO
.S SDUP="ABCDEFGHIJKLMNOPRSTUWQXYzv",SDLO="abcdefghijklmnoprstuwqxyzv"
.N SMT S SMT=$$GET1^DIQ(409.3,IEN_",",25) I SMT'="" S SMT=$TR(SMT,SDUP,SDLO) W !?2,"Comment: ",SMT
.N SMO S SMO=$$GET1^DIQ(409.3,IEN_",",30) I SMO'="" S SMO=$TR(SMO,SDUP,SDLO) W !?2,"Reopen: ",SMO
.I $P(REC,U,13)'="" W !?2,"Non-Removal Reason: ",$P(REC,U,13)
Q
SDWLPL ;IOFO BAY PINES/DMR,ESW - WAIT LIST PICK LIST ; December 10, 2008 10:46:16 ; ; Compiled December 12, 2008 12:59:34
+1 ;;5.3;PIMS;**327,394,417,446,1015,1016**;JUN 30, 2012;Build 20
+2 ;
+3 ;
+4 ;09/23/2006 Patch SD*5.3*417 Upper/Lower case usage.
+5 ;SD*5.3*446 - Included M - matched appointments
+6 ;
+7 IF '$DATA(^SDWL(409.3,"B",DFN))
QUIT
+8 SET NN=""
+9 WRITE !,"This patient is currently on the Wait List."
+10 ;
ANS1 ;
+1 SET DIR("B")="NO"
SET DIR("A")="Do you want to display open Wait list entries? (Y or N): "
SET DIR(0)="Y^AO"
DO ^DIR
+2 KILL DIR
+3 IF 'Y
QUIT
+4 ;
ANS2(DFN,ANS2) ;
+1 NEW STR
SET ANS2=" "
SET STR=",A,S,C,"
+2 FOR
IF STR[ANS2!(ANS2="^")
QUIT
Begin DoDot:1
TST WRITE !!,"Display Open Wait List entries selection:",!
+1 SET DIR(0)="S^A:ALL;C:Matching Appt CLINIC;S:matching Appt SPECIALTY"
SET DIR("B")="A"
SET DIR("A")="Select Entry or ""^"" to QUIT "
DO ^DIR
SET ANS2=Y
+2 IF ANS2'="A"&(ANS2'="S")&(ANS2'="C")&(ANS2'="^")
WRITE !!,"PLEASE ENTER 'A' for All entries, 'C' for clinic or 'S' for current specialty/stop code or '^' to quit."
End DoDot:1
+3 KILL DIR
+4 IF ANS2="^"
QUIT
+5 DO INIT(DFN,ANS2)
IF '$DATA(^TMP($JOB,"SDWLPL"))
WRITE !!,"No selected open EWL entry has been found!"
QUIT
DISPLAY ;
+1 DO LIST(ANS2,DFN)
+2 QUIT
+3 ;
INIT(DFN,ANS2,FLG) ;
+1 ; ANS2: A - ALL
+2 ; S - All Specialties
+3 ; C - All Clinics
+4 ; M - Matches stop codes only
+5 ; FLG: (optional)
+6 ; NR - do not diplay entries with NON REMOVAL REASON - in check out
+7 SET (INST,SCODE,CLINIC,DENTER,REQBY,DESIRD,SCPRI,IEN,SSN)=""
KILL ^TMP("SDWLPL",$JOB),^TMP($JOB,"SDWLPL")
+8 FOR
SET IEN=$ORDER(^SDWL(409.3,"B",DFN,IEN))
IF IEN=""
QUIT
Begin DoDot:1
+9 IF $$GET1^DIQ(409.3,IEN_",",23,"I")="C"
QUIT
+10 ;I $G(FLG)="NR" Q:$$GET1^DIQ(409.3,IEN_",",18,"I")'="" ; include non-removed for 'NR flag
+11 ;Q:$$GET1^DIQ(409.3,IEN_",",18,"I")'="" ;
+12 SET ^TMP("SDWLPL",$JOB,IEN)=$GET(^SDWL(409.3,IEN,0))
SET DENTER=""
SET DENTER=$PIECE($GET(^TMP("SDWLPL",$JOB,IEN)),"^",2)
+13 SET (WLTYPE,TYPE,WLTN,NUM)=""
SET TYPE=$PIECE($GET(^TMP("SDWLPL",$JOB,IEN)),"^",5)
+14 IF DENTER'=""&(TYPE'="")
Begin DoDot:2
+15 IF ANS2="A"
DO ARAY1
+16 IF ANS2="S"
DO ARAY2
+17 IF ANS2="C"
DO ARAY3
+18 IF ANS2="M"
DO ARAY4
End DoDot:2
End DoDot:1
+19 ;
+20 KILL ANS1,NN,INST,SCODE,CLINIC,DENTER,REQBY,DESIRD,SCPRI
+21 KILL CLINIC,WLTYPE,TYPE,WLTN,NUM,REC
+22 QUIT
+23 ;
ARAY1 ;
+1 IF TYPE=1
SET WLTYPE="PCMM TEAM"
SET NUM=$PIECE($GET(^TMP("SDWLPL",$JOB,IEN)),"^",6)
SET WLTNI=$$GET1^DIQ(404.51,NUM_",",.01,"I")
SET WLTN=$$GET1^DIQ(404.51,NUM_",",.01)
+2 IF TYPE=2
SET WLTYPE="PCMM POSITION"
SET NUM=$PIECE($GET(^TMP("SDWLPL",$JOB,IEN)),"^",7)
SET WLTNI=$$GET1^DIQ(404.57,NUM_",",.01,"I")
SET WLTN=$$GET1^DIQ(404.57,NUM_",",.01)
+3 IF TYPE=3
SET WLTYPE="SERV/SPECIALTY"
SET NUM=$PIECE($GET(^TMP("SDWLPL",$JOB,IEN)),"^",8)
SET WLTNI=$$GET1^DIQ(409.31,NUM_",",.01,"I")
SET WLTN=$$GET1^DIQ(409.31,NUM_",",.01)
+4 IF TYPE=4
SET WLTYPE="CLINIC"
SET NUM=$PIECE($GET(^TMP("SDWLPL",$JOB,IEN)),"^",9)
SET WLTNI=$$GET1^DIQ(409.32,NUM_",",.01,"I")
SET WLTN=$$GET1^DIQ(409.32,NUM_",",.01)
+5 DO SAVE(TYPE,WLTNI,IEN)
+6 QUIT
+7 ;
ARAY2 ;
+1 IF TYPE=3
Begin DoDot:1
+2 SET SCODE=+$PIECE($GET(^TMP($JOB,"APPT",1)),U,13)
SET NUM=$PIECE($GET(^TMP("SDWLPL",$JOB,IEN)),"^",8)
SET WLTNI=$$GET1^DIQ(409.31,NUM_",",.01,"I")
SET WLTN=$$GET1^DIQ(409.31,NUM_",",.01)
+3 ;Q:SCODE'=WLTNI
+4 SET WLTYPE="SERV/SPECIAL"
+5 DO SAVE(TYPE,WLTNI,IEN)
End DoDot:1
+6 QUIT
+7 ;
ARAY3 ;
+1 IF TYPE=4
Begin DoDot:1
+2 SET CLINIC=+$PIECE($GET(^TMP($JOB,"APPT",1)),U,2)
SET NUM=$PIECE($GET(^TMP("SDWLPL",$JOB,IEN)),"^",9)
SET WLTNI=$$GET1^DIQ(409.32,NUM_",",.01,"I")
SET WLTN=$$GET1^DIQ(409.32,NUM_",",.01)
+3 ;Q:CLINIC'=WLTNI
+4 SET WLTYPE="CLINIC"
+5 DO SAVE(TYPE,WLTNI,IEN)
End DoDot:1
+6 QUIT
ARAY4 ;identify both clinic and specialties EWL matching by stop code with entered appointment
+1 SET SCODE=+$PIECE($GET(^TMP($JOB,"APPT",1)),U,13)
+2 IF TYPE=3
Begin DoDot:1
+3 SET NUM=$PIECE($GET(^TMP("SDWLPL",$JOB,IEN)),"^",8)
SET WLTNI=$$GET1^DIQ(409.31,NUM_",",.01,"I")
SET WLTN=$$GET1^DIQ(409.31,NUM_",",.01)
+4 IF SCODE'=WLTNI
QUIT
+5 SET WLTYPE="SERV/SPECIAL"
+6 DO SAVE(TYPE,WLTNI,IEN)
End DoDot:1
QUIT
+7 IF TYPE=4
Begin DoDot:1
+8 NEW SDCLSC
+9 SET NUM=$PIECE($GET(^TMP("SDWLPL",$JOB,IEN)),"^",9)
SET WLTNI=$$GET1^DIQ(409.32,NUM_",",.01,"I")
SET WLTN=$$GET1^DIQ(409.32,NUM_",",.01)
+10 ; STOP CODE
SET SDCLSC=$$GET1^DIQ(44,WLTNI_",",8,"I")
+11 IF SCODE'=SDCLSC
QUIT
+12 SET WLTYPE="CLINIC"
+13 DO SAVE(TYPE,WLTNI,IEN)
End DoDot:1
+14 QUIT
+15 ;
SAVE(TYPE,WLTNI,IEN) ;
+1 SET REQBY=$PIECE($GET(^TMP("SDWLPL",$JOB,IEN)),"^",12)
+2 SET INST=$PIECE($GET(^TMP("SDWLPL",$JOB,IEN)),"^",3)
+3 NEW DESIRED
SET DESIRED=$PIECE($GET(^TMP("SDWLPL",$JOB,IEN)),"^",16)
+4 ;SC priority
SET SCPRI=$EXTRACT($$GET1^DIQ(409.3,IEN_",",15))
+5 NEW NAME,SSN
SET NAME=$$GET1^DIQ(2,DFN_",",.01)
SET SSN=$$GET1^DIQ(2,DFN_",",.09)
+6 NEW SDBY
SET SDBY=$$GET1^DIQ(409.3,IEN_",",11)
SET SDBY=$EXTRACT(SDBY,1,3)
+7 ; non removal reason
NEW SDNR
SET SDNR=$$GET1^DIQ(409.3,IEN_",",18,"E")
+8 SET NN=$ORDER(^TMP($JOB,"SDWLPL",""),-1)+1
+9 SET ^TMP($JOB,"SDWLPL",NN)=IEN_U_WLTYPE_U_SCPRI_U_WLTN_U_INST_U_DENTER_U_SDBY_U_DESIRED
+10 ;
+11 NEW SPIEC
SET SPIEC=$SELECT(TYPE=4:9,TYPE=3:10,TYPE=2:11,TYPE=1:12)
+12 SET $PIECE(^TMP($JOB,"SDWLPL",NN),U,SPIEC)=WLTNI
+13 SET $PIECE(^TMP($JOB,"SDWLPL",NN),U,13)=SDNR
+14 KILL ^TMP("SDWLPL",$JOB,IEN)
+15 QUIT
+16 ;
LIST(ANS2,DFN) ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 ;D APPTD^SDWLEVAL ;display appointment(s) again
+3 WRITE !,"=========================================================================="
+4 NEW NAME,SSN
SET NAME=$$GET1^DIQ(2,DFN_",",.01)
SET SSN=$$GET1^DIQ(2,DFN_",",.09)
+5 ;W !!,$S(ANS2="A":" All",ANS2="C":" All Clinics",ANS2="M":" Matched Entries:",ANS2="S":" All Specialties",1:" All")
+6 WRITE !," Open EWL entries matching appointment specialty"
+7 WRITE !,"------------------------------"
IF ANS2'="A"
WRITE "-----------"
+8 WRITE !,"EW List Type SC/P Waiting for Institution Orig Date By Des. Date Reopen"
+9 WRITE !,"--------------------------------------------------------------------------------"
+10 SET (REC,NUM)=""
+11 FOR
SET NUM=$ORDER(^TMP($JOB,"SDWLPL",NUM))
IF NUM=""
QUIT
SET REC=^TMP($JOB,"SDWLPL",NUM)
Begin DoDot:1
+12 SET IEN=+REC
NEW SDP,SDR
Begin DoDot:2
+13 ;priority
SET SDP=$EXTRACT($$GET1^DIQ(409.3,IEN_",",10))
+14 ;reopen reason
SET SDR=$$GET1^DIQ(409.3,IEN_",",29,"I")
End DoDot:2
+15 NEW SDINS,SDIN
SET SDINS=$PIECE(REC,"^",5)
SET SDIN=$$GET1^DIQ(4,SDINS_",",.01,"I")
+16 WRITE !,NUM_". ",$EXTRACT($PIECE(REC,"^",2),1,12),?16,$PIECE(REC,"^",3)_"/"_SDP,?21,$EXTRACT($PIECE(REC,U,4),1,13),?35,SDIN,?47,$$FMTE^XLFDT($PIECE(REC,"^",6),8),?59,$PIECE(REC,"^",7),?63,$$FMTE^XLFDT($PIECE(REC,"^",8),8),?77,SDR
+17 NEW SDUP,SDLO
+18 SET SDUP="ABCDEFGHIJKLMNOPRSTUWQXYzv"
SET SDLO="abcdefghijklmnoprstuwqxyzv"
+19 NEW SMT
SET SMT=$$GET1^DIQ(409.3,IEN_",",25)
IF SMT'=""
SET SMT=$TRANSLATE(SMT,SDUP,SDLO)
WRITE !?2,"Comment: ",SMT
+20 NEW SMO
SET SMO=$$GET1^DIQ(409.3,IEN_",",30)
IF SMO'=""
SET SMO=$TRANSLATE(SMO,SDUP,SDLO)
WRITE !?2,"Reopen: ",SMO
+21 IF $PIECE(REC,U,13)'=""
WRITE !?2,"Non-Removal Reason: ",$PIECE(REC,U,13)
End DoDot:1
+22 QUIT
