source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCWAIT.m@ 1780

SCMCWAIT ;ALB/SCK - Broker Utilities for Placement on Wait List ; 30 Oct 2002  3:42 PM  ; Compiled May 25, 2007 09:07:17

 ;;5.3;Scheduling;**264,297,446**;AUG 13, 1993;Build 77

 ;

 Q

 ;

WAIT(SCOK,SC) ; Place patient on wait list

 ;  'SC BLD PAT CLN LIST'

 ;

 ;M ^JDS=SC

 N COMMENT,SDTM,SDCNT,SDINS,SDINTR,SDMTM,SDREJ,SDWLIN

 S TEAM=$G(SC("TEAM")),POS=$G(SC("POSITION")),DFN=$G(SC("DFN")),COMMENT=$G(SC("COMMENT")),SC=$G(SC("SC"))

 S SDWLIN=+$P($G(^SCTM(404.51,+$G(TEAM),0)),U,7),SDINTR=$G(SC("SDINTR")),SDREJ=$G(SC("SDREJ")),SDMTM=$G(SC("SDMTM"))

 ; check if transfer and if multiple teams in institution

 S SDCNT=0,SDINTR="",SDREJ="",SDMTM="",SDCC=TEAM

 ;identify INTRA-transfer

 ;- is patient assigned to PC provider?

 I 'POS&TEAM D PCPVER(DFN,.SDTM) D  ; return current PCP team or 0

 .I SDTM I $P($G(^SCTM(404.51,SDTM,0)),U,7)'=SDWLIN S SDINTR=1 ; inter transfer ; different institution

 .I 'SDTM S SDINS="" F  S SDINS=$O(^SCTM(404.51,"AINST",SDINS)) Q:SDINS=""  I SDINS'=SDWLIN D  Q:SDREJ

 ..;check available PCMM teams in other institutions and if so set up rejection flag

 ..N SDT S SDCNT=0,SDT=""

 ..F  S SDT=$O(^SCTM(404.51,"AINST",SDINS,SDT)) Q:SDT=""  D  Q:SDREJ

 ...I $$ACTTM^SCMCTMU(SDT)&($P($G(^SCTM(404.51,SDT,0)),U,5))&'$P($G(^SCTM(404.51,SDT,0)),U,10) D

 ...N SCTMCT S SCTMCT=$$TEAMCNT^SCAPMCU1(SDT) ;currently assigned

 ...N SCTMMAX 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

 I SDCNT>1 S SDMTM=1 S SDCC="" F  S SDCC=$O(TEAM(SDCC)) Q:SDCC=""  N DR,Y D WT Q

 I SDCNT'>1 D WT Q

WT N RES D INPUT^SDWLRP1(.RES,DFN_U_$S(POS:2,1:1)_U_SDCC_U_$S(POS:POS_U_DUZ,1:U_DUZ)_U_COMMENT_U_SC_U_SDINTR_U_SDREJ_U_SDMTM)

 I RES S SDWLRES=RES  ; 446

 Q

WAITS(DFN,TEAM,POS,SC) ; PLACE PATIENT ON WAIT LIST

 N SDCC,SDTEAM,SDINTR,SDMTM,SDREJ,SDWLIN,SDWLRES

 S SDTEAM=$G(TEAM)

 ; check if transfer and if multiple teams in institution

 S SDCNT=0,SDINTR="",SDREJ="",SDMTM="" I 'POS&TEAM D

 .S SDWLIN=$P($G(^SCTM(404.51,TEAM,0)),U,7)

 .;- is patient assigned to PC provider?

 I 'POS&TEAM D PCPVER(DFN,.SDTM) D  ; return current PCP team or 0

 .I SDTM I $P($G(^SCTM(404.51,SDTM,0)),U,7)'=SDWLIN S SDINTR=1 ; inter transfer ; different institution

 .I 'SDTM S SDINS="" F  S SDINS=$O(^SCTM(404.51,"AINST",SDINS)) Q:SDINS=""  I SDINS'=SDWLIN D  Q:SDREJ

 ..;check available PCMM teams in other institutions and if so set up rejection flag

 ..N SDT S SDCNT=0,SDT=""

 ..F  S SDT=$O(^SCTM(404.51,"AINST",SDINS,SDT)) Q:SDT=""  D  Q:SDREJ

 ...I $$ACTTM^SCMCTMU(SDT)&($P($G(^SCTM(404.51,SDT,0)),U,5))&'$P($G(^SCTM(404.51,SDT,0)),U,10) D

 ...N SCTMCT S SCTMCT=$$TEAMCNT^SCAPMCU1(SDT) ;currently assigned

 ...N SCTMMAX 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

 I SDCNT>1 S SDMTM=1 S SDCC="" F  S SDCC=$O(TEAM(SDCC)) Q:SDCC=""  S TEAM=SDCC N DR,Y S SDWLRES=$$WMT

 I SDCNT'>1 N DR,Y S SDWLRES=$$WMT

 S TEAM=$G(SDTEAM) Q $G(SDWLRES)

