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

SCMCQK1.m

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