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

SCMCWAIT.m

Go to the documentation of this file.
  1. SCMCWAIT ;ALB/SCK - Broker Utilities for Placement on Wait List ; 30 Oct 2002 3:42 PM ; Compiled May 25, 2007 09:07:17
  1. ;;5.3;Scheduling;**264,297,446**;AUG 13, 1993;Build 77
  1. ;
  1. Q
  1. ;
  1. WAIT(SCOK,SC) ; Place patient on wait list
  1. ; 'SC BLD PAT CLN LIST'
  1. ;
  1. ;M ^JDS=SC
  1. N COMMENT,SDTM,SDCNT,SDINS,SDINTR,SDMTM,SDREJ,SDWLIN
  1. S TEAM=$G(SC("TEAM")),POS=$G(SC("POSITION")),DFN=$G(SC("DFN")),COMMENT=$G(SC("COMMENT")),SC=$G(SC("SC"))
  1. S SDWLIN=+$P($G(^SCTM(404.51,+$G(TEAM),0)),U,7),SDINTR=$G(SC("SDINTR")),SDREJ=$G(SC("SDREJ")),SDMTM=$G(SC("SDMTM"))
  1. ; check if transfer and if multiple teams in institution
  1. S SDCNT=0,SDINTR="",SDREJ="",SDMTM="",SDCC=TEAM
  1. ;identify INTRA-transfer
  1. ;- is patient assigned to PC provider?
  1. I 'POS&TEAM D PCPVER(DFN,.SDTM) D ; return current PCP team or 0
  1. .I SDTM I $P($G(^SCTM(404.51,SDTM,0)),U,7)'=SDWLIN S SDINTR=1 ; inter transfer ; different institution
  1. .I 'SDTM S SDINS="" F S SDINS=$O(^SCTM(404.51,"AINST",SDINS)) Q:SDINS="" I SDINS'=SDWLIN D Q:SDREJ
  1. ..;check available PCMM teams in other institutions and if so set up rejection flag
  1. ..N SDT S SDCNT=0,SDT=""
  1. ..F S SDT=$O(^SCTM(404.51,"AINST",SDINS,SDT)) Q:SDT="" D Q:SDREJ
  1. ...I $$ACTTM^SCMCTMU(SDT)&($P($G(^SCTM(404.51,SDT,0)),U,5))&'$P($G(^SCTM(404.51,SDT,0)),U,10) D
  1. ...N SCTMCT S SCTMCT=$$TEAMCNT^SCAPMCU1(SDT) ;currently assigned
  1. ...N SCTMMAX S SCTMMAX=$P($$GETEAM^SCAPMCU3(SDT),"^",8) ;maximum set
  1. ...I SCTMCT<SCTMMAX S SDREJ=1
  1. ..;find all teams from institution SDWLIN
  1. .I SDINTR S SDCNT=0,SDT="" D
  1. ..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
  1. I SDCNT>1 S SDMTM=1 S SDCC="" F S SDCC=$O(TEAM(SDCC)) Q:SDCC="" N DR,Y D WT Q
  1. I SDCNT'>1 D WT Q
  1. 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)
  1. I RES S SDWLRES=RES ; 446
  1. Q
  1. WAITS(DFN,TEAM,POS,SC) ; PLACE PATIENT ON WAIT LIST
  1. N SDCC,SDTEAM,SDINTR,SDMTM,SDREJ,SDWLIN,SDWLRES
  1. S SDTEAM=$G(TEAM)
  1. ; check if transfer and if multiple teams in institution
  1. S SDCNT=0,SDINTR="",SDREJ="",SDMTM="" I 'POS&TEAM D
  1. .S SDWLIN=$P($G(^SCTM(404.51,TEAM,0)),U,7)
  1. .;- is patient assigned to PC provider?
  1. I 'POS&TEAM D PCPVER(DFN,.SDTM) D ; return current PCP team or 0
  1. .I SDTM I $P($G(^SCTM(404.51,SDTM,0)),U,7)'=SDWLIN S SDINTR=1 ; inter transfer ; different institution
  1. .I 'SDTM S SDINS="" F S SDINS=$O(^SCTM(404.51,"AINST",SDINS)) Q:SDINS="" I SDINS'=SDWLIN D Q:SDREJ
  1. ..;check available PCMM teams in other institutions and if so set up rejection flag
  1. ..N SDT S SDCNT=0,SDT=""
  1. ..F S SDT=$O(^SCTM(404.51,"AINST",SDINS,SDT)) Q:SDT="" D Q:SDREJ
  1. ...I $$ACTTM^SCMCTMU(SDT)&($P($G(^SCTM(404.51,SDT,0)),U,5))&'$P($G(^SCTM(404.51,SDT,0)),U,10) D
  1. ...N SCTMCT S SCTMCT=$$TEAMCNT^SCAPMCU1(SDT) ;currently assigned
  1. ...N SCTMMAX S SCTMMAX=$P($$GETEAM^SCAPMCU3(SDT),"^",8) ;maximum set
  1. ...I SCTMCT<SCTMMAX S SDREJ=1
  1. ..;find all teams from institution SDWLIN
  1. .I SDINTR S SDCNT=0,SDT="" D
  1. ..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
  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
  1. I SDCNT'>1 N DR,Y S SDWLRES=$$WMT
  1. S TEAM=$G(SDTEAM) Q $G(SDWLRES)
  1. WMT() N RES
  1. 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)
  1. I $G(RES) D
  1. .N DA,DIE,DIK,DR,OK
  1. .S SDWLRES=RES ; 446
  1. .S OK=0,DA=+$P(RES,U,2),DIE="^SDWL(409.3,",DR="25;S OK=1"
  1. .D ^DIE
  1. .I 'OK S DIK=DIE D ^DIK W !,"Wait list entry deleted" S RES=0
  1. Q $G(RES)
  1. TEAMRM(DFN,TEAM) ;
  1. N SDTM D PCPVER(DFN,.SDTM) I 'SDTM D CLONE(DFN,TEAM) Q ;not PC panel assignment
  1. I SDTM'=TEAM D CLONE(DFN,TEAM) Q ;TEAM IS NOT PCP
  1. ;close EWL entries only if assignment to PC panel, not necessarily to a team
  1. N I
  1. 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
  1. .I 12'[$P(A,U,5) Q
  1. .;I $P(A,U,6)'=$G(TEAM) Q
  1. .I $G(^SDWL(409.3,I,"DIS")) Q
  1. .;INACTIVATE I
  1. .N FDA S FDA(409.3,I_",",21)="SA"
  1. .S FDA(409.3,I_",",19)=DT,FDA(409.3,I_",",23)="C"
  1. .S FDA(409.3,I_",",20)=DUZ
  1. .D UPDATE^DIE("","FDA")
  1. Q
  1. POSRM(TEAMP,POS) ;
  1. ;
  1. S DFN=+$G(^SCPT(404.42,+$G(TEAMP),0))
  1. N SDTM D PCPVER(DFN,.SDTM) I 'SDTM D CLONE(DFN,TEAMP,POS) Q ;not PC panel assignment
  1. I SDTM'=TEAMP D CLONE(DFN,TEAMP,POS) Q
  1. I $G(POS) I '$P($G(^SCPT(404.43,+POS,0)),U,5) Q ;not pc
  1. I '$P($G(^SCPT(404.42,+$G(TEAMP),0)),U,8) Q ;not pc
  1. ;S ^JDS("TEAMP")=TEAMP,^JDS("POS")=POS,^JDS("DFN")=DFN
  1. N I
  1. 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
  1. .I 12'[$P(A,U,5) Q
  1. .;I $P(A,U,7)'=$G(POS) Q
  1. .I $G(^SDWL(409.3,I,"DIS")) Q
  1. .N FDA S FDA(409.3,I_",",21)="SA",FDA(409.3,I_",",23)="C"
  1. .S FDA(409.3,I_",",19)=DT
  1. .S FDA(409.3,I_",",20)=DUZ
  1. .D FILE^DIE("","FDA")
  1. .;INACTIVATE
  1. Q
  1. CLONE(DFN,TEAM,POS) ;clean one entry only or two if position
  1. N I,SDONE S SDONE=0
  1. 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
  1. .I 12'[$P(A,U,5) Q
  1. .I $P(A,U,5)=1 I $P(A,U,6)'=$G(TEAM) Q
  1. .I $P(A,U,5)=2 I $P(A,U,6)'=$G(POS) Q
  1. .I $G(^SDWL(409.3,I,"DIS")) Q
  1. .;INACTIVATE I
  1. .N FDA S FDA(409.3,I_",",21)="SA"
  1. .S FDA(409.3,I_",",19)=DT,FDA(409.3,I_",",23)="C"
  1. .S FDA(409.3,I_",",20)=DUZ
  1. .D UPDATE^DIE("","FDA")
  1. .S SDONE=1
  1. Q
  1. PCPVER(DFN,SDTM) ;verify if PCP assignment
  1. S SDTM=0 ; return 0 if no PCP assignment
  1. K ^TMP("SDPCP",$J)
  1. N SDATE,SDPCP
  1. N SDI F SDI="BEGIN","END" S SDATE(SDI)=DT
  1. S SDATE="SDATE",SDPCP="^TMP(""SDPCP"",$J)"
  1. ;
  1. N SDI S SDI=$$GETALL^SCAPMCA(DFN,.SDATE,SDPCP)
  1. N SDII S SDII=0
  1. F S SDII=$O(^TMP("SDPCP",$J,DFN,"PCPOS",SDII)) Q:'SDII D
  1. .N SDX S SDX=^TMP("SDPCP",$J,DFN,"PCPOS",SDII)
  1. .I +$P(SDX,U,7)'=2 Q ;PCP role
  1. .I +$P(SDX,U,6)>0&(+$P(SDX,U,6)<DT) Q
  1. .S SDTM=$P(SDX,U,3)
  1. Q
  1. ONWAIT(DFN) ;is patient on wait list
  1. D DEM^VADPT I $G(VADM(6)) Q 9 ;Patient is dead
  1. N I,X
  1. S X=0
  1. 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
  1. .I 12'[$P(A,U,5) Q
  1. .I $G(^SDWL(409.3,I,"DIS")) Q
  1. .S X="3;ON WAITLIST TEAM: "_$P($G(^SCTM(404.51,+$P(A,U,6),0)),U)
  1. .I $P(A,U,7) S X=X_" POSITION: "_$P($G(^SCTM(404.57,+$P(A,U,7),0)),U)
  1. I X Q X
  1. ;Q X
  1. ;CHECK IF ON TEAM
  1. N SCD,SCDT,SCOK S SCOK=$$TMPT^SCAPMC3(DFN,"SCDT","","SCD","SCER1") I $D(SCD(1)) S X=1
  1. N SCPOS S SCOK=$$TPPT^SCAPMC(DFN,.SCDT,"","","","","","SCPOS","SCBKERR") I $D(SCPOS(1)) S X=2
  1. Q X
  1. ;CHECK IF ON POSITION
  1. SORT ;From sort template
  1. S X=0
  1. Q
  1. PC(RESULT,POS) ;rpc to see if provider can be pc
  1. N POENT,RES
  1. D ROLE(.RES,POS) I RES=1 S RESULT(0)=0 Q
  1. S POENT=+$O(^SCTM(404.52,"AIDT",+$G(POS),1,-(DT+.1))),POENT=$O(^(POENT,0))
  1. ;S PROV=+$P($G(^SCTM(404.52,+$G(POENT),0)),U,3)
  1. I 'POENT S RESULT(0)=1 Q
  1. N D0 S D0=+$G(POENT) D SORT S RESULT(0)=X
  1. Q
  1. ROLE(RESULT,POS) ;rpc to see if role of position is resident
  1. N ZERO S ZERO=$G(^SCTM(404.57,+$G(POS),0))
  1. I $P(ZERO,U,4) S RESULT=0 Q ;Already pc let them change it.
  1. S RESULT=0
  1. I $P($G(^SD(403.46,+$P(ZERO,U,3),0)),U)="RESIDENT (PHYSICIAN)" S RESULT=1
  1. Q
  1. SC(DFN) ;Is patient 0-50 sc%
  1. N TEAM,INST S TEAM=$P(DFN,U,2),INST=+$P($G(^SCTM(404.51,+TEAM,0)),U,7)
  1. S X=0,DFN=+DFN
  1. N A D ELIG^VADPT S A=$G(VAEL(3)) I $P(A,U)'="Y" Q 0
  1. I $P(A,U,2)<50 Q $P(A,U,2)
  1. Q 0
  1. SCLI(RESULT,SC) ;sc sc list
  1. K RESULT N RES
  1. S DFN=+$G(SC("DFN"))
  1. D SDSC^SDWLRP3(.RES,DFN) I RES=-1 S RESULT(0)=-1 Q
  1. 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