WMT() N RES

 D INPUT^SDWLRP1(.RES,DFN_U_$S(POS:2,1:1)_U_TEAM_U_$S(POS:POS_U_DUZ,1:U_DUZ)_"^^"_SC_U_SDINTR_U_SDREJ_U_SDMTM)

 I $G(RES) D

 .N DA,DIE,DIK,DR,OK

 .S SDWLRES=RES  ; 446

 .S OK=0,DA=+$P(RES,U,2),DIE="^SDWL(409.3,",DR="25;S OK=1"

 .D ^DIE

 .I 'OK S DIK=DIE D ^DIK W !,"Wait list entry deleted" S RES=0

 Q $G(RES)

TEAMRM(DFN,TEAM) ;

 N SDTM D PCPVER(DFN,.SDTM) I 'SDTM D CLONE(DFN,TEAM) Q  ;not PC panel assignment

 I SDTM'=TEAM D CLONE(DFN,TEAM) Q  ;TEAM IS NOT PCP

 ;close EWL entries only if assignment to PC panel, not necessarily to a team                                   

 N I

 F I=0:0 S I=$O(^SDWL(409.3,"B",+$G(DFN),I)) Q:'I  S A=$G(^SDWL(409.3,I,0)) D

 .I 12'[$P(A,U,5) Q

 .;I $P(A,U,6)'=$G(TEAM) Q

 .I $G(^SDWL(409.3,I,"DIS")) Q

 .;INACTIVATE I

 .N FDA S FDA(409.3,I_",",21)="SA"

 .S FDA(409.3,I_",",19)=DT,FDA(409.3,I_",",23)="C"

 .S FDA(409.3,I_",",20)=DUZ

 .D UPDATE^DIE("","FDA")

 Q

POSRM(TEAMP,POS) ;

 ; 

 S DFN=+$G(^SCPT(404.42,+$G(TEAMP),0))

 N SDTM D PCPVER(DFN,.SDTM) I 'SDTM D CLONE(DFN,TEAMP,POS) Q  ;not PC panel assignment

 I SDTM'=TEAMP D CLONE(DFN,TEAMP,POS) Q

 I $G(POS) I '$P($G(^SCPT(404.43,+POS,0)),U,5) Q   ;not pc

 I '$P($G(^SCPT(404.42,+$G(TEAMP),0)),U,8) Q   ;not pc

 ;S ^JDS("TEAMP")=TEAMP,^JDS("POS")=POS,^JDS("DFN")=DFN

 N I

 F I=0:0 S I=$O(^SDWL(409.3,"B",+$G(DFN),I)) Q:'I  S A=$G(^SDWL(409.3,I,0)) D

 .I 12'[$P(A,U,5) Q

 .;I $P(A,U,7)'=$G(POS) Q

 .I $G(^SDWL(409.3,I,"DIS")) Q

 .N FDA S FDA(409.3,I_",",21)="SA",FDA(409.3,I_",",23)="C"

 .S FDA(409.3,I_",",19)=DT

 .S FDA(409.3,I_",",20)=DUZ

 .D FILE^DIE("","FDA")

 .;INACTIVATE

 Q

CLONE(DFN,TEAM,POS) ;clean one entry only or two if position

 N I,SDONE S SDONE=0

 F I=0:0 S I=$O(^SDWL(409.3,"B",+$G(DFN),I)) Q:'I  S A=$G(^SDWL(409.3,I,0)) D  Q:SDONE

 .I 12'[$P(A,U,5) Q

 .I $P(A,U,5)=1 I $P(A,U,6)'=$G(TEAM) Q

 .I $P(A,U,5)=2 I $P(A,U,6)'=$G(POS) Q

 .I $G(^SDWL(409.3,I,"DIS")) Q

 .;INACTIVATE I

 .N FDA S FDA(409.3,I_",",21)="SA"

 .S FDA(409.3,I_",",19)=DT,FDA(409.3,I_",",23)="C"

 .S FDA(409.3,I_",",20)=DUZ

 .D UPDATE^DIE("","FDA")

 .S SDONE=1

 Q

