Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCQK1.m
===================================================================
--- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCQK1.m	(revision 613)
+++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCQK1.m	(revision 623)
@@ -1,268 +1,268 @@
-SCMCQK1	;ALBOI/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge;11/07/02
-	;;5.3;Scheduling;**148,177,231,264,436,297,446,524**;AUG 13, 1993;Build 29
-	;
-	;04/25/2006 SD*5.3*446 INTER-FACILITY TRANSFER
-UNTP	;unassign patient from pc prac position
-	I '$G(SCTP) W !,"No position defined" Q
-	N OK,SCER,SCCL,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS
-	S OK=0
-	W !,"About to Unassign "_$$NAME(DFN)_" from: ",!,?8,$$POSITION(SCTP)_" position   ["_$P($$GETPRTP^SCAPMCU2(SCTP,DT),U,2)_"]"
-	S SCDISCH=$$DATE("D")
-	G:SCDISCH<1 QTUNTP
-	G:'$$CONFIRM() QTUNTP
-	S OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)  ; og/sd/524
-	G:OK'>0 QTUNTP
-	S SCCL=$P($G(^SCTM(404.57,+$G(SCTP),0)),U,9)
-	I SCCL D DISCL
-QTUNTP	W !,"Position Unassignment "_$S(OK:"made.",1:"NOT made.")
-	Q
-ENRCL	;
-	N SCRESTA,SCREST,SCCLNM,SCTM
-	N SCCL
-	F SCCL=0:0 S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,SCCL)) Q:'SCCL  D
-	.Q:$$ACTCL(DFN,SCCL)
-	.W !!!,"The "_$$POSITION(SCTP)_" is associated with the ",$$CLINIC(SCCL)_" clinic."
-	.;SCRESTA = Array of pt's teams causing restricted consults
-	.N SCRESTA
-	.S SCREST=$$RESTPT^SCAPMCU4(DFN,DT,"SCRESTA")
-	.I SCREST D
-	..N SCTM
-	..S SCCLNM=Y
-	..W !,?5,"Patient has restricted consults due to team assignment(s):"
-	..S SCTM=0
-	..F  S SCTM=$O(SCRESTA(SCTM)) Q:'SCTM  W !,?10,SCRESTA(SCTM)
-	.I SCREST&'$G(SCOKCONS) D  G QTECL
-	..W !,?5,"This patient may only be enrolled in clinics via"
-	..W !,?15,"Edit Clinic Enrollment Data option"
-	.W !,"Do you wish to enroll the patient from this clinic on "
-	.S Y=SCASSDT X ^DD("DD") W Y,"?"
-	.I $$YESNO() D
-	..W !,"Clinic Enrollment"
-	..I $$ACPTCL^SCAPMC18(DFN,SCCL,,SCASSDT,"SCENER") W " made"
-	..E  W "NOT made"
-QTECL	Q
-DISCL	;
-	N SCCL F SCCL=0:0 S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,SCCL)) Q:'SCCL  D
-	.Q:'$$ACTCL(DFN,SCCL)
-	.W !,$$NAME(DFN)," is enrolled in the associated "_$$CLINIC(SCCL)_" clinic."
-	.W !,"Do you wish to discharge the patient from this clinic on "
-	.S Y=SCDISCH X ^DD("DD") W Y,"?"
-	.Q:'$$YESNO()
-	.N SDFN,SDCLN S SDFN=DFN,SDCLN=SCCL
-	.N DFN D ^SDCD
-QTDCL	Q
-UNTM	;
-	;assign patient from pc team (and pc position if possible)
-	N OK,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS,OK2,OK3
-	S OK=0
-	W !!,"About to Unassign "_$$NAME(DFN)_" from "_$$TEAMNM(SCTM)_" team"
-	W:'SCTPSTAT !,?5,"AND from "_$$POSITION(SCTP)_" position  ["_$$WRITETP^SCMCDD1(SCTP)_"]"
-	S SCDISCH=$$DATE("D")
-	G:SCDISCH<1 QTUNTM
-	G:'$$CONFIRM() QTUNTM
-	IF 'SCTPSTAT D  G:OK2'>0 QTUNTM
-	.W !,"PC assignment unassigned."
-	.S OK2=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)
-	.IF OK2>0 D
-	..W "made."
-	..S SCCL=$P(^SCTM(404.57,SCTP,0),U,9)
-	..D:SCCL DISCL
-	S OK3=$$ALLPOS()
-	IF $$OKINPTTM^SCMCTMU2(DFN,SCTM,SCDISCH) D
-	.S OK=$$INPTSCTM^SCAPMC7(DFN,SCTM,SCDISCH,.SCER)
-	ELSE  D
-	.W !,"Future/Current Patient-Position Assignment exists"
-QTUNTM	W !,"Team Unassignment "_$S(OK:"made",1:"NOT made.")
-	Q
-ALLPOS()	;unassign all patient-positions for team
-	;not stand-alone - needs dfn,sctm
-	;return 1=No positions left assigned|0=At least 1 position assigned
-	N OK,SCDT1,SCPTTPX,SCERRR,SCTP,SCCNT,SCPTTPI,SCLOC,SCNODE,SCPTTP2
-	S SCDT1("BEGIN")=SCDISCH+1
-	S SCDT1("END")=3990101
-	S SCDT1("INCL")=0  ;anytime from now to future
-	S OK=$$TPPT^SCAPMC23(DFN,"SCDT1",,,,,,"SCPTTPX",.SCERRR)
-	S (SCTP,SCCNT)=0
-	W !,"Checking for other position assignments to team..."
-	F  S SCTP=$O(SCPTTPX("SCTP",SCTM,SCTP)) Q:'SCTP  S SCCNT=SCCNT+1 D
-	.S SCPTTPI=$O(SCPTTPX("SCTP",SCTM,SCTP,9999999),-1)
-	.S SCLOC=$O(SCPTTPX("SCTP",SCTM,SCTP,SCPTTPI,0))
-	.S SCNODE=SCPTTPX(SCLOC)
-	.S SCPTTP2(SCTP)=""
-	.W !,?3,$P(SCNODE,U,2),"   ",$P(SCNODE,U,8)
-	.IF $P(SCNODE,U,6)!(SCDISCH'>$P(SCNODE,U,5)) D
-	..W !,?5,"Unassignment date already exists or unassignment after assignment date"
-	..W !,?15,"- Correct via PCMM GUI"
-	..S OK=0
-	W !,?5,$S(SCCNT:SCCNT,1:"No")_" current/future position assignment(s)"
-	G:'OK!('SCCNT) QTALL
-	W !!,"About to unassign the above patient-position assignments"
-	IF '$$CONFIRM S OK=0 G QTALL
-	S SCTP=0
-	F  S SCTP=$O(SCPTTP2(SCTP)) Q:'SCTP  D  Q:'OK
-	.S OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)
-	.W:'OK !,?10,"Problem with unassignment, correct via PCMM GUI"
-QTALL	Q OK
-ASTM	;assign patient to PC team
-	N DIC,Y,OK,SCTM,SCTMFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS
-	S OK=0
-	W !!,"About to Assign "_$$NAME(DFN)_" to a primary care team"
-	I $$SC(DFN) W !!,"********** This patient is 50 percent or greater service-connected ************"
-	S DIC="^SCTM(404.51,"
-	S DIC(0)="AEMQZ"
-	S DIC("S")="IF $$ACTTM^SCMCTMU(Y,DT)&($P($G(^SCTM(404.51,Y,0)),U,5))"
-	;select from active teams that can be PC Teams
-	D ^DIC
-	G:Y<1 QTASTM
-	S SCTM=+Y
-	;The following logic to present warning message added per SD*5.3*436
-	I $P($G(^SCTM(404.51,SCTM,0)),U,10) D  G:'SCFLAG QTASTM
-	.S SCFLAG=0
-	.W !!,"This team is closed to further patient assignments.  While you are"
-	.W !,"not currently prevented from assigning this patient, you may want to"
-	.W !,"check before continuing."
-	.Q:'$$YESNO1()  ; new function call per SD*5.3*436
-	.Q:'$$CONFIRM()
-	.S SCFLAG=1 W !
-	S SCASSDT=$$DATE("A")
-	G:SCASSDT<1 QTASTM
-	S SCTMCT=$$TEAMCNT^SCAPMCU1(SCTM)
-	S SCTMMAX=$P($$GETEAM^SCAPMCU3(SCTM),"^",8)
-	I SCTMCT'<SCTMMAX  D  G QTASTM:$$WAITYN(),QTASTM:'$$YESNO2()
-	.W !,"This assignment will reach or exceeded the maximum set for this team."
-	.W !,"Currently assigned: "_SCTMCT
-	.W !,"Maximum set for team: "_SCTMMAX
-	I SCTMCT<SCTMMAX,'$$CONFIRM() G QTASTM
-	S SCTM=+Y
-	;setup fields
-	S SCTMFLDS(.08)=1 ;primary care assignment
-	S SCTMFLDS(.11)=$G(DUZ,.5)
-	D NOW^%DTC S SCTMFLDS(.12)=%
-	IF $$ACPTTM^SCAPMC(DFN,SCTM,"SCTMFLDS",SCASSDT,"SCTPTME") D
-	.S SCSELECT=$$SELPOS()
-	.D:$L(SCSELECT) ASTP ;prompt for position prompt
-	.S OK=1
-QTASTM	W !,"Team Assignment "_$S(OK:"made",1:"NOT made.")
-	S:$D(SDWLPCMM) SDWLPCMM=OK  ; 446
-	Q
-ASTP	;assign patient to PC practitioner
-	N DIC,Y,OK,SCCL,X,SCTPFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS
-	S OK=0
-	W !!,"About to Assign "_$$NAME(DFN)_" to PC Position Assignment"
-	I $$SC(DFN) W !!,"********** This patient is 50 percent or greater service-connected ************"
-	;lookup to display only position and [practitioner]
-	IF SCSELECT="PRACT" D
-	.S DIC("W")="N SCP1 S SCP1=$G(^SCTM(404.52,Y,0)) W ""    ["",$P($G(^VA(200,+$P(SCP1,U,3),0)),U,1),""]"""
-	.S DIC("A")="POSITION's Current PRACTITIONER: "
-	.S DIC="^SCTM(404.52,"
-	.;Must be from team, must be activation,must not have future inactivation
-	.S DIC("S")="I $$PRACSCR^SCMCQK1(Y)"
-	.S D="C"
-	ELSE  D
-	.S DIC="^SCTM(404.57,"
-	.S D="B"
-	.S DIC("A")="POSITION's Name: "
-	.S DIC("S")="I $$POSSCR^SCMCQK1(Y)"
-	S DIC(0)="AEMQZ"
-	D MIX^DIC1
-	G:Y<1 QTASTP
-	IF SCSELECT="PRACT" D
-	.S SCTP=$P(Y,U,2)
-	ELSE  D
-	.S SCTP=$P(Y,U,1)
-	S SCASSDT=$$DATE("A")
-	G:SCASSDT<1 QTASTP
-	S SCTMCT=$$PCPOSCNT^SCAPMCU1(SCTP),SCTMMAX=+$P($G(^SCTM(404.57,SCTP,0)),U,8)
-	I SCTMCT'<SCTMMAX D  G QTASTP:$$WAITYN,QTASTP:'$$YESNO2
-	.W !,"This assignment will reach or exceeded the maximum set for this position."
-	.W !,"Currently assigned: "_SCTMCT
-	.W !,"Maximum set for position: "_SCTMMAX
-	G:'$$CONFIRM() QTASTP
-	;setup fields
-	S SCTPFLDS(.03)=SCASSDT
-	S SCTPFLDS(.05)=1 ;pc pract role
-	S SCTPFLDS(.06)=$G(DUZ,.5)
-	D NOW^%DTC S SCTPFLDS(.07)=%
-	IF $$ACPTTP^SCAPMC21(DFN,SCTP,"SCTPFLDS",SCASSDT,"SCTPTME",0) D
-	.S OK=1
-	.S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,0))
-	.D:SCCL ENRCL
-QTASTP	W !,"Position Assignment "_$S(OK:"made",1:"NOT made.")
-	S:$D(SDWLPCMM) SDWLPCMM=OK ;446
-	Q
-NAME(DFN)	;return patient name
-	Q $P($G(^DPT(DFN,0)),U,1)
-POSITION(SCTP)	;return position name
-	Q $P($G(^SCTM(404.57,SCTP,0)),U,1)
-TEAMNM(SCTM)	;return team name
-	Q $P($G(^SCTM(404.51,SCTM,0)),U,1)
-CLINIC(SCCL)	;return clinic name
-	Q $P($G(^SC(+SCCL,0)),U,1)
-YESNO()	;
-	N DIR,X,Y
-	S DIR(0)="Y",DIR("B")="YES"
-	D ^DIR
-	Q Y>0
-YESNO1()	; added per SD*5.3*436
-	N DIR,X,Y
-	S DIR(0)="Y",DIR("A")="Do you wish to assign this patient now (Yes/No)?"
-	S DIR("B")="NO"
-	D ^DIR
-	Q Y>0
-YESNO2()	;
-	N DIR,X,Y
-	S DIR(0)="Y",DIR("B")="NO"
-	S DIR("A")="Do you wish to continue with the assignment (Yes/No)?"
-	D ^DIR
-	Q Y>0
-CONFIRM()	;confirmation call
-	N DIR,X,Y
-	S DIR("A")="Are you sure (Yes/No)"
-	S DIR(0)="Y"
-	D ^DIR
-	Q +Y=1
-SELPOS()	;return way to select position: 1=PRACT,2=POSIT,3=NONE
-	N DIR,X,Y
-	W !,"Choose way to select PC POSITION Assignment: "
-	S DIR(0)="SO^0:NONE;1:BY PRACTITIONER ASSIGNMENT;2:BY POSITION ASSIGNMENT"
-	S DIR("B")=1
-	D ^DIR
-	Q $S(Y'>0:"",+Y=1:"PRACT",1:"POSIT")
-DATE(TYPE)	;return date type=A or D
-	N DIR,X,Y
-	S DIR("A")=$S(TYPE="A":"Assignment",1:"Unassignment")_" date: "
-	S DIR(0)="DA^::EXP"
-	S Y=$S($D(SCDISCH):SCDISCH,$D(SCASSDT):SCASSDT,(TYPE="A"):"TODAY",1:"TODAY-1")
-	X ^DD("DD")
-	S DIR("B")=Y
-	D ^DIR
-	Q Y
-ACTCL(DFN,SCCL)	;is patient enrolled in clinic?
-	N SCXX
-	S SCXX=$O(^DPT(DFN,"DE","B",SCCL,9999),-1)
-	Q $S('SCXX:0,($P(^DPT(DFN,"DE",+SCXX,0),U,2)="I"):0,1:1)
-PRACSCR(SC40452)	;screen for for file 404.52
-	N SCP,SCNODE,OK
-	S SCP=$G(^SCTM(404.52,SC40452,0))
-	S OK=0
-	G:'SCP QTPP
-	S SCNODE=$G(^SCTM(404.57,+SCP,0))
-	S OK=$S($P(SCNODE,U,2)'=SCTM:0,'$P(SCNODE,U,4):0,($O(^SCTM(404.52,"AIDT",+SCP,1,""))'=-$P(SCP,U,2)):0,($O(^SCTM(404.52,"AIDT",+SCP,0,-$P(SCP,U,2)),-1)):0,($$ACTTP^SCMCTPU(+SCP)>0):1,1:0)
-QTPP	Q OK
-POSSCR(SCTP)	;screen for file 404.57
-	N SCNODE
-	S SCNODE=$G(^SCTM(404.57,SCTP,0))
-	Q $S($P(SCNODE,U,2)'=SCTM:0,'$P(SCNODE,U,4):0,($$ACTTP^SCMCTPU(SCTP)>0):1,1:0)
-	Q
-WAITYN()	;
-	N %,OK,Y
-	I SCTMCT<SCTMMAX Q 0
-	N A,SC S A=$$ONWAIT^SCMCWAIT(DFN) I A W:(+A=3) !,$P(A,";",2) I $S($G(SCTP):A>1,1:1) Q 0
-	N DIR,X,Y
-	S DIR(0)="Y",DIR("B")="NO"
-	S DIR("A")="Do you wish to place the patient on the wait list (Yes/No)?"
-	D ^DIR
-	I Y=1 S Y=$$WAITS^SCMCWAIT(DFN,SCTM,$G(SCTP),$G(SC)) I Y>0 W !,"Patient Placed on Wait List"
-	Q Y>0
-SC(DFN)	;Is patient 50 to 100%
-	D ELIG^VADPT Q $P($G(VAEL(3)),U,2)>49
+SCMCQK1 ;ALB/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge ; 07 Oct 2002  12:10 PM  ; Compiled April 12, 2007 10:03:59
+ ;;5.3;Scheduling;**148,177,231,264,436,297,446**;AUG 13, 1993;Build 77
+ ;
+ ;04/25/2006 SD*5.3*446 INTER-FACILITY TRANSFER
+UNTP ;unassign patient from pc prac position
+ I '$G(SCTP) W !,"No position defined" Q
+ N OK,SCER,SCCL,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS
+ S OK=0
+ W !,"About to Unassign "_$$NAME(DFN)_" from: ",!,?8,$$POSITION(SCTP)_" position   ["_$P($$GETPRTP^SCAPMCU2(SCTP,DT),U,2)_"]"
+ S SCDISCH=$$DATE("D")
+ G:SCDISCH<1 QTUNTP
+ G:'$$CONFIRM() QTUNTP
+ S OK=1 ;$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)
+ G:OK'>0 QTUNTP
+ S SCCL=$P($G(^SCTM(404.57,+$G(SCTP),0)),U,9)
+ I SCCL D DISCL
+QTUNTP W !,"Position Unassignment "_$S(OK:"made.",1:"NOT made.")
+ Q
+ENRCL ;
+ N SCRESTA,SCREST,SCCLNM,SCTM
+ N SCCL
+ F SCCL=0:0 S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,SCCL)) Q:'SCCL  D
+ .Q:$$ACTCL(DFN,SCCL)
+ .W !!!,"The "_$$POSITION(SCTP)_" is associated with the ",$$CLINIC(SCCL)_" clinic."
+ .;SCRESTA = Array of pt's teams causing restricted consults
+ .N SCRESTA
+ .S SCREST=$$RESTPT^SCAPMCU4(DFN,DT,"SCRESTA")
+ .I SCREST D
+ ..N SCTM
+ ..S SCCLNM=Y
+ ..W !,?5,"Patient has restricted consults due to team assignment(s):"
+ ..S SCTM=0
+ ..F  S SCTM=$O(SCRESTA(SCTM)) Q:'SCTM  W !,?10,SCRESTA(SCTM)
+ .I SCREST&'$G(SCOKCONS) D  G QTECL
+ ..W !,?5,"This patient may only be enrolled in clinics via"
+ ..W !,?15,"Edit Clinic Enrollment Data option"
+ .W !,"Do you wish to enroll the patient from this clinic on "
+ .S Y=SCASSDT X ^DD("DD") W Y,"?"
+ .I $$YESNO() D
+ ..W !,"Clinic Enrollment"
+ ..I $$ACPTCL^SCAPMC18(DFN,SCCL,,SCASSDT,"SCENER") W " made"
+ ..E  W "NOT made"
+QTECL Q
+DISCL ;
+ N SCCL F SCCL=0:0 S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,SCCL)) Q:'SCCL  D
+ .Q:'$$ACTCL(DFN,SCCL)
+ .W !,$$NAME(DFN)," is enrolled in the associated "_$$CLINIC(SCCL)_" clinic."
+ .W !,"Do you wish to discharge the patient from this clinic on "
+ .S Y=SCDISCH X ^DD("DD") W Y,"?"
+ .Q:'$$YESNO()
+ .N SDFN,SDCLN S SDFN=DFN,SDCLN=SCCL
+ .N DFN D ^SDCD
+QTDCL Q
+UNTM ;
+ ;assign patient from pc team (and pc position if possible)
+ N OK,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS,OK2,OK3
+ S OK=0
+ W !!,"About to Unassign "_$$NAME(DFN)_" from "_$$TEAMNM(SCTM)_" team"
+ W:'SCTPSTAT !,?5,"AND from "_$$POSITION(SCTP)_" position  ["_$$WRITETP^SCMCDD1(SCTP)_"]"
+ S SCDISCH=$$DATE("D")
+ G:SCDISCH<1 QTUNTM
+ G:'$$CONFIRM() QTUNTM
+ IF 'SCTPSTAT D  G:OK2'>0 QTUNTM
+ .W !,"PC assignment unassigned."
+ .S OK2=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)
+ .IF OK2>0 D
+ ..W "made."
+ ..S SCCL=$P(^SCTM(404.57,SCTP,0),U,9)
+ ..D:SCCL DISCL
+ S OK3=$$ALLPOS()
+ IF $$OKINPTTM^SCMCTMU2(DFN,SCTM,SCDISCH) D
+ .S OK=$$INPTSCTM^SCAPMC7(DFN,SCTM,SCDISCH,.SCER)
+ ELSE  D
+ .W !,"Future/Current Patient-Position Assignment exists"
+QTUNTM W !,"Team Unassignment "_$S(OK:"made",1:"NOT made.")
+ Q
+ALLPOS() ;unassign all patient-positions for team
+ ;not stand-alone - needs dfn,sctm
+ ;return 1=No positions left assigned|0=At least 1 position assigned
+ N OK,SCDT1,SCPTTPX,SCERRR,SCTP,SCCNT,SCPTTPI,SCLOC,SCNODE,SCPTTP2
+ S SCDT1("BEGIN")=SCDISCH+1
+ S SCDT1("END")=3990101
+ S SCDT1("INCL")=0  ;anytime from now to future
+ S OK=$$TPPT^SCAPMC23(DFN,"SCDT1",,,,,,"SCPTTPX",.SCERRR)
+ S (SCTP,SCCNT)=0
+ W !,"Checking for other position assignments to team..."
+ F  S SCTP=$O(SCPTTPX("SCTP",SCTM,SCTP)) Q:'SCTP  S SCCNT=SCCNT+1 D
+ .S SCPTTPI=$O(SCPTTPX("SCTP",SCTM,SCTP,9999999),-1)
+ .S SCLOC=$O(SCPTTPX("SCTP",SCTM,SCTP,SCPTTPI,0))
+ .S SCNODE=SCPTTPX(SCLOC)
+ .S SCPTTP2(SCTP)=""
+ .W !,?3,$P(SCNODE,U,2),"   ",$P(SCNODE,U,8)
+ .IF $P(SCNODE,U,6)!(SCDISCH'>$P(SCNODE,U,5)) D
+ ..W !,?5,"Unassignment date already exists or unassignment after assignment date"
+ ..W !,?15,"- Correct via PCMM GUI"
+ ..S OK=0
+ W !,?5,$S(SCCNT:SCCNT,1:"No")_" current/future position assignment(s)"
+ G:'OK!('SCCNT) QTALL
+ W !!,"About to unassign the above patient-position assignments"
+ IF '$$CONFIRM S OK=0 G QTALL
+ S SCTP=0
+ F  S SCTP=$O(SCPTTP2(SCTP)) Q:'SCTP  D  Q:'OK
+ .S OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)
+ .W:'OK !,?10,"Problem with unassignment, correct via PCMM GUI"
+QTALL Q OK
+ASTM ;assign patient to PC team
+ N DIC,Y,OK,SCTM,SCTMFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS
+ S OK=0
+ W !!,"About to Assign "_$$NAME(DFN)_" to a primary care team"
+ I $$SC(DFN) W !!,"********** This patient is 50 percent or greater service-connected ************"
+ S DIC="^SCTM(404.51,"
+ S DIC(0)="AEMQZ"
+ S DIC("S")="IF $$ACTTM^SCMCTMU(Y,DT)&($P($G(^SCTM(404.51,Y,0)),U,5))"
+ ;select from active teams that can be PC Teams
+ D ^DIC
+ G:Y<1 QTASTM
+ S SCTM=+Y
+ ;The following logic to present warning message added per SD*5.3*436
+ I $P($G(^SCTM(404.51,SCTM,0)),U,10) D  G:'SCFLAG QTASTM
+ .S SCFLAG=0
+ .W !!,"This team is closed to further patient assignments.  While you are"
+ .W !,"not currently prevented from assigning this patient, you may want to"
+ .W !,"check before continuing."
+ .Q:'$$YESNO1()  ; new function call per SD*5.3*436
+ .Q:'$$CONFIRM()
+ .S SCFLAG=1 W !
+ S SCASSDT=$$DATE("A")
+ G:SCASSDT<1 QTASTM
+ S SCTMCT=$$TEAMCNT^SCAPMCU1(SCTM)
+ S SCTMMAX=$P($$GETEAM^SCAPMCU3(SCTM),"^",8)
+ I SCTMCT'<SCTMMAX  D  G QTASTM:$$WAITYN(),QTASTM:'$$YESNO2()
+ .W !,"This assignment will reach or exceeded the maximum set for this team."
+ .W !,"Currently assigned: "_SCTMCT
+ .W !,"Maximum set for team: "_SCTMMAX
+ I SCTMCT<SCTMMAX,'$$CONFIRM() G QTASTM
+ S SCTM=+Y
+ ;setup fields
+ S SCTMFLDS(.08)=1 ;primary care assignment
+ S SCTMFLDS(.11)=$G(DUZ,.5)
+ D NOW^%DTC S SCTMFLDS(.12)=%
+ IF $$ACPTTM^SCAPMC(DFN,SCTM,"SCTMFLDS",SCASSDT,"SCTPTME") D
+ .S SCSELECT=$$SELPOS()
+ .D:$L(SCSELECT) ASTP ;prompt for position prompt
+ .S OK=1
+QTASTM W !,"Team Assignment "_$S(OK:"made",1:"NOT made.")
+ S:$D(SDWLPCMM) SDWLPCMM=OK  ; 446
+ Q
+ASTP ;assign patient to PC practitioner
+ N DIC,Y,OK,SCCL,X,SCTPFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS
+ S OK=0
+ W !!,"About to Assign "_$$NAME(DFN)_" to PC Position Assignment"
+ I $$SC(DFN) W !!,"********** This patient is 50 percent or greater service-connected ************"
+ ;lookup to display only position and [practitioner]
+ IF SCSELECT="PRACT" D
+ .S DIC("W")="N SCP1 S SCP1=$G(^SCTM(404.52,Y,0)) W ""    ["",$P($G(^VA(200,+$P(SCP1,U,3),0)),U,1),""]"""
+ .S DIC("A")="POSITION's Current PRACTITIONER: "
+ .S DIC="^SCTM(404.52,"
+ .;Must be from team, must be activation,must not have future inactivation
+ .S DIC("S")="I $$PRACSCR^SCMCQK1(Y)"
+ .S D="C"
+ ELSE  D
+ .S DIC="^SCTM(404.57,"
+ .S D="B"
+ .S DIC("A")="POSITION's Name: "
+ .S DIC("S")="I $$POSSCR^SCMCQK1(Y)"
+ S DIC(0)="AEMQZ"
+ D MIX^DIC1
+ G:Y<1 QTASTP
+ IF SCSELECT="PRACT" D
+ .S SCTP=$P(Y,U,2)
+ ELSE  D
+ .S SCTP=$P(Y,U,1)
+ S SCASSDT=$$DATE("A")
+ G:SCASSDT<1 QTASTP
+ S SCTMCT=$$PCPOSCNT^SCAPMCU1(SCTP),SCTMMAX=+$P($G(^SCTM(404.57,SCTP,0)),U,8)
+ I SCTMCT'<SCTMMAX D  G QTASTP:$$WAITYN,QTASTP:'$$YESNO2
+ .W !,"This assignment will reach or exceeded the maximum set for this position."
+ .W !,"Currently assigned: "_SCTMCT
+ .W !,"Maximum set for position: "_SCTMMAX
+ G:'$$CONFIRM() QTASTP
+ ;setup fields
+ S SCTPFLDS(.03)=SCASSDT
+ S SCTPFLDS(.05)=1 ;pc pract role
+ S SCTPFLDS(.06)=$G(DUZ,.5)
+ D NOW^%DTC S SCTPFLDS(.07)=%
+ IF $$ACPTTP^SCAPMC21(DFN,SCTP,"SCTPFLDS",SCASSDT,"SCTPTME",0) D
+ .S OK=1
+ .S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,0))
+ .D:SCCL ENRCL
+QTASTP W !,"Position Assignment "_$S(OK:"made",1:"NOT made.")
+ S:$D(SDWLPCMM) SDWLPCMM=OK ;446
+ Q
+NAME(DFN) ;return patient name
+ Q $P($G(^DPT(DFN,0)),U,1)
+POSITION(SCTP) ;return position name
+ Q $P($G(^SCTM(404.57,SCTP,0)),U,1)
+TEAMNM(SCTM) ;return team name
+ Q $P($G(^SCTM(404.51,SCTM,0)),U,1)
+CLINIC(SCCL) ;return clinic name
+ Q $P($G(^SC(+SCCL,0)),U,1)
+YESNO() ;
+ N DIR,X,Y
+ S DIR(0)="Y",DIR("B")="YES"
+ D ^DIR
+ Q Y>0
+YESNO1() ; added per SD*5.3*436
+ N DIR,X,Y
+ S DIR(0)="Y",DIR("A")="Do you wish to assign this patient now (Yes/No)?"
+ S DIR("B")="NO"
+ D ^DIR
+ Q Y>0
+YESNO2() ;
+ N DIR,X,Y
+ S DIR(0)="Y",DIR("B")="NO"
+ S DIR("A")="Do you wish to continue with the assignment (Yes/No)?"
+ D ^DIR
+ Q Y>0
+CONFIRM() ;confirmation call
+ N DIR,X,Y
+ S DIR("A")="Are you sure (Yes/No)"
+ S DIR(0)="Y"
+ D ^DIR
+ Q +Y=1
+SELPOS() ;return way to select position: 1=PRACT,2=POSIT,3=NONE
+ N DIR,X,Y
+ W !,"Choose way to select PC POSITION Assignment: "
+ S DIR(0)="SO^0:NONE;1:BY PRACTITIONER ASSIGNMENT;2:BY POSITION ASSIGNMENT"
+ S DIR("B")=1
+ D ^DIR
+ Q $S(Y'>0:"",+Y=1:"PRACT",1:"POSIT")
+DATE(TYPE) ;return date type=A or D
+ N DIR,X,Y
+ S DIR("A")=$S(TYPE="A":"Assignment",1:"Unassignment")_" date: "
+ S DIR(0)="DA^::EXP"
+ S Y=$S($D(SCDISCH):SCDISCH,$D(SCASSDT):SCASSDT,(TYPE="A"):"TODAY",1:"TODAY-1")
+ X ^DD("DD")
+ S DIR("B")=Y
+ D ^DIR
+ Q Y
+ACTCL(DFN,SCCL) ;is patient enrolled in clinic?
+ N SCXX
+ S SCXX=$O(^DPT(DFN,"DE","B",SCCL,9999),-1)
+ Q $S('SCXX:0,($P(^DPT(DFN,"DE",+SCXX,0),U,2)="I"):0,1:1)
+PRACSCR(SC40452) ;screen for for file 404.52
+ N SCP,SCNODE,OK
+ S SCP=$G(^SCTM(404.52,SC40452,0))
+ S OK=0
+ G:'SCP QTPP
+ S SCNODE=$G(^SCTM(404.57,+SCP,0))
+ S OK=$S($P(SCNODE,U,2)'=SCTM:0,'$P(SCNODE,U,4):0,($O(^SCTM(404.52,"AIDT",+SCP,1,""))'=-$P(SCP,U,2)):0,($O(^SCTM(404.52,"AIDT",+SCP,0,-$P(SCP,U,2)),-1)):0,($$ACTTP^SCMCTPU(+SCP)>0):1,1:0)
+QTPP Q OK
+POSSCR(SCTP) ;screen for file 404.57
+ N SCNODE
+ S SCNODE=$G(^SCTM(404.57,SCTP,0))
+ Q $S($P(SCNODE,U,2)'=SCTM:0,'$P(SCNODE,U,4):0,($$ACTTP^SCMCTPU(SCTP)>0):1,1:0)
+ Q
+WAITYN() ;
+ N %,OK,Y
+ I SCTMCT<SCTMMAX Q 0
+ N A,SC S A=$$ONWAIT^SCMCWAIT(DFN) I A W:(+A=3) !,$P(A,";",2) I $S($G(SCTP):A>1,1:1) Q 0
+ N DIR,X,Y
+ S DIR(0)="Y",DIR("B")="NO"
+ S DIR("A")="Do you wish to place the patient on the wait list (Yes/No)?"
+ D ^DIR
+ I Y=1 S Y=$$WAITS^SCMCWAIT(DFN,SCTM,$G(SCTP),$G(SC)) I Y>0 W !,"Patient Placed on Wait List"
+ Q Y>0
+SC(DFN) ;Is patient 50 to 100%
+ D ELIG^VADPT Q $P($G(VAEL(3)),U,2)>49
