Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDWLPL

SDWLPL.m

Go to the documentation of this file.
  1. SDWLPL ;IOFO BAY PINES/DMR,ESW - WAIT LIST PICK LIST ;JAN 15, 2016
  1. ;;5.3;scheduling;**327,394,417,446,538,627**;AUG 13, 1993;Build 249
  1. ;
  1. ;
  1. ;09/23/2006 Patch SD*5.3*417 Upper/Lower case usage.
  1. ;SD*5.3*446 - Included M - matched appointments
  1. ;
  1. I '$D(^SDWL(409.3,"B",DFN)) Q
  1. S NN=""
  1. W !,"This patient is currently on the Wait List."
  1. ;
  1. ANS1 ;
  1. S DIR("B")="NO",DIR("A")="Do you want to display open Wait list entries? (Y or N): ",DIR(0)="Y^AO" D ^DIR
  1. K DIR
  1. Q:'Y
  1. ;
  1. ANS2(DFN,ANS2) ;
  1. N STR S ANS2=" ",STR=",A,S,C,"
  1. F Q:STR[ANS2!(ANS2="^") D
  1. TST .W !!,"Display Open Wait List entries selection:",!
  1. .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
  1. .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."
  1. K DIR
  1. Q:ANS2="^"
  1. D INIT(DFN,ANS2) I '$D(^TMP($J,"SDWLPL")) W !!,"No selected open EWL entry has been found!" Q
  1. DISPLAY ;
  1. D LIST(ANS2,DFN)
  1. Q
  1. ;
  1. INIT(DFN,ANS2,FLG) ;
  1. ; ANS2: A - ALL
  1. ; S - All Specialties
  1. ; C - All Clinics
  1. ; M - Matches stop codes only
  1. ; FLG: (optional)
  1. ; NR - do not diplay entries with NON REMOVAL REASON - in check out
  1. S (INST,SCODE,CLINIC,DENTER,REQBY,DESIRD,SCPRI,IEN,SSN)="" K ^TMP("SDWLPL",$J),^TMP($J,"SDWLPL")
  1. F S IEN=$O(^SDWL(409.3,"B",DFN,IEN)) Q:IEN="" D
  1. .Q:$$GET1^DIQ(409.3,IEN_",",23,"I")="C"
  1. .;I $G(FLG)="NR" Q:$$GET1^DIQ(409.3,IEN_",",18,"I")'="" ; include non-removed for 'NR flag
  1. .;Q:$$GET1^DIQ(409.3,IEN_",",18,"I")'="" ;
  1. .Q:$D(^XTMP("SDECLKE-"_IEN)) ;do not display EWL if locked by VS GUI ;alb/sat 627
  1. .S ^TMP("SDWLPL",$J,IEN)=$G(^SDWL(409.3,IEN,0)) S DENTER="",DENTER=$P($G(^TMP("SDWLPL",$J,IEN)),"^",2)
  1. .S (WLTYPE,TYPE,WLTN,NUM)="",TYPE=$P($G(^TMP("SDWLPL",$J,IEN)),"^",5)
  1. .IF DENTER'=""&(TYPE'="") D
  1. ..IF ANS2="A" D ARAY1
  1. ..IF ANS2="S" D ARAY2
  1. ..IF ANS2="C" D ARAY3
  1. ..IF ANS2="M" D ARAY4
  1. ;
  1. K ANS1,NN,INST,SCODE,CLINIC,DENTER,REQBY,DESIRD,SCPRI
  1. K CLINIC,WLTYPE,TYPE,WLTN,NUM,REC
  1. Q
  1. ;
  1. ARAY1 ;
  1. 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)
  1. 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)
  1. 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)
  1. 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)
  1. D SAVE(TYPE,WLTNI,IEN)
  1. Q
  1. ;
  1. ARAY2 ;
  1. IF TYPE=3 D
  1. .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)
  1. .;Q:SCODE'=WLTNI
  1. .S WLTYPE="SERV/SPECIAL"
  1. .D SAVE(TYPE,WLTNI,IEN)
  1. Q
  1. ;
  1. ARAY3 ;
  1. IF TYPE=4 D
  1. .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)
  1. .;Q:CLINIC'=WLTNI
  1. .S WLTYPE="CLINIC"
  1. .D SAVE(TYPE,WLTNI,IEN)
  1. Q
  1. ARAY4 ;identify both clinic and specialties EWL matching by stop code with entered appointment
  1. S SCODE=+$P($G(^TMP($J,"APPT",1)),U,13)
  1. IF TYPE=3 D Q
  1. .S NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",8),WLTNI=$$GET1^DIQ(409.31,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(409.31,NUM_",",.01)
  1. .Q:SCODE'=WLTNI
  1. .S WLTYPE="SERV/SPECIAL"
  1. .D SAVE(TYPE,WLTNI,IEN)
  1. IF TYPE=4 D
  1. .N SDCLSC
  1. .S NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",9),WLTNI=$$GET1^DIQ(409.32,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(409.32,NUM_",",.01)
  1. .S SDCLSC=$$GET1^DIQ(44,WLTNI_",",8,"I") ; STOP CODE
  1. .Q:SCODE'=SDCLSC
  1. .S WLTYPE="CLINIC"
  1. .D SAVE(TYPE,WLTNI,IEN)
  1. Q
  1. ;
  1. SAVE(TYPE,WLTNI,IEN) ;
  1. S REQBY=$P($G(^TMP("SDWLPL",$J,IEN)),"^",12)
  1. S INST=$P($G(^TMP("SDWLPL",$J,IEN)),"^",3)
  1. N DESIRED S DESIRED=$P($G(^TMP("SDWLPL",$J,IEN)),"^",16)
  1. S SCPRI=$E($$GET1^DIQ(409.3,IEN_",",15)) ;SC priority
  1. N NAME,SSN S NAME=$$GET1^DIQ(2,DFN_",",.01),SSN=$$GET1^DIQ(2,DFN_",",.09)
  1. N SDBY S SDBY=$$GET1^DIQ(409.3,IEN_",",11),SDBY=$E(SDBY,1,3)
  1. N SDNR S SDNR=$$GET1^DIQ(409.3,IEN_",",18,"E") ; non removal reason
  1. S NN=$O(^TMP($J,"SDWLPL",""),-1)+1
  1. S ^TMP($J,"SDWLPL",NN)=IEN_U_WLTYPE_U_SCPRI_U_WLTN_U_INST_U_DENTER_U_SDBY_U_DESIRED
  1. ;
  1. N SPIEC S SPIEC=$S(TYPE=4:9,TYPE=3:10,TYPE=2:11,TYPE=1:12)
  1. S $P(^TMP($J,"SDWLPL",NN),U,SPIEC)=WLTNI
  1. S $P(^TMP($J,"SDWLPL",NN),U,13)=SDNR
  1. K ^TMP("SDWLPL",$J,IEN)
  1. Q
  1. ;
  1. LIST(ANS2,DFN) ;
  1. W:$D(IOF) @IOF
  1. ;D APPTD^SDWLEVAL ;display appointment(s) again
  1. W !,"=========================================================================="
  1. N NAME,SSN S NAME=$$GET1^DIQ(2,DFN_",",.01),SSN=$$GET1^DIQ(2,DFN_",",.09)
  1. ;W !!,$S(ANS2="A":" All",ANS2="C":" All Clinics",ANS2="M":" Matched Entries:",ANS2="S":" All Specialties",1:" All")
  1. W !," Open EWL entries matching appointment specialty"
  1. W !,"------------------------------" I ANS2'="A" W "-----------"
  1. W !,"EW List Type SC/P Waiting for Institution Orig Date By Des. Date Reopen"
  1. W !,"--------------------------------------------------------------------------------"
  1. S (REC,NUM)=""
  1. F S NUM=$O(^TMP($J,"SDWLPL",NUM)) Q:NUM="" S REC=^TMP($J,"SDWLPL",NUM) D
  1. .S IEN=+REC N SDP,SDR D
  1. ..S SDP=$E($$GET1^DIQ(409.3,IEN_",",10)) ;priority
  1. ..S SDR=$$GET1^DIQ(409.3,IEN_",",29,"I") ;reopen reason
  1. .N SDINS,SDIN S SDINS=$P(REC,"^",5) S SDIN=$$GET1^DIQ(4,SDINS_",",.01,"I")
  1. .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
  1. .N SDUP,SDLO
  1. .S SDUP="ABCDEFGHIJKLMNOPRSTUWQXYzv",SDLO="abcdefghijklmnoprstuwqxyzv"
  1. .N SMT S SMT=$$GET1^DIQ(409.3,IEN_",",25) I SMT'="" S SMT=$TR(SMT,SDUP,SDLO) W !?2,"Comment: ",SMT
  1. .N SMO S SMO=$$GET1^DIQ(409.3,IEN_",",30) I SMO'="" S SMO=$TR(SMO,SDUP,SDLO) W !?2,"Reopen: ",SMO
  1. .I $P(REC,U,13)'="" W !?2,"Non-Removal Reason: ",$P(REC,U,13)
  1. Q