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,1015**;AUG 13, 1993;Build 21
;
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
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,1015**;AUG 13, 1993;Build 21
+2 ;
+3 QUIT
+4 ;
WAIT(SCOK,SC) ; Place patient on wait list
+1 ; 'SC BLD PAT CLN LIST'
+2 ;
+3 ;M ^JDS=SC
+4 NEW COMMENT,SDTM,SDCNT,SDINS,SDINTR,SDMTM,SDREJ,SDWLIN
+5 SET TEAM=$GET(SC("TEAM"))
SET POS=$GET(SC("POSITION"))
SET DFN=$GET(SC("DFN"))
SET COMMENT=$GET(SC("COMMENT"))
SET SC=$GET(SC("SC"))
+6 SET SDWLIN=+$PIECE($GET(^SCTM(404.51,+$GET(TEAM),0)),U,7)
SET SDINTR=$GET(SC("SDINTR"))
SET SDREJ=$GET(SC("SDREJ"))
SET SDMTM=$GET(SC("SDMTM"))
+7 ; check if transfer and if multiple teams in institution
+8 SET SDCNT=0
SET SDINTR=""
SET SDREJ=""
SET SDMTM=""
SET SDCC=TEAM
+9 ;identify INTRA-transfer
+10 ;- is patient assigned to PC provider?
+11 ; return current PCP team or 0
IF 'POS&TEAM
DO PCPVER(DFN,.SDTM)
Begin DoDot:1
+12 ; inter transfer ; different institution
IF SDTM
IF $PIECE($GET(^SCTM(404.51,SDTM,0)),U,7)'=SDWLIN
SET SDINTR=1
+13 IF 'SDTM
SET SDINS=""
FOR
SET SDINS=$ORDER(^SCTM(404.51,"AINST",SDINS))
IF SDINS=""
QUIT
IF SDINS'=SDWLIN
Begin DoDot:2
+14 ;check available PCMM teams in other institutions and if so set up rejection flag
+15 NEW SDT
SET SDCNT=0
SET SDT=""
+16 FOR
SET SDT=$ORDER(^SCTM(404.51,"AINST",SDINS,SDT))
IF SDT=""
QUIT
Begin DoDot:3
+17 IF $$ACTTM^SCMCTMU(SDT)&($PIECE($GET(^SCTM(404.51,SDT,0)),U,5))&'$PIECE($GET(^SCTM(404.51,SDT,0)),U,10)
Begin DoDot:4
End DoDot:4
+18 ;currently assigned
NEW SCTMCT
SET SCTMCT=$$TEAMCNT^SCAPMCU1(SDT)
+19 ;maximum set
NEW SCTMMAX
SET SCTMMAX=$PIECE($$GETEAM^SCAPMCU3(SDT),"^",8)
+20 IF SCTMCT<SCTMMAX
SET SDREJ=1
End DoDot:3
IF SDREJ
QUIT
+21 ;find all teams from institution SDWLIN
End DoDot:2
IF SDREJ
QUIT
+22 IF SDINTR
SET SDCNT=0
SET SDT=""
Begin DoDot:2
+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:2
End DoDot:1
+24 IF SDCNT>1
SET SDMTM=1
SET SDCC=""
FOR
SET SDCC=$ORDER(TEAM(SDCC))
IF SDCC=""
QUIT
NEW DR,Y
DO WT
QUIT
+25 IF SDCNT'>1
DO WT
QUIT
WT NEW RES
DO INPUT^SDWLRP1(.RES,DFN_U_$SELECT(POS:2,1:1)_U_SDCC_U_$SELECT(POS:POS_U_DUZ,1:U_DUZ)_U_COMMENT_U_SC_U_SDINTR_U_SDREJ_U_SDMTM)
+1 ; 446
IF RES
SET SDWLRES=RES
+2 QUIT
WAITS(DFN,TEAM,POS,SC) ; PLACE PATIENT ON WAIT LIST
+1 NEW SDCC,SDTEAM,SDINTR,SDMTM,SDREJ,SDWLIN,SDWLRES
+2 SET SDTEAM=$GET(TEAM)
+3 ; check if transfer and if multiple teams in institution
+4 SET SDCNT=0
SET SDINTR=""
SET SDREJ=""
SET SDMTM=""
IF 'POS&TEAM
Begin DoDot:1
+5 SET SDWLIN=$PIECE($GET(^SCTM(404.51,TEAM,0)),U,7)
+6 ;- is patient assigned to PC provider?
End DoDot:1
+7 ; return current PCP team or 0
IF 'POS&TEAM
DO PCPVER(DFN,.SDTM)
Begin DoDot:1
+8 ; inter transfer ; different institution
IF SDTM
IF $PIECE($GET(^SCTM(404.51,SDTM,0)),U,7)'=SDWLIN
SET SDINTR=1
+9 IF 'SDTM
SET SDINS=""
FOR
SET SDINS=$ORDER(^SCTM(404.51,"AINST",SDINS))
IF SDINS=""
QUIT
IF SDINS'=SDWLIN
Begin DoDot:2
+10 ;check available PCMM teams in other institutions and if so set up rejection flag
+11 NEW SDT
SET SDCNT=0
SET SDT=""
+12 FOR
SET SDT=$ORDER(^SCTM(404.51,"AINST",SDINS,SDT))
IF SDT=""
QUIT
Begin DoDot:3
+13 IF $$ACTTM^SCMCTMU(SDT)&($PIECE($GET(^SCTM(404.51,SDT,0)),U,5))&'$PIECE($GET(^SCTM(404.51,SDT,0)),U,10)
Begin DoDot:4
End DoDot:4
+14 ;currently assigned
NEW SCTMCT
SET SCTMCT=$$TEAMCNT^SCAPMCU1(SDT)
+15 ;maximum set
NEW SCTMMAX
SET SCTMMAX=$PIECE($$GETEAM^SCAPMCU3(SDT),"^",8)
+16 IF SCTMCT<SCTMMAX
SET SDREJ=1
End DoDot:3
IF SDREJ
QUIT
+17 ;find all teams from institution SDWLIN
End DoDot:2
IF SDREJ
QUIT
+18 IF SDINTR
SET SDCNT=0
SET SDT=""
Begin DoDot:2
+19 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:2
End DoDot:1
+20 IF SDCNT>1
SET SDMTM=1
SET SDCC=""
FOR
SET SDCC=$ORDER(TEAM(SDCC))
IF SDCC=""
QUIT
SET TEAM=SDCC
NEW DR,Y
SET SDWLRES=$$WMT
+21 IF SDCNT'>1
NEW DR,Y
SET SDWLRES=$$WMT
+22 SET TEAM=$GET(SDTEAM)
QUIT $GET(SDWLRES)
WMT() NEW RES
+1 DO INPUT^SDWLRP1(.RES,DFN_U_$SELECT(POS:2,1:1)_U_TEAM_U_$SELECT(POS:POS_U_DUZ,1:U_DUZ)_"^^"_SC_U_SDINTR_U_SDREJ_U_SDMTM)
+2 IF $GET(RES)
Begin DoDot:1
+3 NEW DA,DIE,DIK,DR,OK
+4 ; 446
SET SDWLRES=RES
+5 SET OK=0
SET DA=+$PIECE(RES,U,2)
SET DIE="^SDWL(409.3,"
SET DR="25;S OK=1"
+6 DO ^DIE
+7 IF 'OK
SET DIK=DIE
DO ^DIK
WRITE !,"Wait list entry deleted"
SET RES=0
End DoDot:1
+8 QUIT $GET(RES)
TEAMRM(DFN,TEAM) ;
+1 ;not PC panel assignment
NEW SDTM
DO PCPVER(DFN,.SDTM)
IF 'SDTM
DO CLONE(DFN,TEAM)
QUIT
+2 ;TEAM IS NOT PCP
IF SDTM'=TEAM
DO CLONE(DFN,TEAM)
QUIT
+3 ;close EWL entries only if assignment to PC panel, not necessarily to a team
+4 NEW I
+5 FOR I=0:0
SET I=$ORDER(^SDWL(409.3,"B",+$GET(DFN),I))
IF 'I
QUIT
SET A=$GET(^SDWL(409.3,I,0))
Begin DoDot:1
+6 IF 12'[$PIECE(A,U,5)
QUIT
+7 ;I $P(A,U,6)'=$G(TEAM) Q
+8 IF $GET(^SDWL(409.3,I,"DIS"))
QUIT
+9 ;INACTIVATE I
+10 NEW FDA
SET FDA(409.3,I_",",21)="SA"
+11 SET FDA(409.3,I_",",19)=DT
SET FDA(409.3,I_",",23)="C"
+12 SET FDA(409.3,I_",",20)=DUZ
+13 DO UPDATE^DIE("","FDA")
End DoDot:1
+14 QUIT
POSRM(TEAMP,POS) ;
+1 ;
+2 SET DFN=+$GET(^SCPT(404.42,+$GET(TEAMP),0))
+3 ;not PC panel assignment
NEW SDTM
DO PCPVER(DFN,.SDTM)
IF 'SDTM
DO CLONE(DFN,TEAMP,POS)
QUIT
+4 IF SDTM'=TEAMP
DO CLONE(DFN,TEAMP,POS)
QUIT
+5 ;not pc
IF $GET(POS)
IF '$PIECE($GET(^SCPT(404.43,+POS,0)),U,5)
QUIT
+6 ;not pc
IF '$PIECE($GET(^SCPT(404.42,+$GET(TEAMP),0)),U,8)
QUIT
+7 ;S ^JDS("TEAMP")=TEAMP,^JDS("POS")=POS,^JDS("DFN")=DFN
+8 NEW I
+9 FOR I=0:0
SET I=$ORDER(^SDWL(409.3,"B",+$GET(DFN),I))
IF 'I
QUIT
SET A=$GET(^SDWL(409.3,I,0))
Begin DoDot:1
+10 IF 12'[$PIECE(A,U,5)
QUIT
+11 ;I $P(A,U,7)'=$G(POS) Q
+12 IF $GET(^SDWL(409.3,I,"DIS"))
QUIT
+13 NEW FDA
SET FDA(409.3,I_",",21)="SA"
SET FDA(409.3,I_",",23)="C"
+14 SET FDA(409.3,I_",",19)=DT
+15 SET FDA(409.3,I_",",20)=DUZ
+16 DO FILE^DIE("","FDA")
+17 ;INACTIVATE
End DoDot:1
+18 QUIT
CLONE(DFN,TEAM,POS) ;clean one entry only or two if position
+1 NEW I,SDONE
SET SDONE=0
+2 FOR I=0:0
SET I=$ORDER(^SDWL(409.3,"B",+$GET(DFN),I))
IF 'I
QUIT
SET A=$GET(^SDWL(409.3,I,0))
Begin DoDot:1
+3 IF 12'[$PIECE(A,U,5)
QUIT
+4 IF $PIECE(A,U,5)=1
IF $PIECE(A,U,6)'=$GET(TEAM)
QUIT
+5 IF $PIECE(A,U,5)=2
IF $PIECE(A,U,6)'=$GET(POS)
QUIT
+6 IF $GET(^SDWL(409.3,I,"DIS"))
QUIT
+7 ;INACTIVATE I
+8 NEW FDA
SET FDA(409.3,I_",",21)="SA"
+9 SET FDA(409.3,I_",",19)=DT
SET FDA(409.3,I_",",23)="C"
+10 SET FDA(409.3,I_",",20)=DUZ
+11 DO UPDATE^DIE("","FDA")
+12 SET SDONE=1
End DoDot:1
IF SDONE
QUIT
+13 QUIT
PCPVER(DFN,SDTM) ;verify if PCP assignment
+1 ; return 0 if no PCP assignment
SET SDTM=0
+2 KILL ^TMP("SDPCP",$JOB)
+3 NEW SDATE,SDPCP
+4 NEW SDI
FOR SDI="BEGIN","END"
SET SDATE(SDI)=DT
+5 SET SDATE="SDATE"
SET SDPCP="^TMP(""SDPCP"",$J)"
+6 ;
+7 NEW SDI
SET SDI=$$GETALL^SCAPMCA(DFN,.SDATE,SDPCP)
+8 NEW SDII
SET SDII=0
+9 FOR
SET SDII=$ORDER(^TMP("SDPCP",$JOB,DFN,"PCPOS",SDII))
IF 'SDII
QUIT
Begin DoDot:1
+10 NEW SDX
SET SDX=^TMP("SDPCP",$JOB,DFN,"PCPOS",SDII)
+11 ;PCP role
IF +$PIECE(SDX,U,7)'=2
QUIT
+12 IF +$PIECE(SDX,U,6)>0&(+$PIECE(SDX,U,6)<DT)
QUIT
+13 SET SDTM=$PIECE(SDX,U,3)
End DoDot:1
+14 QUIT
ONWAIT(DFN) ;is patient on wait list
+1 ;Patient is dead
DO DEM^VADPT
IF $GET(VADM(6))
QUIT 9
+2 NEW I,X
+3 SET X=0
+4 FOR I=0:0
SET I=$ORDER(^SDWL(409.3,"B",+$GET(DFN),I))
IF 'I
QUIT
SET A=$GET(^SDWL(409.3,I,0))
Begin DoDot:1
+5 IF 12'[$PIECE(A,U,5)
QUIT
+6 IF $GET(^SDWL(409.3,I,"DIS"))
QUIT
+7 SET X="3;ON WAITLIST TEAM: "_$PIECE($GET(^SCTM(404.51,+$PIECE(A,U,6),0)),U)
+8 IF $PIECE(A,U,7)
SET X=X_" POSITION: "_$PIECE($GET(^SCTM(404.57,+$PIECE(A,U,7),0)),U)
End DoDot:1
IF X
QUIT
+9 IF X
QUIT X
+10 ;Q X
+11 ;CHECK IF ON TEAM
+12 NEW SCD,SCDT,SCOK
SET SCOK=$$TMPT^SCAPMC3(DFN,"SCDT","","SCD","SCER1")
IF $DATA(SCD(1))
SET X=1
+13 NEW SCPOS
SET SCOK=$$TPPT^SCAPMC(DFN,.SCDT,"","","","","","SCPOS","SCBKERR")
IF $DATA(SCPOS(1))
SET X=2
+14 QUIT X
+15 ;CHECK IF ON POSITION
SORT ;From sort template
+1 SET X=0
+2 QUIT
PC(RESULT,POS) ;rpc to see if provider can be pc
+1 NEW POENT,RES
+2 DO ROLE(.RES,POS)
IF RES=1
SET RESULT(0)=0
QUIT
+3 SET POENT=+$ORDER(^SCTM(404.52,"AIDT",+$GET(POS),1,-(DT+.1)))
SET POENT=$ORDER(^(POENT,0))
+4 ;S PROV=+$P($G(^SCTM(404.52,+$G(POENT),0)),U,3)
+5 IF 'POENT
SET RESULT(0)=1
QUIT
+6 NEW D0
SET D0=+$GET(POENT)
DO SORT
SET RESULT(0)=X
+7 QUIT
ROLE(RESULT,POS) ;rpc to see if role of position is resident
+1 NEW ZERO
SET ZERO=$GET(^SCTM(404.57,+$GET(POS),0))
+2 ;Already pc let them change it.
IF $PIECE(ZERO,U,4)
SET RESULT=0
QUIT
+3 SET RESULT=0
+4 IF $PIECE($GET(^SD(403.46,+$PIECE(ZERO,U,3),0)),U)="RESIDENT (PHYSICIAN)"
SET RESULT=1
+5 QUIT
SC(DFN) ;Is patient 0-50 sc%
+1 NEW TEAM,INST
SET TEAM=$PIECE(DFN,U,2)
SET INST=+$PIECE($GET(^SCTM(404.51,+TEAM,0)),U,7)
+2 SET X=0
SET DFN=+DFN
+3 NEW A
DO ELIG^VADPT
SET A=$GET(VAEL(3))
IF $PIECE(A,U)'="Y"
QUIT 0
+4 IF $PIECE(A,U,2)<50
QUIT $PIECE(A,U,2)
+5 QUIT 0
SCLI(RESULT,SC) ;sc sc list
+1 KILL RESULT
NEW RES
+2 SET DFN=+$GET(SC("DFN"))
+3 DO SDSC^SDWLRP3(.RES,DFN)
IF RES=-1
SET RESULT(0)=-1
QUIT
+4 SET RESULT(0)="<RESULTS>"
NEW CNT,I
SET CNT=1
FOR I=0:0
SET I=$ORDER(^TMP("SDWLRP3",$JOB,I))
IF 'I
QUIT
SET RESULT(CNT)=^(I)
SET CNT=CNT+1