PCPVER(DFN,SDTM) ;verify if PCP assignment

 S SDTM=0 ; return 0 if no PCP assignment

 K ^TMP("SDPCP",$J)

 N SDATE,SDPCP

 N SDI F SDI="BEGIN","END" S SDATE(SDI)=DT

 S SDATE="SDATE",SDPCP="^TMP(""SDPCP"",$J)"

 ;

 N SDI S SDI=$$GETALL^SCAPMCA(DFN,.SDATE,SDPCP)

 N SDII S SDII=0

 F  S SDII=$O(^TMP("SDPCP",$J,DFN,"PCPOS",SDII)) Q:'SDII  D

 .N SDX S SDX=^TMP("SDPCP",$J,DFN,"PCPOS",SDII)

 .I +$P(SDX,U,7)'=2 Q  ;PCP role

 .I +$P(SDX,U,6)>0&(+$P(SDX,U,6)<DT) Q

 .S SDTM=$P(SDX,U,3)

 Q

ONWAIT(DFN) ;is patient on wait list

 D DEM^VADPT I $G(VADM(6)) Q 9  ;Patient is dead

 N I,X

 S X=0

 F I=0:0 S I=$O(^SDWL(409.3,"B",+$G(DFN),I)) Q:'I  S A=$G(^SDWL(409.3,I,0)) D  Q:X

 .I 12'[$P(A,U,5) Q

 .I $G(^SDWL(409.3,I,"DIS")) Q

 .S X="3;ON WAITLIST TEAM: "_$P($G(^SCTM(404.51,+$P(A,U,6),0)),U)

 .I $P(A,U,7) S X=X_" POSITION: "_$P($G(^SCTM(404.57,+$P(A,U,7),0)),U)

 I X Q X

 ;Q X

 ;CHECK IF ON TEAM

 N SCD,SCDT,SCOK S SCOK=$$TMPT^SCAPMC3(DFN,"SCDT","","SCD","SCER1") I $D(SCD(1)) S X=1

 N SCPOS S SCOK=$$TPPT^SCAPMC(DFN,.SCDT,"","","","","","SCPOS","SCBKERR") I $D(SCPOS(1)) S X=2

 Q X

 ;CHECK IF ON POSITION

SORT ;From sort template

 S X=0

 Q

PC(RESULT,POS) ;rpc to see if provider can be pc

 N POENT,RES

 D ROLE(.RES,POS) I RES=1 S RESULT(0)=0 Q

 S POENT=+$O(^SCTM(404.52,"AIDT",+$G(POS),1,-(DT+.1))),POENT=$O(^(POENT,0))

 ;S PROV=+$P($G(^SCTM(404.52,+$G(POENT),0)),U,3)

 I 'POENT S RESULT(0)=1 Q

 N D0 S D0=+$G(POENT) D SORT S RESULT(0)=X

 Q

ROLE(RESULT,POS) ;rpc to see if role of position is resident

 N ZERO S ZERO=$G(^SCTM(404.57,+$G(POS),0))

 I $P(ZERO,U,4) S RESULT=0 Q  ;Already pc let them change it.

 S RESULT=0

 I $P($G(^SD(403.46,+$P(ZERO,U,3),0)),U)="RESIDENT (PHYSICIAN)" S RESULT=1

 Q

SC(DFN) ;Is patient 0-50 sc%

 N TEAM,INST S TEAM=$P(DFN,U,2),INST=+$P($G(^SCTM(404.51,+TEAM,0)),U,7)

 S X=0,DFN=+DFN

 N A D ELIG^VADPT S A=$G(VAEL(3)) I $P(A,U)'="Y" Q 0

 I $P(A,U,2)<50 Q $P(A,U,2)

 Q 0

SCLI(RESULT,SC) ;sc sc list

 K RESULT N RES

 S DFN=+$G(SC("DFN"))

 D SDSC^SDWLRP3(.RES,DFN) I RES=-1 S RESULT(0)=-1 Q

 S RESULT(0)="<RESULTS>" N CNT,I S CNT=1 F I=0:0 S I=$O(^TMP("SDWLRP3",$J,I)) Q:'I  S RESULT(CNT)=^(I),CNT=CNT+1