SCMCTSK9 ;;BP/DMR - PCMM ; 18 Apr 2003 9:36 AM
;;5.3;Scheduling;**297,526**;AUG 13, 1993;Build 8
Q
EXTKEY ;
N Y,% W @IOF,!,$G(SCDHD) D NOW^%DTC S Y=% W:$X>(IOM-40) ! W ?(IOM-40)
W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 " "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12)
W ?(IOM-15),"PAGE: "_($G(DC)+1)
S Y="",$P(Y,"-",IOM)="" W !,Y,!!
W !,"Column Heading Explanation of column headings"
W !
W !,"Patient Name Name of patient scheduled to be inactivated from their primary care team and position/provider."
W !,"SSN SSN number."
W !,"Institution Institution name, previously called Division, in which patient receives primary care."
W !,"PC Team The patient's assigned Primary Care team in PCMM."
W !,"Provider/ Name of Associate Primary Care Provider (AP) assigned to patient, if there is one."
W !," Team Position The name of the team position to which the Associate Primary Care Provider (AP) is assigned."
W !,"Current Preceptor/ Name of Primary Care Provider (PCP) assigned to patient. Every Primary Care patient should"
W !," Team Position be assigned to one PCP. The name of the team position to which the Primary Care Provider (PCP)"
W !," is assigned."
W !,"Date Scheduled for Date patient will be inactivated from PCMM and their Primary Care team and provider/position unless"
W !," Inactivation they have a completed outpatient appointment encounter with their current PCP or AP before this date."
W !," Note: There is a patient reassignment option, which allows an inactivated patient to be reactivated"
W !," to their previous Primary Care team and position if they return for care."
W !,"Reason for Extended The reason entered for extending the patient's time before inactivation from PC panels."
W !," Inactivation Entry of this field is in the PCMM GUI, Patient drop down menu, and the Extend Patient's Date for"
W !," Inactivation from PC Panels option."
Q
EXTCHUI ;roll n scroll option to extend a patient
N DA,DIC,DIE,DR,SCTM,SCARRAY,SCHIGH,SCX,V1
S SCTM=0 F D P1 Q:+SCTM<1
Q
P1 D GCL S DIC="^SCTM(404.51,",DIC(0)="AEQMZ" D ^DIC S SCTM=+Y Q:+SCTM<1
W !,"Searching...",!
D EXTEND(.SCARRAY,SCTM)
I $G(^TMP("SCMCTSK9","OUT",$J,1))="<DATA>" W !,"No Patients to Extend..." D GCL Q
S SCHIGH=$O(^TMP("SCMCTSK9","OUT",$J,9999999),-1)
S SCX=999 F Q:(SCX="^")!(SCX="") D P2
Q
P2 W !,"Select From: ",!!
S V1=0 F S V1=$O(^TMP("SCMCTSK9","OUT",$J,V1)) Q:'V1 D
. W $J(V1,2)_" ",$P(^TMP("SCMCTSK9","OUT",$J,V1),U,3),!
F W !,"Select 1-",SCHIGH," " R SCX:DTIME Q:(SCX="^")!(SCX="")!((SCX'>SCHIGH)&(SCX>0)) D
. I $E(SCX,1)="?" W !,"Select 1-",SCHIGH," or '^' to exit" Q
. I (+SCX<1)!(+SCX>SCHIGH) W !,"Select a valid number" Q
I SCX'?1.9N Q
S DIE="^SCPT(404.43,"
S DA=$P(^TMP("SCMCTSK9","OUT",$J,SCX),U)
S DR=".13//DO NOT EXTEND;S Y=.16 I X=4 S Y=.14;.14;.16////"_DUZ
D ^DIE
Q
EXTEND(DATA,SCTEAM) ;return list of patients to inactivate in next 60 days
;IEN^POSITION^PATIENT^EXTENDED^REASON
K DATA,SCDATA,SDDATA
N CNT,I,J,K,A,POSA S CNT=1 S SCTEAM=$G(SCTEAM),^TMP("SCMCTSK9","OUT",$J,1)="<DATA>"
D DT^DICRW S X="T-9M" D ^%DT S STDT=Y
S X="T-21M" D ^%DT S TYDT=+Y ;MAKE THIS 21
S POSA=""
F S POSA=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA)) Q:POSA="" D
.F POS=0:0 S POS=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA,POS)) Q:'POS D POS
EX1 S A="^TMP(""SCMCTSK9"",$J)",CNT=1 F S A=$Q(@A) Q:A=""!($P(A,",",2)'=$J) D
.S B=@A
.S ^TMP("SCMCTSK9","OUT",$J,CNT)=(+$P(B,U,3))_U_$TR($P($P(A,"(",4),","),$C(34))_U_$TR($P(B,U,2),$C(34))_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,13)_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,14)
.S CNT=CNT+1
Q
POS I '$$DATES^SCAPMCU1(404.59,POS) Q ;Not an active position
I '$P($G(^SCTM(404.57,POS,0)),U,4) Q ;Not PC
;get patients for this position
K ^TMP("SC TMP LIST",$J)
S X=$$PTTP^SCAPMC(POS,"",.SCLIST,.SCERR)
S J=0 F S J=$O(@SCLIST@(J)) Q:'J S SCDATA=^(J) D
.N J I $P(SCDATA,U,4)>STDT Q
.I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,5) Q
.I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,15) Q
.S DFN=+SCDATA
.D SEEN Q:SEEN
.S ^TMP("SCMCTSK9",$J,$P($G(^SCTM(404.57,POS,0)),U),$P(SCDATA,U,2),+SCDATA)=SCDATA,CNT=CNT+1
K @SCLIST
Q
SEEN ;was patient seen
S SEEN=0
N SCPRO,I,PRECP,PRO
N X,SCPRDTS,SCPR
;get list of providers for this position
S PROV=+$$GETPRTP^SCAPMCU2(POS,DT) S SCPRO(+PROV)=""
S SCPRDTS("BEGIN")=TYDT
S SCPRDTS("END")=DT
S X=$$PRTP^SCAPMC(POS,"SCPRDTS","SCPR")
F I=0:0 S I=$O(SCPR(I)) Q:'I S SCPRO(+SCPR(I))=""
S PRECP=0 I $G(PREC),$G(PREC)'=POS S PRECP=+$$GETPRTP^SCAPMCU2(PREC,DT),SCPRO(+PRECP)=""
F I=TYDT:0 S I=$O(^SCE("ADFN",DFN,I)) Q:'I D Q:SEEN
.F J=0:0 S J=$O(^SCE("ADFN",DFN,I,J)) Q:'J D Q:SEEN
..N VISIT S VISIT=+$P($G(^SCE(J,0)),U,5) I $G(^SCE(J,0))<$G(TYDT) Q
..F PRO=0:0 S PRO=$O(SCPRO(PRO)) Q:'PRO D Q:SEEN
...I $D(^SDD(409.44,"AO",J,$G(PRO))) S SEEN=1 Q ;GET THE PROVIDERJ
...N V F V=0:0 S V=$O(^AUPNVPRV("AD",VISIT,V)) Q:'V I PRO=(+$G(^AUPNVPRV(V,0))) S SEEN=1 Q
Q
GCL ;clean temp globals
K ^TMP("SCMCTSK9",$J)
K ^TMP("SCMCTSK9","OUT",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCTSK9 5351 printed Sep 23, 2025@20:18 Page 2
SCMCTSK9 ;;BP/DMR - PCMM ; 18 Apr 2003 9:36 AM
+1 ;;5.3;Scheduling;**297,526**;AUG 13, 1993;Build 8
+2 QUIT
EXTKEY ;
+1 NEW Y,%
WRITE @IOF,!,$GET(SCDHD)
DO NOW^%DTC
SET Y=%
if $X>(IOM-40)
WRITE !
WRITE ?(IOM-40)
+2 WRITE $PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$EXTRACT(Y,4,5))_" "
if Y#100
WRITE $JUSTIFY(Y#100\1,2)_","
WRITE Y\10000+1700
if Y#1
WRITE " "_$EXTRACT(Y_0,9,10)_":"_$EXTRACT(Y_"000",11,12)
+3 WRITE ?(IOM-15),"PAGE: "_($GET(DC)+1)
+4 SET Y=""
SET $PIECE(Y,"-",IOM)=""
WRITE !,Y,!!
+5 WRITE !,"Column Heading Explanation of column headings"
+6 WRITE !
+7 WRITE !,"Patient Name Name of patient scheduled to be inactivated from their primary care team and position/provider."
+8 WRITE !,"SSN SSN number."
+9 WRITE !,"Institution Institution name, previously called Division, in which patient receives primary care."
+10 WRITE !,"PC Team The patient's assigned Primary Care team in PCMM."
+11 WRITE !,"Provider/ Name of Associate Primary Care Provider (AP) assigned to patient, if there is one."
+12 WRITE !," Team Position The name of the team position to which the Associate Primary Care Provider (AP) is assigned."
+13 WRITE !,"Current Preceptor/ Name of Primary Care Provider (PCP) assigned to patient. Every Primary Care patient should"
+14 WRITE !," Team Position be assigned to one PCP. The name of the team position to which the Primary Care Provider (PCP)"
+15 WRITE !," is assigned."
+16 WRITE !,"Date Scheduled for Date patient will be inactivated from PCMM and their Primary Care team and provider/position unless"
+17 WRITE !," Inactivation they have a completed outpatient appointment encounter with their current PCP or AP before this date."
+18 WRITE !," Note: There is a patient reassignment option, which allows an inactivated patient to be reactivated"
+19 WRITE !," to their previous Primary Care team and position if they return for care."
+20 WRITE !,"Reason for Extended The reason entered for extending the patient's time before inactivation from PC panels."
+21 WRITE !," Inactivation Entry of this field is in the PCMM GUI, Patient drop down menu, and the Extend Patient's Date for"
+22 WRITE !," Inactivation from PC Panels option."
+23 QUIT
EXTCHUI ;roll n scroll option to extend a patient
+1 NEW DA,DIC,DIE,DR,SCTM,SCARRAY,SCHIGH,SCX,V1
+2 SET SCTM=0
FOR
DO P1
if +SCTM<1
QUIT
+3 QUIT
P1 DO GCL
SET DIC="^SCTM(404.51,"
SET DIC(0)="AEQMZ"
DO ^DIC
SET SCTM=+Y
if +SCTM<1
QUIT
+1 WRITE !,"Searching...",!
+2 DO EXTEND(.SCARRAY,SCTM)
+3 IF $GET(^TMP("SCMCTSK9","OUT",$JOB,1))="<DATA>"
WRITE !,"No Patients to Extend..."
DO GCL
QUIT
+4 SET SCHIGH=$ORDER(^TMP("SCMCTSK9","OUT",$JOB,9999999),-1)
+5 SET SCX=999
FOR
if (SCX="^")!(SCX="")
QUIT
DO P2
+6 QUIT
P2 WRITE !,"Select From: ",!!
+1 SET V1=0
FOR
SET V1=$ORDER(^TMP("SCMCTSK9","OUT",$JOB,V1))
if 'V1
QUIT
Begin DoDot:1
+2 WRITE $JUSTIFY(V1,2)_" ",$PIECE(^TMP("SCMCTSK9","OUT",$JOB,V1),U,3),!
End DoDot:1
+3 FOR
WRITE !,"Select 1-",SCHIGH," "
READ SCX:DTIME
if (SCX="^")!(SCX="")!((SCX'>SCHIGH)&(SCX>0))
QUIT
Begin DoDot:1
+4 IF $EXTRACT(SCX,1)="?"
WRITE !,"Select 1-",SCHIGH," or '^' to exit"
QUIT
+5 IF (+SCX<1)!(+SCX>SCHIGH)
WRITE !,"Select a valid number"
QUIT
End DoDot:1
+6 IF SCX'?1.9N
QUIT
+7 SET DIE="^SCPT(404.43,"
+8 SET DA=$PIECE(^TMP("SCMCTSK9","OUT",$JOB,SCX),U)
+9 SET DR=".13//DO NOT EXTEND;S Y=.16 I X=4 S Y=.14;.14;.16////"_DUZ
+10 DO ^DIE
+11 QUIT
EXTEND(DATA,SCTEAM) ;return list of patients to inactivate in next 60 days
+1 ;IEN^POSITION^PATIENT^EXTENDED^REASON
+2 KILL DATA,SCDATA,SDDATA
+3 NEW CNT,I,J,K,A,POSA
SET CNT=1
SET SCTEAM=$GET(SCTEAM)
SET ^TMP("SCMCTSK9","OUT",$JOB,1)="<DATA>"
+4 DO DT^DICRW
SET X="T-9M"
DO ^%DT
SET STDT=Y
+5 ;MAKE THIS 21
SET X="T-21M"
DO ^%DT
SET TYDT=+Y
+6 SET POSA=""
+7 FOR
SET POSA=$ORDER(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA))
if POSA=""
QUIT
Begin DoDot:1
+8 FOR POS=0:0
SET POS=$ORDER(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA,POS))
if 'POS
QUIT
DO POS
End DoDot:1
EX1 SET A="^TMP(""SCMCTSK9"",$J)"
SET CNT=1
FOR
SET A=$QUERY(@A)
if A=""!($PIECE(A,",",2)'=$JOB)
QUIT
Begin DoDot:1
+1 SET B=@A
+2 SET ^TMP("SCMCTSK9","OUT",$JOB,CNT)=(+$PIECE(B,U,3))_U_$TRANSLATE($PIECE($PIECE(A,"(",4),","),$CHAR(34))_U_$TRANSLATE($PIECE(B,U,2),$CHAR(34))_U_$PIECE($GET(^SCPT(404.43,+$PIECE(B,U,3),0)),U,13)_U_$PIECE($GET(^SCPT(404.43,+$PIECE(B,U,3)
,0)),U,14)
+3 SET CNT=CNT+1
End DoDot:1
+4 QUIT
POS ;Not an active position
IF '$$DATES^SCAPMCU1(404.59,POS)
QUIT
+1 ;Not PC
IF '$PIECE($GET(^SCTM(404.57,POS,0)),U,4)
QUIT
+2 ;get patients for this position
+3 KILL ^TMP("SC TMP LIST",$JOB)
+4 SET X=$$PTTP^SCAPMC(POS,"",.SCLIST,.SCERR)
+5 SET J=0
FOR
SET J=$ORDER(@SCLIST@(J))
if 'J
QUIT
SET SCDATA=^(J)
Begin DoDot:1
+6 NEW J
IF $PIECE(SCDATA,U,4)>STDT
QUIT
+7 IF '$PIECE($GET(^SCPT(404.43,+$PIECE(SCDATA,U,3),0)),U,5)
QUIT
+8 IF '$PIECE($GET(^SCPT(404.43,+$PIECE(SCDATA,U,3),0)),U,15)
QUIT
+9 SET DFN=+SCDATA
+10 DO SEEN
if SEEN
QUIT
+11 SET ^TMP("SCMCTSK9",$JOB,$PIECE($GET(^SCTM(404.57,POS,0)),U),$PIECE(SCDATA,U,2),+SCDATA)=SCDATA
SET CNT=CNT+1
End DoDot:1
+12 KILL @SCLIST
+13 QUIT
SEEN ;was patient seen
+1 SET SEEN=0
+2 NEW SCPRO,I,PRECP,PRO
+3 NEW X,SCPRDTS,SCPR
+4 ;get list of providers for this position
+5 SET PROV=+$$GETPRTP^SCAPMCU2(POS,DT)
SET SCPRO(+PROV)=""
+6 SET SCPRDTS("BEGIN")=TYDT
+7 SET SCPRDTS("END")=DT
+8 SET X=$$PRTP^SCAPMC(POS,"SCPRDTS","SCPR")
+9 FOR I=0:0
SET I=$ORDER(SCPR(I))
if 'I
QUIT
SET SCPRO(+SCPR(I))=""
+10 SET PRECP=0
IF $GET(PREC)
IF $GET(PREC)'=POS
SET PRECP=+$$GETPRTP^SCAPMCU2(PREC,DT)
SET SCPRO(+PRECP)=""
+11 FOR I=TYDT:0
SET I=$ORDER(^SCE("ADFN",DFN,I))
if 'I
QUIT
Begin DoDot:1
+12 FOR J=0:0
SET J=$ORDER(^SCE("ADFN",DFN,I,J))
if 'J
QUIT
Begin DoDot:2
+13 NEW VISIT
SET VISIT=+$PIECE($GET(^SCE(J,0)),U,5)
IF $GET(^SCE(J,0))<$GET(TYDT)
QUIT
+14 FOR PRO=0:0
SET PRO=$ORDER(SCPRO(PRO))
if 'PRO
QUIT
Begin DoDot:3
+15 ;GET THE PROVIDERJ
IF $DATA(^SDD(409.44,"AO",J,$GET(PRO)))
SET SEEN=1
QUIT
+16 NEW V
FOR V=0:0
SET V=$ORDER(^AUPNVPRV("AD",VISIT,V))
if 'V
QUIT
IF PRO=(+$GET(^AUPNVPRV(V,0)))
SET SEEN=1
QUIT
End DoDot:3
if SEEN
QUIT
End DoDot:2
if SEEN
QUIT
End DoDot:1
if SEEN
QUIT
+17 QUIT
GCL ;clean temp globals
+1 KILL ^TMP("SCMCTSK9",$JOB)
+2 KILL ^TMP("SCMCTSK9","OUT",$JOB)
+3 QUIT
