source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCQK1.m@ 1540

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