SCMCTSK3 ;ALB/JDS - PCMM Inactivation Reports ; 7/19/05 10:06am ; Compiled June 7, 2007 13:57:55 ; Compiled February 12, 2008 11:46:47
;;5.3;Scheduling;**297,499,532**;AUG 13, 1993;Build 21
Q
SORTP ;sort template
N DIC
S DIC=200,DIC(0)="ZME"
S DIC("S")="I $D(^SCTM(404.52,""C"",+Y))"
S DIR("A")="Start with Provider",DIR("B")="FIRST",DIR(0)="F" D ^DIR
I X="FIRST" S DIPA("SP")="",DIPA("EI")="zzz",X=1 Q
D ^DIC I Y<0 S DIPA("SP")=X Q:X[U D
.S DIR("A")="Go to Provider",DIR("B")="LAST" S DIR(0)="F" D ^DIR
.I X="LAST" S DIPA("EP")="zzz"
I Y>0 S DIPA("SP")=$P(Y(0),U),DIC(0)="AZQME",DIC("A")="Go to Provider: "
D ^DIC
I Y>0 S DIPA("EP")=$P(Y(0),U)
I Y<0 S DIPA("EP")=X Q:X[U
S X=1 Q
Q
KEY ;Inactivated Report Key
D KEY^SCMCTSK3 Q
SORTYP() ; sort type
W !,"Sort report by"
S DIR(0)="SO^1:TEAM;2:ASSOCIATED CLINIC;"
S DIR("B")=1
D ^DIR
Q Y
DV(PP) ;return institution sort of patient assignment entry and then IEN of team^ien of position
N A,B,C,T,I,INSTNM,INSTN
S A=$G(^SCPT(404.43,+PP,0)),T=+$P($G(^SCPT(404.42,+A,0)),U,3) I $D(INST(T)) Q INST(T)_U_T_U_$P(A,U,2)
S I=$P($G(^SCTM(404.51,T,0)),U,7) I $O(^TMP("SC",$J,"DIV",0)) I '$D(^TMP("SC",$J,"DIV",I)) Q -1
S INSTNM=$$GET1^DIQ(4,(+I)_",",.01),INSTN=$$GET1^DIQ(4,(+I)_",",99)
S INST(T)=$S($L(INSTN)=3:INSTN_" ",1:"")_INSTNM Q INST(T)_U_T_U_$P(A,U,2)
EC(PP) ;return enrolled clinics
N I,A
S A=""
F I=0:0 S I=$O(^SCTM(404.57,+$P(ZERO,U,2),5,I)) Q:'I D
.I '$$PTCL^SCRPO2(DFN,U_I,0,DT) Q ;not enrolled
.I $D(CLIN(I)) S A=A_CLIN(I)_U Q
.I $O(^TMP("SC",$J,"CLINIC",0)) I '$D(^(I)) Q
.S CLIN(I)=$P($G(^SC(I,0)),U) I $L(CLIN(I)) S A=A_CLIN(I)_U
Q $S(A="":-1,1:A)
TM(PP) ;Return Team
N I,A,T
S T=+$P($G(^SCPT(404.42,+ZERO,0)),U,3)
I $D(TEAM(T)) Q TEAM(T)
I $O(^TMP("SC",$J,"TEAM",0)) I '$D(^(T)) Q -1
S TEAM(T)=$P($G(^SCTM(404.51,+T,0)),U)
I '$L(TEAM(T)) K TEAM(T) Q -1
Q TEAM(T)
IU(DFN) ;is patient inactivity unassigned
N I,A,B,DATA,QUIT
S DATA=-1,QUIT=0
F I=0:0 S I=$O(^SCPT(404.42,"B",+$G(DFN),I)) Q:'I S A=$G(^SCPT(404.42,I,0)) D Q:QUIT
.F J=0:0 S J=$O(^SCPT(404.43,"B",I,J)) Q:'J S B=$G(^SCPT(404.43,+J,0)) D Q:QUIT
..I $P(B,U,5),'$P(B,U,4) K A S QUIT=1 Q
..I $P(B,U,12)="NA" S POS=+J D
...S A("IU",I)=A
...S A("IUA")=A
...S A("IUB")=B
...I $P(A,U,8),'$P(A,U,9) S A("A")=1
;Q:$D(A("A")) DATA
Q:'$D(A("IU")) DATA
;S DATA="1~"_$P(^SCTM(404.51,+$P(A,U,3),0),U)_"~"_(+$P(A,U,3))_"~"_$P($G(^SCTM(404.57,+$P(B,U,2),0)),U)_"~"_($P(B,U,2))_"~"_POS
S DATA="1~"_$P(^SCTM(404.51,+$P(A("IUA"),U,3),0),U)_"~"_(+$P(A("IUA"),U,3))_"~"_$P($G(^SCTM(404.57,+$P(A("IUB"),U,2),0)),U)_"~"_($P(A("IUB"),U,2))_"~"_POS
Q DATA
PROMPT(SCDESC,DATESORT) ;Prompt for report parameters, queue report
;Input: LIST=comma delimited string of list subscripts to prompt for
;Input: SCRTN=report routine entry point
;Input: SCDESC=tasked job description
;
K TEAM,CLIN,INST,^TMP("SCSORT",$J)
N SCDIV,SCBDT,SCEDT,SC,SCI,SCX,SCOUT,SCT
D HOME^%ZIS
D ENS^%ZISS
S SC="^TMP(""SC"",$J)" K @SC S SCOUT=0
D TITL^SCRPW50(SCDESC)
I $L($G(DATESORT)) D G:'$$DTR^SCRPO(.SC,.SCBDT,.SCEDT) END
.D SUBT^SCRPW50(DATESORT)
.S SCBDT("B")="T-30",SCEDT("B")="TODAY"
.I (DATESORT["Scheduled Ina")!(DATESORT["Scheduled for Inactivation") S SCEDT("B")="T+60"
S LIST="DIV,TEAM,POS,ASPR"
;D SUBT^SCRPW50("**** Date Range Selection ****")
;S (SCBDT("B"),SCEDT("B"))="TODAY"
;G:'$$DTR^SCRPO(.SC,.SCBDT,.SCEDT) END
;D SUBT^SCRPW50("**** Report Parameter Selection ****")
F SCI=1:1:$L(LIST,",") S SCX=$P(LIST,",",SCI) D Q:SCOUT
.S SCOUT='$$LIST^SCRPO(.SC,SCX,1)
.Q
G:SCOUT END
S SORT="DV,TM,TP,PR"_$S(SCDESC["FTEE":",AC",1:",PT")
D SUBT^SCRPW50("**** Output sort order (optional) ****")
G:'$$SORT^SCRPO(.SC,SORT,"") END
S SCT(1)="**** Report Parameters Selected ****" D SUBT^SCRPW50(SCT(1))
G:'$$PPAR^SCRPO(.SC,1,.SCT) END
S SORTN=""
F SCI=0:0 S SCI=$O(^TMP("SC",$J,"SORT",SCI)) Q:'SCI S SORTN=SORTN_$P(^(SCI),U,2)_U
W:$G(IORESET)'[$C(99) $G(IORESET)
Q
END W:$G(IORESET)'[$C(99) $G(IORESET) K ^TMP("SC",$J) Q
EXTEND ;Sort Extend
K ^TMP("SCSORT",$J)
I '$D(^TMP("SC",$J,"SORT",1)) S ^(1)="DV^INSTITUTION^SCDIV",SORTN="DIVISION"
N SORT S A="" F S A=$O(^TMP("SC",$J,A)) Q:A="" I "XRSORTDTR"'[A I $G(^(A))'="ALL" S SORT($S(A="ASPR":"PR",A="DIV":"DV",A="POS":"TP",1:"TM",A="PATIENT":PT))=""
N I,A,ED,SD
F I=0:0 S I=$O(^SCPT(404.43,"AEXT",I)) Q:'I F J=0:0 S J=$O(^SCPT(404.43,"AEXT",I,J)) Q:'J D
.I '$P($G(^SCPT(404.43,J,0)),U,15) Q
.S SD=$G(^TMP("SC",$J,"DTR","BEGIN")) I SD S ED=$G(^("END")) S:'ED ED=9999999 D INACTDT^SCMCTSK1(J) I (X<SD)!(X>ED) Q
.D SORT(0)
Q
FILEIN(DATA,INFO) ;undo a inactivation
;INFO entry in PATIENT POSITION ASSIGNMENT file
N ZERO,FLDA S DATA=1
S ZERO=$G(^SCPT(404.43,+$G(INFO),0))
;I $P(ZERO,U,12)'="IU" Q
S FLDA(404.43,(+INFO)_",",.12)=""
S FLDA(404.43,(+INFO)_",",.04)=""
S FLDA(404.43,(+INFO)_",",.15)=""
S FLDA(404.43,(+INFO)_",",.17)=DT
I $D(^SCPT(404.42,+ZERO,0)) S FLDA(404.42,(+ZERO)_",",.15)="",FLDA(404.42,(+ZERO)_",",.09)=""
D FILE^DIE("E","FLDA","ERR")
Q
UNASSIGN ;Sort UNASSIGNMENTS
N END,START
K ^TMP("SCSORT",$J)
S START=$G(^TMP("SC",$J,"DTR","BEGIN"))-.1,END=$G(^("END"))+.9
I '$D(^TMP("SC",$J,"SORT",1)) S ^(1)="DV^INSTITUTION^SCDIV",SORTN="INSTITUTION"
N I,A,STAT
F STAT="NA","DU" F J=0:0 S J=$O(^SCPT(404.43,"ASTATB",STAT,J)) Q:'J D
.S ZERO=$G(^SCPT(404.43,J,0)) I ($P(ZERO,U,4)<START)!($P(ZERO,U,4)>END) Q
.D SORT(1)
Q
DFN(A) ;Return patient from Position assigment
Q +$G(^SCPT(404.42,+$G(A),0))
PA(A) ;return patient name
Q $P($G(^DPT(+$G(DFN),0)),U)
PR(PP) ;Return assigned provider
N A
S A=$$GETPRTP^SCAPMCU2(+$P(ZERO,U,2),DT)
I $O(^TMP("SC",$J,"ASPR",0)) I '$D(^(+A)) Q -1
S A=$P(A,U,2)
Q $S(A="":-1,1:A)
TP(A) ;return the team position
N TP S TP=+$P($G(ZERO),U,2)
I $O(^TMP("SC",$J,"POS",0)) I '$D(^(TP)) Q -1
Q $P($G(^SCTM(404.57,+TP,0)),U)
FLAGG ;Sort FLAGGED
K ^TMP("SCSORT",$J)
N I,A,J
I '$D(^TMP("SC",$J,"SORT",1)) S ^(1)="DV^INSTITUTION^SCDIV",SORTN="INSTITUTION",^(2)="TM^TEAM^SCTEAM",^(3)="PR^PROVIDER^SCPROV",^(4)="PA^PATIENT^SCPAT"
N SORT S A="" F S A=$O(^TMP("SC",$J,A)) Q:A="" I "XRSORTDTR"'[A I $G(^(A))'="ALL" S SORT($S(A="ASPR":"PR",A="DIV":"DV",A="POS":"TP",1:"TM",A="PATIENT":PT))=""
S SDT=$G(^TMP("SC",$J,"DTR","BEGIN")),END=$G(^("END"))+.9
F I=0:0 S I=$O(^SCPT(404.43,"AFLG",I)) Q:'I F J=0:0 S J=$O(^SCPT(404.43,"AFLG",I,J)) Q:'J D
.I SDT>0 S:(END'>9) END=9999999 D INACTDT^SCMCTSK1(J) I (X<SDT)!(X>END) Q
.D SORT(0)
Q
SORT(INACTIVE) ;
N A,B,C,D,E,QUIT,SCA,K,KCNT,PIECE
S ZERO=$G(^SCPT(404.43,+J,0)) Q:$S('$G(INACTIVE):$P(ZERO,U,4),1:'$P(ZERO,U,4))
S DFN=$$DFN(+ZERO)
S QUIT=0,KCNT=0
F K=1:1 Q:'$D(^TMP("SC",$J,"SORT",K)) S A=^(K) K SORT($P(A,U)) S @("A("_K_")=$$"_$P(A,U)_"("_J_")") D I (A(K)=-1)!($P(A(K),U)="") S QUIT=1 Q
.I $P(A,U)="EC",$L(A(K),U)>2 S KCNT=K
Q:QUIT
S A="" F S A=$O(SORT(A)) Q:A="" S @("B=$$"_A_"("_J_")") I B=-1 S QUIT=1 Q
Q:QUIT
F PIECE=1:1:$S(KCNT:$L(A(KCNT),U)-1,1:1) D
.S B="E" K @B
.F K=1:1:$O(A(99),-1) S @B@($P(A(K),U,$S(K=KCNT:PIECE,1:1)))="" S C=$Q(@B) K @B S B=C
.S @B@(J)=""
.M ^TMP("SCSORT",$J)=E
Q
INACT ;
N ALPHA,ZERO
S ALPHA=$G(^SCTM(404.44,1,1)),ALPHA=$P(ALPHA,U,8) I ALPHA<DT S ALPHA=0
S ZERO=$G(^SCPT(404.43,+$G(PA),0)) I '$P(ZERO,U,15) S X="" Q
S X1=$P(ZERO,U,15),X2=$S(ALPHA:2,1:30) I $P(ZERO,U,13) S X2=$S(ALPHA:5,1:90)
D C^%DTC Q:ALPHA Q:$E(X,6,7)=15
F S (ZERO,X1)=X,X2=1 D C^%DTC Q:$E(X,6,7)=15 I $E(X,6,7)="01" S X=ZERO Q
Q
INCON ;Inconsistency
N X
F POS=0:0 S POS=$O(^SCTM(404.57,POS)) Q:'POS D POSIN(POS) I $L(X) S ^TMP("SCMCTSK",$J,POS)=X
Q
POSIN(POS) ;
S X=""
N ZERO S ZERO=$G(^SCTM(404.57,POS,0))
I '$P(ZERO,U,4) Q ;not primary care ignore this
I '$$ACTTP^SCMCTPU(POS) Q ;inactive position
I '$$OKPREC3^SCMCLK(POS,DT) I '$P($G(^SD(403.46,+$P(ZERO,U,3),0)),U,3) S X="Role not=PCprovider" Q
;find provider assigned to position and their person class
S PROV=+$$GETPRTP^SCAPMCU2(POS,DT) Q:'PROV
S PC=$$GET^XUA4A72(+PROV)
I '$O(^SD(403.46,+$P(ZERO,U,3),2,0)) Q
I '$D(^SD(403.46,+$P(ZERO,U,3),2,+PC)) S X="PersonClass not valid"
Q
PRFLAG ;
N LASTDT,POSH
K ^TMP("SCMCTSK",$J) N FLDA
F POS=0:0 S POS=$O(^SCTM(404.57,POS)) Q:'POS S ZERO=$G(^(POS,0)) D
.I '$P(ZERO,U,4) Q ;not primary care ignore this
.I '$$ACTTP^SCMCTPU(POS) Q ;inactive position
.S LASTDT=+$O(^SCTM(404.52,"AIDT",POS,1,-DT)),POSH=+$O(^SCTM(404.52,"AIDT",POS,1,LASTDT,0)) Q:'POSH
.I $O(^SCTM(404.52,"AIDT",POS,0,-9999999))<LASTDT Q ;inactivation already scheduled
.I $P($G(^SCTM(404.52,POSH,0)),U,10) Q ;inactivation already scheduled S FLDA(404.52,POSH_",",.091)="" ;already flagged
.I '$P($G(^SCTM(404.52,POSH,0)),U,4) Q ;inactive
.I '$$OKPREC3^SCMCLK(POS,DT) I '$P($G(^SD(403.46,+$P(ZERO,U,3),0)),U,3) S ^TMP("SCMCTSK",$J,POSH)="Role cannot be primary care" Q
.;find provider assigned to position and their person class
.S PROV=+$$GETPRTP^SCAPMCU2(POS,DT)
.S PC=$$GET^XUA4A72(+PROV)
.I '$D(^SD(403.46,+$P(ZERO,U,3),2,+PC)) S ^TMP("SCMCTSK",$J,POSH)="Person Class is not valid for this role"
F POS=0:0 S POS=$O(^TMP("SCMCTSK",$J,POS)) Q:'POS S FLDA(404.52,POS_",",.091)=DT
VERPR ;verify already flagged positions; SD/499 replaced "AFLG" with "AFLAG"
N II,POSH S II="" F S II=$O(^SCTM(404.52,"AFLAG",II)) Q:'II S POSH="" F S POSH=$O(^SCTM(404.52,"AFLAG",II,POSH)) Q:'POSH D
.N ZERO,ZEROTP S ZERO=$G(^SCTM(404.52,POSH,0))
.I '$P(ZERO,U,4) S FLDA(404.52,POSH_",",.091)="" Q
.;SD/499; added verification of the POSSIBLE PRIMARY PRACTITIONER field
.;in the TEAM POSITION file
.N TP S TP=$P(ZERO,U) S ZEROTP=$G(^SCTM(404.57,TP,0))
.I '$P(ZEROTP,U,4) S FLDA(404.52,POSH_",",.091)="" Q
.I (-$O(^SCTM(404.52,"AIDT",+ZERO,0,-9999999)))>$P(ZERO,U,2) S FLDA(404.52,POSH_",",.091)=""
I $O(FLDA(0)) D FILE^DIE("I","FLDA","ERR")
K ^TMP("SCMCTSK",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCTSK3 9975 printed Sep 23, 2025@20:17:55 Page 2
SCMCTSK3 ;ALB/JDS - PCMM Inactivation Reports ; 7/19/05 10:06am ; Compiled June 7, 2007 13:57:55 ; Compiled February 12, 2008 11:46:47
+1 ;;5.3;Scheduling;**297,499,532**;AUG 13, 1993;Build 21
+2 QUIT
SORTP ;sort template
+1 NEW DIC
+2 SET DIC=200
SET DIC(0)="ZME"
+3 SET DIC("S")="I $D(^SCTM(404.52,""C"",+Y))"
+4 SET DIR("A")="Start with Provider"
SET DIR("B")="FIRST"
SET DIR(0)="F"
DO ^DIR
+5 IF X="FIRST"
SET DIPA("SP")=""
SET DIPA("EI")="zzz"
SET X=1
QUIT
+6 DO ^DIC
IF Y<0
SET DIPA("SP")=X
if X[U
QUIT
Begin DoDot:1
+7 SET DIR("A")="Go to Provider"
SET DIR("B")="LAST"
SET DIR(0)="F"
DO ^DIR
+8 IF X="LAST"
SET DIPA("EP")="zzz"
End DoDot:1
+9 IF Y>0
SET DIPA("SP")=$PIECE(Y(0),U)
SET DIC(0)="AZQME"
SET DIC("A")="Go to Provider: "
+10 DO ^DIC
+11 IF Y>0
SET DIPA("EP")=$PIECE(Y(0),U)
+12 IF Y<0
SET DIPA("EP")=X
if X[U
QUIT
+13 SET X=1
QUIT
+14 QUIT
KEY ;Inactivated Report Key
+1 DO KEY^SCMCTSK3
QUIT
SORTYP() ; sort type
+1 WRITE !,"Sort report by"
+2 SET DIR(0)="SO^1:TEAM;2:ASSOCIATED CLINIC;"
+3 SET DIR("B")=1
+4 DO ^DIR
+5 QUIT Y
DV(PP) ;return institution sort of patient assignment entry and then IEN of team^ien of position
+1 NEW A,B,C,T,I,INSTNM,INSTN
+2 SET A=$GET(^SCPT(404.43,+PP,0))
SET T=+$PIECE($GET(^SCPT(404.42,+A,0)),U,3)
IF $DATA(INST(T))
QUIT INST(T)_U_T_U_$PIECE(A,U,2)
+3 SET I=$PIECE($GET(^SCTM(404.51,T,0)),U,7)
IF $ORDER(^TMP("SC",$JOB,"DIV",0))
IF '$DATA(^TMP("SC",$JOB,"DIV",I))
QUIT -1
+4 SET INSTNM=$$GET1^DIQ(4,(+I)_",",.01)
SET INSTN=$$GET1^DIQ(4,(+I)_",",99)
+5 SET INST(T)=$SELECT($LENGTH(INSTN)=3:INSTN_" ",1:"")_INSTNM
QUIT INST(T)_U_T_U_$PIECE(A,U,2)
EC(PP) ;return enrolled clinics
+1 NEW I,A
+2 SET A=""
+3 FOR I=0:0
SET I=$ORDER(^SCTM(404.57,+$PIECE(ZERO,U,2),5,I))
if 'I
QUIT
Begin DoDot:1
+4 ;not enrolled
IF '$$PTCL^SCRPO2(DFN,U_I,0,DT)
QUIT
+5 IF $DATA(CLIN(I))
SET A=A_CLIN(I)_U
QUIT
+6 IF $ORDER(^TMP("SC",$JOB,"CLINIC",0))
IF '$DATA(^(I))
QUIT
+7 SET CLIN(I)=$PIECE($GET(^SC(I,0)),U)
IF $LENGTH(CLIN(I))
SET A=A_CLIN(I)_U
End DoDot:1
+8 QUIT $SELECT(A="":-1,1:A)
TM(PP) ;Return Team
+1 NEW I,A,T
+2 SET T=+$PIECE($GET(^SCPT(404.42,+ZERO,0)),U,3)
+3 IF $DATA(TEAM(T))
QUIT TEAM(T)
+4 IF $ORDER(^TMP("SC",$JOB,"TEAM",0))
IF '$DATA(^(T))
QUIT -1
+5 SET TEAM(T)=$PIECE($GET(^SCTM(404.51,+T,0)),U)
+6 IF '$LENGTH(TEAM(T))
KILL TEAM(T)
QUIT -1
+7 QUIT TEAM(T)
IU(DFN) ;is patient inactivity unassigned
+1 NEW I,A,B,DATA,QUIT
+2 SET DATA=-1
SET QUIT=0
+3 FOR I=0:0
SET I=$ORDER(^SCPT(404.42,"B",+$GET(DFN),I))
if 'I
QUIT
SET A=$GET(^SCPT(404.42,I,0))
Begin DoDot:1
+4 FOR J=0:0
SET J=$ORDER(^SCPT(404.43,"B",I,J))
if 'J
QUIT
SET B=$GET(^SCPT(404.43,+J,0))
Begin DoDot:2
+5 IF $PIECE(B,U,5)
IF '$PIECE(B,U,4)
KILL A
SET QUIT=1
QUIT
+6 IF $PIECE(B,U,12)="NA"
SET POS=+J
Begin DoDot:3
+7 SET A("IU",I)=A
+8 SET A("IUA")=A
+9 SET A("IUB")=B
+10 IF $PIECE(A,U,8)
IF '$PIECE(A,U,9)
SET A("A")=1
End DoDot:3
End DoDot:2
if QUIT
QUIT
End DoDot:1
if QUIT
QUIT
+11 ;Q:$D(A("A")) DATA
+12 if '$DATA(A("IU"))
QUIT DATA
+13 ;S DATA="1~"_$P(^SCTM(404.51,+$P(A,U,3),0),U)_"~"_(+$P(A,U,3))_"~"_$P($G(^SCTM(404.57,+$P(B,U,2),0)),U)_"~"_($P(B,U,2))_"~"_POS
+14 SET DATA="1~"_$PIECE(^SCTM(404.51,+$PIECE(A("IUA"),U,3),0),U)_"~"_(+$PIECE(A("IUA"),U,3))_"~"_$PIECE($GET(^SCTM(404.57,+$PIECE(A("IUB"),U,2),0)),U)_"~"_($PIECE(A("IUB"),U,2))_"~"_POS
+15 QUIT DATA
PROMPT(SCDESC,DATESORT) ;Prompt for report parameters, queue report
+1 ;Input: LIST=comma delimited string of list subscripts to prompt for
+2 ;Input: SCRTN=report routine entry point
+3 ;Input: SCDESC=tasked job description
+4 ;
+5 KILL TEAM,CLIN,INST,^TMP("SCSORT",$JOB)
+6 NEW SCDIV,SCBDT,SCEDT,SC,SCI,SCX,SCOUT,SCT
+7 DO HOME^%ZIS
+8 DO ENS^%ZISS
+9 SET SC="^TMP(""SC"",$J)"
KILL @SC
SET SCOUT=0
+10 DO TITL^SCRPW50(SCDESC)
+11 IF $LENGTH($GET(DATESORT))
Begin DoDot:1
+12 DO SUBT^SCRPW50(DATESORT)
+13 SET SCBDT("B")="T-30"
SET SCEDT("B")="TODAY"
+14 IF (DATESORT["Scheduled Ina")!(DATESORT["Scheduled for Inactivation")
SET SCEDT("B")="T+60"
End DoDot:1
if '$$DTR^SCRPO(.SC,.SCBDT,.SCEDT)
GOTO END
+15 SET LIST="DIV,TEAM,POS,ASPR"
+16 ;D SUBT^SCRPW50("**** Date Range Selection ****")
+17 ;S (SCBDT("B"),SCEDT("B"))="TODAY"
+18 ;G:'$$DTR^SCRPO(.SC,.SCBDT,.SCEDT) END
+19 ;D SUBT^SCRPW50("**** Report Parameter Selection ****")
+20 FOR SCI=1:1:$LENGTH(LIST,",")
SET SCX=$PIECE(LIST,",",SCI)
Begin DoDot:1
+21 SET SCOUT='$$LIST^SCRPO(.SC,SCX,1)
+22 QUIT
End DoDot:1
if SCOUT
QUIT
+23 if SCOUT
GOTO END
+24 SET SORT="DV,TM,TP,PR"_$SELECT(SCDESC["FTEE":",AC",1:",PT")
+25 DO SUBT^SCRPW50("**** Output sort order (optional) ****")
+26 if '$$SORT^SCRPO(.SC,SORT,"")
GOTO END
+27 SET SCT(1)="**** Report Parameters Selected ****"
DO SUBT^SCRPW50(SCT(1))
+28 if '$$PPAR^SCRPO(.SC,1,.SCT)
GOTO END
+29 SET SORTN=""
+30 FOR SCI=0:0
SET SCI=$ORDER(^TMP("SC",$JOB,"SORT",SCI))
if 'SCI
QUIT
SET SORTN=SORTN_$PIECE(^(SCI),U,2)_U
+31 if $GET(IORESET)'[$CHAR(99)
WRITE $GET(IORESET)
+32 QUIT
END if $GET(IORESET)'[$CHAR(99)
WRITE $GET(IORESET)
KILL ^TMP("SC",$JOB)
QUIT
EXTEND ;Sort Extend
+1 KILL ^TMP("SCSORT",$JOB)
+2 IF '$DATA(^TMP("SC",$JOB,"SORT",1))
SET ^(1)="DV^INSTITUTION^SCDIV"
SET SORTN="DIVISION"
+3 NEW SORT
SET A=""
FOR
SET A=$ORDER(^TMP("SC",$JOB,A))
if A=""
QUIT
IF "XRSORTDTR"'[A
IF $GET(^(A))'="ALL"
SET SORT($SELECT(A="ASPR":"PR",A="DIV":"DV",A="POS":"TP",1:"TM",A="PATIENT":PT))=""
+4 NEW I,A,ED,SD
+5 FOR I=0:0
SET I=$ORDER(^SCPT(404.43,"AEXT",I))
if 'I
QUIT
FOR J=0:0
SET J=$ORDER(^SCPT(404.43,"AEXT",I,J))
if 'J
QUIT
Begin DoDot:1
+6 IF '$PIECE($GET(^SCPT(404.43,J,0)),U,15)
QUIT
+7 SET SD=$GET(^TMP("SC",$JOB,"DTR","BEGIN"))
IF SD
SET ED=$GET(^("END"))
if 'ED
SET ED=9999999
DO INACTDT^SCMCTSK1(J)
IF (X<SD)!(X>ED)
QUIT
+8 DO SORT(0)
End DoDot:1
+9 QUIT
FILEIN(DATA,INFO) ;undo a inactivation
+1 ;INFO entry in PATIENT POSITION ASSIGNMENT file
+2 NEW ZERO,FLDA
SET DATA=1
+3 SET ZERO=$GET(^SCPT(404.43,+$GET(INFO),0))
+4 ;I $P(ZERO,U,12)'="IU" Q
+5 SET FLDA(404.43,(+INFO)_",",.12)=""
+6 SET FLDA(404.43,(+INFO)_",",.04)=""
+7 SET FLDA(404.43,(+INFO)_",",.15)=""
+8 SET FLDA(404.43,(+INFO)_",",.17)=DT
+9 IF $DATA(^SCPT(404.42,+ZERO,0))
SET FLDA(404.42,(+ZERO)_",",.15)=""
SET FLDA(404.42,(+ZERO)_",",.09)=""
+10 DO FILE^DIE("E","FLDA","ERR")
+11 QUIT
UNASSIGN ;Sort UNASSIGNMENTS
+1 NEW END,START
+2 KILL ^TMP("SCSORT",$JOB)
+3 SET START=$GET(^TMP("SC",$JOB,"DTR","BEGIN"))-.1
SET END=$GET(^("END"))+.9
+4 IF '$DATA(^TMP("SC",$JOB,"SORT",1))
SET ^(1)="DV^INSTITUTION^SCDIV"
SET SORTN="INSTITUTION"
+5 NEW I,A,STAT
+6 FOR STAT="NA","DU"
FOR J=0:0
SET J=$ORDER(^SCPT(404.43,"ASTATB",STAT,J))
if 'J
QUIT
Begin DoDot:1
+7 SET ZERO=$GET(^SCPT(404.43,J,0))
IF ($PIECE(ZERO,U,4)<START)!($PIECE(ZERO,U,4)>END)
QUIT
+8 DO SORT(1)
End DoDot:1
+9 QUIT
DFN(A) ;Return patient from Position assigment
+1 QUIT +$GET(^SCPT(404.42,+$GET(A),0))
PA(A) ;return patient name
+1 QUIT $PIECE($GET(^DPT(+$GET(DFN),0)),U)
PR(PP) ;Return assigned provider
+1 NEW A
+2 SET A=$$GETPRTP^SCAPMCU2(+$PIECE(ZERO,U,2),DT)
+3 IF $ORDER(^TMP("SC",$JOB,"ASPR",0))
IF '$DATA(^(+A))
QUIT -1
+4 SET A=$PIECE(A,U,2)
+5 QUIT $SELECT(A="":-1,1:A)
TP(A) ;return the team position
+1 NEW TP
SET TP=+$PIECE($GET(ZERO),U,2)
+2 IF $ORDER(^TMP("SC",$JOB,"POS",0))
IF '$DATA(^(TP))
QUIT -1
+3 QUIT $PIECE($GET(^SCTM(404.57,+TP,0)),U)
FLAGG ;Sort FLAGGED
+1 KILL ^TMP("SCSORT",$JOB)
+2 NEW I,A,J
+3 IF '$DATA(^TMP("SC",$JOB,"SORT",1))
SET ^(1)="DV^INSTITUTION^SCDIV"
SET SORTN="INSTITUTION"
SET ^(2)="TM^TEAM^SCTEAM"
SET ^(3)="PR^PROVIDER^SCPROV"
SET ^(4)="PA^PATIENT^SCPAT"
+4 NEW SORT
SET A=""
FOR
SET A=$ORDER(^TMP("SC",$JOB,A))
if A=""
QUIT
IF "XRSORTDTR"'[A
IF $GET(^(A))'="ALL"
SET SORT($SELECT(A="ASPR":"PR",A="DIV":"DV",A="POS":"TP",1:"TM",A="PATIENT":PT))=""
+5 SET SDT=$GET(^TMP("SC",$JOB,"DTR","BEGIN"))
SET END=$GET(^("END"))+.9
+6 FOR I=0:0
SET I=$ORDER(^SCPT(404.43,"AFLG",I))
if 'I
QUIT
FOR J=0:0
SET J=$ORDER(^SCPT(404.43,"AFLG",I,J))
if 'J
QUIT
Begin DoDot:1
+7 IF SDT>0
if (END'>9)
SET END=9999999
DO INACTDT^SCMCTSK1(J)
IF (X<SDT)!(X>END)
QUIT
+8 DO SORT(0)
End DoDot:1
+9 QUIT
SORT(INACTIVE) ;
+1 NEW A,B,C,D,E,QUIT,SCA,K,KCNT,PIECE
+2 SET ZERO=$GET(^SCPT(404.43,+J,0))
if $SELECT('$GET(INACTIVE)
QUIT
+3 SET DFN=$$DFN(+ZERO)
+4 SET QUIT=0
SET KCNT=0
+5 FOR K=1:1
if '$DATA(^TMP("SC",$JOB,"SORT",K))
QUIT
SET A=^(K)
KILL SORT($PIECE(A,U))
SET @("A("_K_")=$$"_$PIECE(A,U)_"("_J_")")
Begin DoDot:1
+6 IF $PIECE(A,U)="EC"
IF $LENGTH(A(K),U)>2
SET KCNT=K
End DoDot:1
IF (A(K)=-1)!($PIECE(A(K),U)="")
SET QUIT=1
QUIT
+7 if QUIT
QUIT
+8 SET A=""
FOR
SET A=$ORDER(SORT(A))
if A=""
QUIT
SET @("B=$$"_A_"("_J_")")
IF B=-1
SET QUIT=1
QUIT
+9 if QUIT
QUIT
+10 FOR PIECE=1:1:$SELECT(KCNT:$LENGTH(A(KCNT),U)-1,1:1)
Begin DoDot:1
+11 SET B="E"
KILL @B
+12 FOR K=1:1:$ORDER(A(99),-1)
SET @B@($PIECE(A(K),U,$SELECT(K=KCNT:PIECE,1:1)))=""
SET C=$QUERY(@B)
KILL @B
SET B=C
+13 SET @B@(J)=""
+14 MERGE ^TMP("SCSORT",$JOB)=E
End DoDot:1
+15 QUIT
INACT ;
+1 NEW ALPHA,ZERO
+2 SET ALPHA=$GET(^SCTM(404.44,1,1))
SET ALPHA=$PIECE(ALPHA,U,8)
IF ALPHA<DT
SET ALPHA=0
+3 SET ZERO=$GET(^SCPT(404.43,+$GET(PA),0))
IF '$PIECE(ZERO,U,15)
SET X=""
QUIT
+4 SET X1=$PIECE(ZERO,U,15)
SET X2=$SELECT(ALPHA:2,1:30)
IF $PIECE(ZERO,U,13)
SET X2=$SELECT(ALPHA:5,1:90)
+5 DO C^%DTC
if ALPHA
QUIT
if $EXTRACT(X,6,7)=15
QUIT
+6 FOR
SET (ZERO,X1)=X
SET X2=1
DO C^%DTC
if $EXTRACT(X,6,7)=15
QUIT
IF $EXTRACT(X,6,7)="01"
SET X=ZERO
QUIT
+7 QUIT
INCON ;Inconsistency
+1 NEW X
+2 FOR POS=0:0
SET POS=$ORDER(^SCTM(404.57,POS))
if 'POS
QUIT
DO POSIN(POS)
IF $LENGTH(X)
SET ^TMP("SCMCTSK",$JOB,POS)=X
+3 QUIT
POSIN(POS) ;
+1 SET X=""
+2 NEW ZERO
SET ZERO=$GET(^SCTM(404.57,POS,0))
+3 ;not primary care ignore this
IF '$PIECE(ZERO,U,4)
QUIT
+4 ;inactive position
IF '$$ACTTP^SCMCTPU(POS)
QUIT
+5 IF '$$OKPREC3^SCMCLK(POS,DT)
IF '$PIECE($GET(^SD(403.46,+$PIECE(ZERO,U,3),0)),U,3)
SET X="Role not=PCprovider"
QUIT
+6 ;find provider assigned to position and their person class
+7 SET PROV=+$$GETPRTP^SCAPMCU2(POS,DT)
if 'PROV
QUIT
+8 SET PC=$$GET^XUA4A72(+PROV)
+9 IF '$ORDER(^SD(403.46,+$PIECE(ZERO,U,3),2,0))
QUIT
+10 IF '$DATA(^SD(403.46,+$PIECE(ZERO,U,3),2,+PC))
SET X="PersonClass not valid"
+11 QUIT
PRFLAG ;
+1 NEW LASTDT,POSH
+2 KILL ^TMP("SCMCTSK",$JOB)
NEW FLDA
+3 FOR POS=0:0
SET POS=$ORDER(^SCTM(404.57,POS))
if 'POS
QUIT
SET ZERO=$GET(^(POS,0))
Begin DoDot:1
+4 ;not primary care ignore this
IF '$PIECE(ZERO,U,4)
QUIT
+5 ;inactive position
IF '$$ACTTP^SCMCTPU(POS)
QUIT
+6 SET LASTDT=+$ORDER(^SCTM(404.52,"AIDT",POS,1,-DT))
SET POSH=+$ORDER(^SCTM(404.52,"AIDT",POS,1,LASTDT,0))
if 'POSH
QUIT
+7 ;inactivation already scheduled
IF $ORDER(^SCTM(404.52,"AIDT",POS,0,-9999999))<LASTDT
QUIT
+8 ;inactivation already scheduled S FLDA(404.52,POSH_",",.091)="" ;already flagged
IF $PIECE($GET(^SCTM(404.52,POSH,0)),U,10)
QUIT
+9 ;inactive
IF '$PIECE($GET(^SCTM(404.52,POSH,0)),U,4)
QUIT
+10 IF '$$OKPREC3^SCMCLK(POS,DT)
IF '$PIECE($GET(^SD(403.46,+$PIECE(ZERO,U,3),0)),U,3)
SET ^TMP("SCMCTSK",$JOB,POSH)="Role cannot be primary care"
QUIT
+11 ;find provider assigned to position and their person class
+12 SET PROV=+$$GETPRTP^SCAPMCU2(POS,DT)
+13 SET PC=$$GET^XUA4A72(+PROV)
+14 IF '$DATA(^SD(403.46,+$PIECE(ZERO,U,3),2,+PC))
SET ^TMP("SCMCTSK",$JOB,POSH)="Person Class is not valid for this role"
End DoDot:1
+15 FOR POS=0:0
SET POS=$ORDER(^TMP("SCMCTSK",$JOB,POS))
if 'POS
QUIT
SET FLDA(404.52,POS_",",.091)=DT
VERPR ;verify already flagged positions; SD/499 replaced "AFLG" with "AFLAG"
+1 NEW II,POSH
SET II=""
FOR
SET II=$ORDER(^SCTM(404.52,"AFLAG",II))
if 'II
QUIT
SET POSH=""
FOR
SET POSH=$ORDER(^SCTM(404.52,"AFLAG",II,POSH))
if 'POSH
QUIT
Begin DoDot:1
+2 NEW ZERO,ZEROTP
SET ZERO=$GET(^SCTM(404.52,POSH,0))
+3 IF '$PIECE(ZERO,U,4)
SET FLDA(404.52,POSH_",",.091)=""
QUIT
+4 ;SD/499; added verification of the POSSIBLE PRIMARY PRACTITIONER field
+5 ;in the TEAM POSITION file
+6 NEW TP
SET TP=$PIECE(ZERO,U)
SET ZEROTP=$GET(^SCTM(404.57,TP,0))
+7 IF '$PIECE(ZEROTP,U,4)
SET FLDA(404.52,POSH_",",.091)=""
QUIT
+8 IF (-$ORDER(^SCTM(404.52,"AIDT",+ZERO,0,-9999999)))>$PIECE(ZERO,U,2)
SET FLDA(404.52,POSH_",",.091)=""
End DoDot:1
+9 IF $ORDER(FLDA(0))
DO FILE^DIE("I","FLDA","ERR")
+10 KILL ^TMP("SCMCTSK",$JOB)
+11 QUIT
