SCMCQK2 ;ALB/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge ; 5/16/12 12:09pm
;;5.3;Scheduling;**297,563**;AUG 13, 1993;Build 45
;
DSPL ;
N LP,SCD,SCPOS
S SCTOK=$$TMPT^SCAPMC3(DFN,"SCDT","","SCD","SCER1")
S SCOK=$$TPPT^SCAPMC(DFN,"","","","","","","SCPOS","SCBKERR")
;
;loop through positions only getting the ones associated with the team
;and that are active.
;
F LP=0:0 S LP=$O(SCPOS(LP)) Q:'LP D
.I $P(SCPOS(LP),U,6)]"" K SCPOS(LP) Q
.S SCPOS("T",$P(SCPOS(LP),U,3),+SCPOS(LP))=SCPOS(LP)
S CNT=0,POS=0
F LP=0:0 S LP=$O(SCD(LP)) Q:'LP S A=SCD(LP) I '$P(A,U,8) D
.I 'CNT W !!,"NON PC ASSIGNMENTS",!
.S CNT=CNT+1 W !,CNT,?4,"Non-PC Team: "_$P(A,U,2),?48,"Phone: "_$P($G(^SCTM(404.51,+A,0)),U,2) S DATA(CNT)=+A
.F I=0:0 S I=$O(SCPOS("T",+A,I)) Q:'I D
..I $P(DATA(CNT),U,2) S CNT=CNT+1
..S B=SCPOS("T",+A,I)
..S DATA(CNT)=(+A)_U_(+B),POS=1
..S SCPR=$$GETPRTP^SCAPMCU2(+B,DT),RES=$$NEWPERSN^SCMCGU(+SCPR,"SCPR")
..W:$X>76 !,CNT,?4,"Non-PC Team: "_$P(A,U,2),?48,"Phone: "_$P($G(^SCTM(404.51,+A,0)),U,2)
..W !,?7,"Provider: "_$P(SCPR,U,2),?45,"Position: "_$P(B,U,2)_" "
..W !,?10,"Pager: "_$P($G(SCPR(+SCPR)),U,5),?48,"Phone: ",$P($G(SCPR(+SCPR)),U,2),?77," "
I 'CNT W !,"No active NON PC ASSIGNMENTS for this patient",!
Q
NPC N SCDT,SCER1,SCD,SCPOS
D DSPL
S DIR(0)="SO^0:NONE;1:TEAM ASSIGNMENT;"_$S(CNT:"2:POSITION ASSIGNMENT;3:UNASSIGNMENT;",1:"")
S DIR("B")=1
D ^DIR
I Y=0 Q
I $D(DIRUT) K DIRUT,X,Y Q ; Quit operation if the user enters "^" or times out SD*5.3*563
I Y=1 D ASTM G NPC
READ S:CNT=1 X=1 I CNT>1 W !,"Select 1-"_CNT_": " R X:DTIME Q:X=U S X=+X I X>CNT!X<1 G READ
I Y=3 S DATA=DATA(+X) S SCTPSTAT=1,SCTP=+$P(DATA,U,2),SCTM=+DATA D UNTP:SCTP,UNTM:'SCTP G NPC
S DATA=DATA(+X),SCTM=+DATA S SCSELECT=$$SELPOS() G NPC:'$L(SCSELECT) D ASTP G NPC
Q
UNTP ;unassign patient from position
IF '$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",DFN) ;SD*5.3*563 Pass DFN
G:SCDISCH<1 QTUNTP
G:'$$CONFIRM() QTUNTP
S OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)
G:OK'>0 QTUNTP
S SCCL=$P($G(^SCTM(404.57,+$G(SCTP),0)),U,9)
QTUNTP W !,"Position Unassignment "_$S(OK:"made.",1:"NOT made.")
Q
;
;
UNTM ;
;assign patient from non 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",DFN) ;SD*5.3*563 Pass DFN
G:SCDISCH<1 QTUNTM
G:'$$CONFIRM() QTUNTM
IF 'SCTPSTAT D G:OK2'>0 QTUNTM
.W !,"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)
S OK3=$$ALLPOS^SCMCQK1()
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
;
ASTM ;assign patient to 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 non primary care team"
I $$SC^SCMCQK1(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) I $$NEW^SCMCQK2()"
; - select from active teams that can not be PC Teams
D ^DIC
G:Y<1 QTASTM
S SCTM=+Y
S SCASSDT=$$DATE("A",DFN) ;SD*5.3*563 Pass DFN
G:SCASSDT<1 QTASTM
S SCTMCT=$$TEAMCNT^SCAPMCU1(SCTM)
S SCTMMAX=$P($$GETEAM^SCAPMCU3(SCTM),"^",8)
I SCTMCT'<SCTMMAX D G 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.")
Q
ASTP ;assign patient to 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 non PC Position Assignment"
I $$SC^SCMCQK1(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 active,must not have future inactivation
.S DIC("S")="I $$PRACSCR^SCMCQK2(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^SCMCQK2(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",DFN) ;SD*5.3*563 Pass DFN
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:'$$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=$P(^SCTM(404.57,SCTP,0),U,9)
QTASTP W !,"Position Assignment "_$S(OK:"made",1:"NOT made.")
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
;
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 NON 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,DFN) ;type=A(Assignment) or D(Unassignment)
; Returns assignment/unassignment date or "^"
I '$G(DFN) Q -1
N DIR,X,Y,SDFLG,SDY
;SD*5.3*563 SDFLG=0 allow to proceed with date if prior to DOD
F D Q:SDFLG=0
.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 K DIR S SDY=Y
.I $D(DIRUT) K DIRUT,DUOUT,X,Y S SDFLG=0 Q
.D WARNMESS^SCMCQK1(SDY,DFN,.SDFLG)
Q SDY
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
NEW() ;
F I=0:0 S I=$O(SCD(I)) Q:'I I (+SCD(I))=(+Y) Q
Q 'I
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCQK2 8175 printed Sep 23, 2025@20:17:38 Page 2
SCMCQK2 ;ALB/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge ; 5/16/12 12:09pm
+1 ;;5.3;Scheduling;**297,563**;AUG 13, 1993;Build 45
+2 ;
DSPL ;
+1 NEW LP,SCD,SCPOS
+2 SET SCTOK=$$TMPT^SCAPMC3(DFN,"SCDT","","SCD","SCER1")
+3 SET SCOK=$$TPPT^SCAPMC(DFN,"","","","","","","SCPOS","SCBKERR")
+4 ;
+5 ;loop through positions only getting the ones associated with the team
+6 ;and that are active.
+7 ;
+8 FOR LP=0:0
SET LP=$ORDER(SCPOS(LP))
if 'LP
QUIT
Begin DoDot:1
+9 IF $PIECE(SCPOS(LP),U,6)]""
KILL SCPOS(LP)
QUIT
+10 SET SCPOS("T",$PIECE(SCPOS(LP),U,3),+SCPOS(LP))=SCPOS(LP)
End DoDot:1
+11 SET CNT=0
SET POS=0
+12 FOR LP=0:0
SET LP=$ORDER(SCD(LP))
if 'LP
QUIT
SET A=SCD(LP)
IF '$PIECE(A,U,8)
Begin DoDot:1
+13 IF 'CNT
WRITE !!,"NON PC ASSIGNMENTS",!
+14 SET CNT=CNT+1
WRITE !,CNT,?4,"Non-PC Team: "_$PIECE(A,U,2),?48,"Phone: "_$PIECE($GET(^SCTM(404.51,+A,0)),U,2)
SET DATA(CNT)=+A
+15 FOR I=0:0
SET I=$ORDER(SCPOS("T",+A,I))
if 'I
QUIT
Begin DoDot:2
+16 IF $PIECE(DATA(CNT),U,2)
SET CNT=CNT+1
+17 SET B=SCPOS("T",+A,I)
+18 SET DATA(CNT)=(+A)_U_(+B)
SET POS=1
+19 SET SCPR=$$GETPRTP^SCAPMCU2(+B,DT)
SET RES=$$NEWPERSN^SCMCGU(+SCPR,"SCPR")
+20 if $X>76
WRITE !,CNT,?4,"Non-PC Team: "_$PIECE(A,U,2),?48,"Phone: "_$PIECE($GET(^SCTM(404.51,+A,0)),U,2)
+21 WRITE !,?7,"Provider: "_$PIECE(SCPR,U,2),?45,"Position: "_$PIECE(B,U,2)_" "
+22 WRITE !,?10,"Pager: "_$PIECE($GET(SCPR(+SCPR)),U,5),?48,"Phone: ",$PIECE($GET(SCPR(+SCPR)),U,2),?77," "
End DoDot:2
End DoDot:1
+23 IF 'CNT
WRITE !,"No active NON PC ASSIGNMENTS for this patient",!
+24 QUIT
NPC NEW SCDT,SCER1,SCD,SCPOS
+1 DO DSPL
+2 SET DIR(0)="SO^0:NONE;1:TEAM ASSIGNMENT;"_$SELECT(CNT:"2:POSITION ASSIGNMENT;3:UNASSIGNMENT;",1:"")
+3 SET DIR("B")=1
+4 DO ^DIR
+5 IF Y=0
QUIT
+6 ; Quit operation if the user enters "^" or times out SD*5.3*563
IF $DATA(DIRUT)
KILL DIRUT,X,Y
QUIT
+7 IF Y=1
DO ASTM
GOTO NPC
READ if CNT=1
SET X=1
IF CNT>1
WRITE !,"Select 1-"_CNT_": "
READ X:DTIME
if X=U
QUIT
SET X=+X
IF X>CNT!X<1
GOTO READ
+1 IF Y=3
SET DATA=DATA(+X)
SET SCTPSTAT=1
SET SCTP=+$PIECE(DATA,U,2)
SET SCTM=+DATA
if SCTP
DO UNTP
if 'SCTP
DO UNTM
GOTO NPC
+2 SET DATA=DATA(+X)
SET SCTM=+DATA
SET SCSELECT=$$SELPOS()
if '$LENGTH(SCSELECT)
GOTO NPC
DO ASTP
GOTO NPC
+3 QUIT
UNTP ;unassign patient from position
+1 IF '$GET(SCTP)
WRITE !,"No position defined"
QUIT
+2 NEW OK,SCER,SCCL,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS
+3 SET OK=0
+4 WRITE !,"About to Unassign "_$$NAME(DFN)_" from: ",!,?8,$$POSITION(SCTP)_" position ["_$PIECE($$GETPRTP^SCAPMCU2(SCTP,DT),U,2)_"]"
+5 ;SD*5.3*563 Pass DFN
SET SCDISCH=$$DATE("D",DFN)
+6 if SCDISCH<1
GOTO QTUNTP
+7 if '$$CONFIRM()
GOTO QTUNTP
+8 SET OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)
+9 if OK'>0
GOTO QTUNTP
+10 SET SCCL=$PIECE($GET(^SCTM(404.57,+$GET(SCTP),0)),U,9)
QTUNTP WRITE !,"Position Unassignment "_$SELECT(OK:"made.",1:"NOT made.")
+1 QUIT
+2 ;
+3 ;
UNTM ;
+1 ;assign patient from non pc team (and pc position if possible)
+2 NEW OK,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS,OK2,OK3
+3 SET OK=0
+4 WRITE !!,"About to Unassign "_$$NAME(DFN)_" from "_$$TEAMNM(SCTM)_" team"
+5 if 'SCTPSTAT
WRITE !,?5,"AND from "_$$POSITION(SCTP)_" position ["_$$WRITETP^SCMCDD1(SCTP)_"]"
+6 ;SD*5.3*563 Pass DFN
SET SCDISCH=$$DATE("D",DFN)
+7 if SCDISCH<1
GOTO QTUNTM
+8 if '$$CONFIRM()
GOTO QTUNTM
+9 IF 'SCTPSTAT
Begin DoDot:1
+10 WRITE !,"Unassigned."
+11 SET OK2=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)
+12 IF OK2>0
Begin DoDot:2
+13 WRITE "made."
+14 SET SCCL=$PIECE(^SCTM(404.57,SCTP,0),U,9)
End DoDot:2
End DoDot:1
if OK2'>0
GOTO QTUNTM
+15 SET OK3=$$ALLPOS^SCMCQK1()
+16 IF $$OKINPTTM^SCMCTMU2(DFN,SCTM,SCDISCH)
Begin DoDot:1
+17 SET OK=$$INPTSCTM^SCAPMC7(DFN,SCTM,SCDISCH,.SCER)
End DoDot:1
+18 IF '$TEST
Begin DoDot:1
+19 WRITE !,"Future/Current Patient-Position Assignment exists"
End DoDot:1
QTUNTM WRITE !,"Team Unassignment "_$SELECT(OK:"made",1:"NOT made.")
+1 QUIT
+2 ;
ASTM ;assign patient to team
+1 NEW DIC,Y,OK,SCTM,SCTMFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS
+2 SET OK=0
+3 WRITE !!,"About to Assign "_$$NAME(DFN)_" to a non primary care team"
+4 IF $$SC^SCMCQK1(DFN)
WRITE !!,"********** This patient is 50 percent or greater service-connected ************"
+5 SET DIC="^SCTM(404.51,"
+6 SET DIC(0)="AEMQZ"
+7 SET DIC("S")="IF $$ACTTM^SCMCTMU(Y,DT) I $$NEW^SCMCQK2()"
+8 ; - select from active teams that can not be PC Teams
+9 DO ^DIC
+10 if Y<1
GOTO QTASTM
+11 SET SCTM=+Y
+12 ;SD*5.3*563 Pass DFN
SET SCASSDT=$$DATE("A",DFN)
+13 if SCASSDT<1
GOTO QTASTM
+14 SET SCTMCT=$$TEAMCNT^SCAPMCU1(SCTM)
+15 SET SCTMMAX=$PIECE($$GETEAM^SCAPMCU3(SCTM),"^",8)
+16 IF SCTMCT'<SCTMMAX
Begin DoDot:1
+17 WRITE !,"This assignment will reach or exceeded the maximum set for this team."
+18 WRITE !,"Currently assigned: "_SCTMCT
+19 WRITE !,"Maximum set for team: "_SCTMMAX
End DoDot:1
if '$$YESNO2()
GOTO QTASTM
+20 IF SCTMCT<SCTMMAX
IF '$$CONFIRM()
GOTO QTASTM
+21 SET SCTM=+Y
+22 ;setup fields
+23 ;S SCTMFLDS(.08)=1 ;primary care assignment
+24 SET SCTMFLDS(.11)=$GET(DUZ,.5)
+25 DO NOW^%DTC
SET SCTMFLDS(.12)=%
+26 IF $$ACPTTM^SCAPMC(DFN,SCTM,"SCTMFLDS",SCASSDT,"SCTPTME")
Begin DoDot:1
+27 SET SCSELECT=$$SELPOS()
+28 ;prompt for position prompt
if $LENGTH(SCSELECT)
DO ASTP
+29 SET OK=1
End DoDot:1
QTASTM WRITE !,"Team Assignment "_$SELECT(OK:"made",1:"NOT made.")
+1 QUIT
ASTP ;assign patient to practitioner
+1 NEW DIC,Y,OK,SCCL,X,SCTPFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS
+2 SET OK=0
+3 WRITE !!,"About to Assign "_$$NAME(DFN)_" to non PC Position Assignment"
+4 IF $$SC^SCMCQK1(DFN)
WRITE !!,"********** This patient is 50 percent or greater service-connected ************"
+5 ;lookup to display only position and [practitioner]
+6 IF SCSELECT="PRACT"
Begin DoDot:1
+7 SET DIC("W")="N SCP1 S SCP1=$G(^SCTM(404.52,Y,0)) W "" ["",$P($G(^VA(200,+$P(SCP1,U,3),0)),U,1),""]"""
+8 SET DIC("A")="POSITION's Current PRACTITIONER: "
+9 SET DIC="^SCTM(404.52,"
+10 ;Must be from team, must be active,must not have future inactivation
+11 SET DIC("S")="I $$PRACSCR^SCMCQK2(Y)"
+12 SET D="C"
End DoDot:1
+13 IF '$TEST
Begin DoDot:1
+14 SET DIC="^SCTM(404.57,"
+15 SET D="B"
+16 SET DIC("A")="POSITION's Name: "
+17 SET DIC("S")="I $$POSSCR^SCMCQK2(Y)"
End DoDot:1
+18 SET DIC(0)="AEMQZ"
+19 DO MIX^DIC1
+20 if Y<1
GOTO QTASTP
+21 IF SCSELECT="PRACT"
Begin DoDot:1
+22 SET SCTP=$PIECE(Y,U,2)
End DoDot:1
+23 IF '$TEST
Begin DoDot:1
+24 SET SCTP=$PIECE(Y,U,1)
End DoDot:1
+25 ;SD*5.3*563 Pass DFN
SET SCASSDT=$$DATE("A",DFN)
+26 if SCASSDT<1
GOTO QTASTP
+27 SET SCTMCT=$$PCPOSCNT^SCAPMCU1(SCTP)
SET SCTMMAX=+$PIECE($GET(^SCTM(404.57,SCTP,0)),U,8)
+28 IF SCTMCT'<SCTMMAX
Begin DoDot:1
+29 WRITE !,"This assignment will reach or exceeded the maximum set for this position."
+30 WRITE !,"Currently assigned: "_SCTMCT
+31 WRITE !,"Maximum set for position: "_SCTMMAX
End DoDot:1
if '$$YESNO2
GOTO QTASTP
+32 if '$$CONFIRM()
GOTO QTASTP
+33 ;setup fields
+34 SET SCTPFLDS(.03)=SCASSDT
+35 ;S SCTPFLDS(.05)=1 ;pc pract role
+36 SET SCTPFLDS(.06)=$GET(DUZ,.5)
+37 DO NOW^%DTC
SET SCTPFLDS(.07)=%
+38 IF $$ACPTTP^SCAPMC21(DFN,SCTP,"SCTPFLDS",SCASSDT,"SCTPTME",0)
Begin DoDot:1
+39 SET OK=1
+40 SET SCCL=$PIECE(^SCTM(404.57,SCTP,0),U,9)
End DoDot:1
QTASTP WRITE !,"Position Assignment "_$SELECT(OK:"made",1:"NOT made.")
+1 QUIT
NAME(DFN) ;return patient name
+1 QUIT $PIECE($GET(^DPT(DFN,0)),U,1)
+2 ;
POSITION(SCTP) ;return position name
+1 QUIT $PIECE($GET(^SCTM(404.57,SCTP,0)),U,1)
+2 ;
TEAMNM(SCTM) ;return team name
+1 QUIT $PIECE($GET(^SCTM(404.51,SCTM,0)),U,1)
+2 ;
CLINIC(SCCL) ;return clinic name
+1 QUIT $PIECE($GET(^SC(+SCCL,0)),U,1)
+2 ;
YESNO() ;
+1 NEW DIR,X,Y
+2 SET DIR(0)="Y"
SET DIR("B")="YES"
+3 DO ^DIR
+4 QUIT Y>0
+5 ;
YESNO2() ;
+1 NEW DIR,X,Y
+2 SET DIR(0)="Y"
SET DIR("B")="NO"
+3 SET DIR("A")="Do you wish to continue with the assignment (Yes/No)?"
+4 DO ^DIR
+5 QUIT Y>0
CONFIRM() ;confirmation call
+1 NEW DIR,X,Y
+2 SET DIR("A")="Are you sure (Yes/No)"
+3 SET DIR(0)="Y"
+4 DO ^DIR
+5 QUIT +Y=1
+6 ;
SELPOS() ;return way to select position: 1=PRACT,2=POSIT,3=NONE
+1 NEW DIR,X,Y
+2 WRITE !,"Choose way to select NON PC POSITION Assignment: "
+3 SET DIR(0)="SO^0:NONE;1:BY PRACTITIONER ASSIGNMENT;2:BY POSITION ASSIGNMENT"
+4 SET DIR("B")=1
+5 DO ^DIR
+6 QUIT $SELECT(Y'>0:"",+Y=1:"PRACT",1:"POSIT")
+7 ;
DATE(TYPE,DFN) ;type=A(Assignment) or D(Unassignment)
+1 ; Returns assignment/unassignment date or "^"
+2 IF '$GET(DFN)
QUIT -1
+3 NEW DIR,X,Y,SDFLG,SDY
+4 ;SD*5.3*563 SDFLG=0 allow to proceed with date if prior to DOD
+5 FOR
Begin DoDot:1
+6 SET DIR("A")=$SELECT(TYPE="A":"Assignment",1:"Unassignment")_" date: "
+7 SET DIR(0)="DA^::EXP"
+8 SET Y=$SELECT($DATA(SCDISCH):SCDISCH,$DATA(SCASSDT):SCASSDT,(TYPE="A"):"TODAY",1:"TODAY-1")
+9 XECUTE ^DD("DD")
+10 SET DIR("B")=Y
+11 DO ^DIR
KILL DIR
SET SDY=Y
+12 IF $DATA(DIRUT)
KILL DIRUT,DUOUT,X,Y
SET SDFLG=0
QUIT
+13 DO WARNMESS^SCMCQK1(SDY,DFN,.SDFLG)
End DoDot:1
if SDFLG=0
QUIT
+14 QUIT SDY
PRACSCR(SC40452) ;screen for for file 404.52
+1 NEW SCP,SCNODE,OK
+2 SET SCP=$GET(^SCTM(404.52,SC40452,0))
+3 SET OK=0
+4 if 'SCP
GOTO QTPP
+5 SET SCNODE=$GET(^SCTM(404.57,+SCP,0))
+6 SET OK=$SELECT($PIECE(SCNODE,U,2)'=SCTM:0,$PIECE(SCNODE,U,4):0,($ORDER(^SCTM(404.52,"AIDT",+SCP,1,""))'=-$PIECE(SCP,U,2)):0,($ORDER(^SCTM(404.52,"AIDT",+SCP,0,-$PIECE(SCP,U,2)),-1)):0,($$ACTTP^SCMCTPU(+SCP)>0):1,1:0)
QTPP QUIT OK
+1 ;
POSSCR(SCTP) ;screen for file 404.57
+1 NEW SCNODE
+2 SET SCNODE=$GET(^SCTM(404.57,SCTP,0))
+3 QUIT $SELECT($PIECE(SCNODE,U,2)'=SCTM:0,$PIECE(SCNODE,U,4):0,($$ACTTP^SCMCTPU(SCTP)>0):1,1:0)
+4 QUIT
NEW() ;
+1 FOR I=0:0
SET I=$ORDER(SCD(I))
if 'I
QUIT
IF (+SCD(I))=(+Y)
QUIT
+2 QUIT 'I
