| 1 | 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
|
|---|
| 2 | ;;5.3;Scheduling;**297,499**;AUG 13, 1993;Build 21
|
|---|
| 3 | Q
|
|---|
| 4 | SORTP ;sort template
|
|---|
| 5 | N DIC
|
|---|
| 6 | S DIC=200,DIC(0)="ZME"
|
|---|
| 7 | S DIC("S")="I $D(^SCTM(404.52,""C"",+Y))"
|
|---|
| 8 | S DIR("A")="Start with Provider",DIR("B")="FIRST",DIR(0)="F" D ^DIR
|
|---|
| 9 | I X="FIRST" S DIPA("SP")="",DIPA("EI")="zzz",X=1 Q
|
|---|
| 10 | D ^DIC I Y<0 S DIPA("SP")=X Q:X[U D
|
|---|
| 11 | .S DIR("A")="Go to Provider",DIR("B")="LAST" S DIR(0)="F" D ^DIR
|
|---|
| 12 | .I X="LAST" S DIPA("EP")="zzz"
|
|---|
| 13 | I Y>0 S DIPA("SP")=$P(Y(0),U),DIC(0)="AZQME",DIC("A")="Go to Provider: "
|
|---|
| 14 | D ^DIC
|
|---|
| 15 | I Y>0 S DIPA("EP")=$P(Y(0),U)
|
|---|
| 16 | I Y<0 S DIPA("EP")=X Q:X[U
|
|---|
| 17 | S X=1 Q
|
|---|
| 18 | Q
|
|---|
| 19 | KEY ;Inactivated Report Key
|
|---|
| 20 | D KEY^SCMCTSK3 Q
|
|---|
| 21 | SORTYP() ; sort type
|
|---|
| 22 | W !,"Sort report by"
|
|---|
| 23 | S DIR(0)="SO^1:TEAM;2:ASSOCIATED CLINIC;"
|
|---|
| 24 | S DIR("B")=1
|
|---|
| 25 | D ^DIR
|
|---|
| 26 | Q Y
|
|---|
| 27 | DV(PP) ;return institution sort of patient assignment entry and then IEN of team^ien of position
|
|---|
| 28 | N A,B,C,T,I,INSTNM,INSTN
|
|---|
| 29 | 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)
|
|---|
| 30 | 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
|
|---|
| 31 | S INSTNM=$$GET1^DIQ(4,(+I)_",",.01),INSTN=$$GET1^DIQ(4,(+I)_",",99)
|
|---|
| 32 | S INST(T)=$S($L(INSTN)=3:INSTN_" ",1:"")_INSTNM Q INST(T)_U_T_U_$P(A,U,2)
|
|---|
| 33 | EC(PP) ;return enrolled clinics
|
|---|
| 34 | N I,A
|
|---|
| 35 | S A=""
|
|---|
| 36 | F I=0:0 S I=$O(^SCTM(404.57,+$P(ZERO,U,2),5,I)) Q:'I D
|
|---|
| 37 | .I '$$PTCL^SCRPO2(DFN,U_I,0,DT) Q ;not enrolled
|
|---|
| 38 | .I $D(CLIN(I)) S A=A_CLIN(I)_U Q
|
|---|
| 39 | .I $O(^TMP("SC",$J,"CLINIC",0)) I '$D(^(I)) Q
|
|---|
| 40 | .S CLIN(I)=$P($G(^SC(I,0)),U) I $L(CLIN(I)) S A=A_CLIN(I)_U
|
|---|
| 41 | Q $S(A="":-1,1:A)
|
|---|
| 42 | TM(PP) ;Return Team
|
|---|
| 43 | N I,A,T
|
|---|
| 44 | S T=+$P($G(^SCPT(404.42,+ZERO,0)),U,3)
|
|---|
| 45 | I $D(TEAM(T)) Q TEAM(T)
|
|---|
| 46 | I $O(^TMP("SC",$J,"TEAM",0)) I '$D(^(T)) Q -1
|
|---|
| 47 | S TEAM(T)=$P($G(^SCTM(404.51,+T,0)),U)
|
|---|
| 48 | I '$L(TEAM(T)) K TEAM(T) Q -1
|
|---|
| 49 | Q TEAM(T)
|
|---|
| 50 | IU(DFN) ;is patient inactivity unassigned
|
|---|
| 51 | N I,A,B,DATA,QUIT
|
|---|
| 52 | S DATA=-1,QUIT=0
|
|---|
| 53 | 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
|
|---|
| 54 | .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
|
|---|
| 55 | ..I $P(B,U,5),'$P(B,U,4) K A S QUIT=1 Q
|
|---|
| 56 | ..I $P(B,U,12)="NA" S POS=+J D
|
|---|
| 57 | ...S A("IU",I)=A
|
|---|
| 58 | ...S A("IUA")=A
|
|---|
| 59 | ...S A("IUB")=B
|
|---|
| 60 | ...I $P(A,U,8),'$P(A,U,9) S A("A")=1
|
|---|
| 61 | ;Q:$D(A("A")) DATA
|
|---|
| 62 | Q:'$D(A("IU")) DATA
|
|---|
| 63 | ;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
|
|---|
| 64 | 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
|
|---|
| 65 | Q DATA
|
|---|
| 66 | PROMPT(SCDESC,DATESORT) ;Prompt for report parameters, queue report
|
|---|
| 67 | ;Input: LIST=comma delimited string of list subscripts to prompt for
|
|---|
| 68 | ;Input: SCRTN=report routine entry point
|
|---|
| 69 | ;Input: SCDESC=tasked job description
|
|---|
| 70 | ;
|
|---|
| 71 | K TEAM,CLIN,INST,^TMP("SCSORT",$J)
|
|---|
| 72 | N SCDIV,SCBDT,SCEDT,SC,SCI,SCX,SCOUT,SCT
|
|---|
| 73 | D HOME^%ZIS
|
|---|
| 74 | D ENS^%ZISS
|
|---|
| 75 | S SC="^TMP(""SC"",$J)" K @SC S SCOUT=0
|
|---|
| 76 | D TITL^SCRPW50(SCDESC)
|
|---|
| 77 | I $L($G(DATESORT)) D G:'$$DTR^SCRPO(.SC,.SCBDT,.SCEDT) END
|
|---|
| 78 | .D SUBT^SCRPW50(DATESORT)
|
|---|
| 79 | .S SCBDT("B")="T-30",SCEDT("B")="TODAY"
|
|---|
| 80 | .I (DATESORT["Scheduled Ina")!(DATESORT["Scheduled for Inactivation") S SCEDT("B")="T+60"
|
|---|
| 81 | S LIST="DIV,TEAM,POS,ASPR"
|
|---|
| 82 | ;D SUBT^SCRPW50("**** Date Range Selection ****")
|
|---|
| 83 | ;S (SCBDT("B"),SCEDT("B"))="TODAY"
|
|---|
| 84 | ;G:'$$DTR^SCRPO(.SC,.SCBDT,.SCEDT) END
|
|---|
| 85 | ;D SUBT^SCRPW50("**** Report Parameter Selection ****")
|
|---|
| 86 | F SCI=1:1:$L(LIST,",") S SCX=$P(LIST,",",SCI) D Q:SCOUT
|
|---|
| 87 | .S SCOUT='$$LIST^SCRPO(.SC,SCX,1)
|
|---|
| 88 | .Q
|
|---|
| 89 | G:SCOUT END
|
|---|
| 90 | S SORT="DV,TM,TP,PR"_$S(SCDESC["FTEE":",AC",1:",PT")
|
|---|
| 91 | D SUBT^SCRPW50("**** Output sort order (optional) ****")
|
|---|
| 92 | G:'$$SORT^SCRPO(.SC,SORT,"") END
|
|---|
| 93 | S SCT(1)="**** Report Parameters Selected ****" D SUBT^SCRPW50(SCT(1))
|
|---|
| 94 | G:'$$PPAR^SCRPO(.SC,1,.SCT) END
|
|---|
| 95 | S SORTN=""
|
|---|
| 96 | F SCI=0:0 S SCI=$O(^TMP("SC",$J,"SORT",SCI)) Q:'SCI S SORTN=SORTN_$P(^(SCI),U,2)_U
|
|---|
| 97 | W:$G(IORESET)'[$C(99) $G(IORESET)
|
|---|
| 98 | Q
|
|---|
| 99 | END W:$G(IORESET)'[$C(99) $G(IORESET) K ^TMP("SC",$J) Q
|
|---|
| 100 | EXTEND ;Sort Extend
|
|---|
| 101 | K ^TMP("SCSORT",$J)
|
|---|
| 102 | I '$D(^TMP("SC",$J,"SORT",1)) S ^(1)="DV^INSTITUTION^SCDIV",SORTN="DIVISION"
|
|---|
| 103 | 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))=""
|
|---|
| 104 | N I,A,ED,SD
|
|---|
| 105 | 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
|
|---|
| 106 | .I '$P($G(^SCPT(404.43,J,0)),U,15) Q
|
|---|
| 107 | .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
|
|---|
| 108 | .D SORT(0)
|
|---|
| 109 | Q
|
|---|
| 110 | FILEIN(DATA,INFO) ;undo a inactivation
|
|---|
| 111 | ;INFO entry in PATIENT POSITION ASSIGNMENT file
|
|---|
| 112 | N ZERO,FLDA S DATA=1
|
|---|
| 113 | S ZERO=$G(^SCPT(404.43,+$G(INFO),0))
|
|---|
| 114 | ;I $P(ZERO,U,12)'="IU" Q
|
|---|
| 115 | S FLDA(404.43,(+INFO)_",",.12)=""
|
|---|
| 116 | S FLDA(404.43,(+INFO)_",",.04)=""
|
|---|
| 117 | S FLDA(404.43,(+INFO)_",",.15)=""
|
|---|
| 118 | S FLDA(404.43,(+INFO)_",",.17)=DT
|
|---|
| 119 | I $D(^SCPT(404.42,+ZERO,0)) S FLDA(404.42,(+ZERO)_",",.15)="",FLDA(404.42,(+ZERO)_",",.09)=""
|
|---|
| 120 | D FILE^DIE("E","FLDA","ERR")
|
|---|
| 121 | Q
|
|---|
| 122 | UNASSIGN ;Sort UNASSIGNMENTS
|
|---|
| 123 | N END,START
|
|---|
| 124 | K ^TMP("SCSORT",$J)
|
|---|
| 125 | S START=$G(^TMP("SC",$J,"DTR","BEGIN"))-.1,END=$G(^("END"))+.9
|
|---|
| 126 | I '$D(^TMP("SC",$J,"SORT",1)) S ^(1)="DV^INSTITUTION^SCDIV",SORTN="INSTITUTION"
|
|---|
| 127 | N I,A,STAT
|
|---|
| 128 | F STAT="NA","DU" F J=0:0 S J=$O(^SCPT(404.43,"ASTATB",STAT,J)) Q:'J D
|
|---|
| 129 | .S ZERO=$G(^SCPT(404.43,J,0)) I ($P(ZERO,U,4)<START)!($P(ZERO,U,4)>END) Q
|
|---|
| 130 | .D SORT(1)
|
|---|
| 131 | Q
|
|---|
| 132 | DFN(A) ;Return patient from Position assigment
|
|---|
| 133 | Q +$G(^SCPT(404.42,+$G(A),0))
|
|---|
| 134 | PA(A) ;return patient name
|
|---|
| 135 | Q $P($G(^DPT(+$G(DFN),0)),U)
|
|---|
| 136 | PR(PP) ;Return assigned provider
|
|---|
| 137 | N A
|
|---|
| 138 | S A=$$GETPRTP^SCAPMCU2(+$P(ZERO,U,2),DT)
|
|---|
| 139 | I $O(^TMP("SC",$J,"ASPR",0)) I '$D(^(+A)) Q -1
|
|---|
| 140 | S A=$P(A,U,2)
|
|---|
| 141 | Q $S(A="":-1,1:A)
|
|---|
| 142 | TP(A) ;return the team position
|
|---|
| 143 | N TP S TP=+$P($G(ZERO),U,2)
|
|---|
| 144 | I $O(^TMP("SC",$J,"POS",0)) I '$D(^(TP)) Q -1
|
|---|
| 145 | Q $P($G(^SCTM(404.57,+TP,0)),U)
|
|---|
| 146 | FLAGG ;Sort FLAGGED
|
|---|
| 147 | K ^TMP("SCSORT",$J)
|
|---|
| 148 | N I,A,J
|
|---|
| 149 | 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"
|
|---|
| 150 | 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))=""
|
|---|
| 151 | S SDT=$G(^TMP("SC",$J,"DTR","BEGIN")),END=$G(^("END"))+.9
|
|---|
| 152 | 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
|
|---|
| 153 | .I SDT>0 S:(END'>9) END=9999999 D INACTDT^SCMCTSK1(J) I (X<SDT)!(X>END) Q
|
|---|
| 154 | .D SORT(0)
|
|---|
| 155 | Q
|
|---|
| 156 | SORT(INACTIVE) ;
|
|---|
| 157 | N A,B,C,D,E,QUIT,SCA,K,KCNT,PIECE
|
|---|
| 158 | S ZERO=$G(^SCPT(404.43,+J,0)) Q:$S('$G(INACTIVE):$P(ZERO,U,4),1:'$P(ZERO,U,4))
|
|---|
| 159 | S DFN=$$DFN(+ZERO)
|
|---|
| 160 | S QUIT=0,KCNT=0
|
|---|
| 161 | 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
|
|---|
| 162 | .I $P(A,U)="EC",$L(A(K),U)>2 S KCNT=K
|
|---|
| 163 | Q:QUIT
|
|---|
| 164 | S A="" F S A=$O(SORT(A)) Q:A="" S @("B=$$"_A_"("_J_")") I B=-1 S QUIT=1 Q
|
|---|
| 165 | Q:QUIT
|
|---|
| 166 | F PIECE=1:1:$S(KCNT:$L(A(KCNT),U)-1,1:1) D
|
|---|
| 167 | .S B="E" K @B
|
|---|
| 168 | .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
|
|---|
| 169 | .S @B@(J)=""
|
|---|
| 170 | .M ^TMP("SCSORT",$J)=E
|
|---|
| 171 | Q
|
|---|
| 172 | INACT ;
|
|---|
| 173 | N ALPHA,ZERO
|
|---|
| 174 | S ALPHA=$G(^SCTM(404.44,1,1)),ALPHA=$P(ALPHA,U,8) I ALPHA<DT S ALPHA=0
|
|---|
| 175 | S ZERO=$G(^SCPT(404.43,+$G(PA),0)) I '$P(ZERO,U,15) S X="" Q
|
|---|
| 176 | S X1=$P(ZERO,U,15),X2=$S(ALPHA:2,1:30) I $P(ZERO,U,13) S X2=$S(ALPHA:5,1:90)
|
|---|
| 177 | D C^%DTC Q:ALPHA Q:$E(X,6,7)=15
|
|---|
| 178 | 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
|
|---|
| 179 | Q
|
|---|
| 180 | INCON ;Inconsistency
|
|---|
| 181 | N X
|
|---|
| 182 | 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
|
|---|
| 183 | Q
|
|---|
| 184 | POSIN(POS) ;
|
|---|
| 185 | S X=""
|
|---|
| 186 | N ZERO S ZERO=$G(^SCTM(404.57,POS,0))
|
|---|
| 187 | I '$P(ZERO,U,4) Q ;not primary care ignore this
|
|---|
| 188 | I '$$ACTTP^SCMCTPU(POS) Q ;inactive position
|
|---|
| 189 | I '$$OKPREC3^SCMCLK(POS,DT) I '$P($G(^SD(403.46,+$P(ZERO,U,3),0)),U,3) S X="Role not=PCprovider" Q
|
|---|
| 190 | ;find provider assigned to position and their person class
|
|---|
| 191 | S PROV=+$$GETPRTP^SCAPMCU2(POS,DT) Q:'PROV
|
|---|
| 192 | S PC=$$GET^XUA4A72(+PROV)
|
|---|
| 193 | I '$O(^SD(403.46,+$P(ZERO,U,3),2,0)) Q
|
|---|
| 194 | I '$D(^SD(403.46,+$P(ZERO,U,3),2,+PC)) S X="PersonClass not valid"
|
|---|
| 195 | Q
|
|---|
| 196 | PRFLAG ;
|
|---|
| 197 | N LASTDT,POSH
|
|---|
| 198 | K ^TMP("SCMCTSK",$J) N FLDA
|
|---|
| 199 | F POS=0:0 S POS=$O(^SCTM(404.57,POS)) Q:'POS S ZERO=$G(^(POS,0)) D
|
|---|
| 200 | .I '$P(ZERO,U,4) Q ;not primary care ignore this
|
|---|
| 201 | .I '$$ACTTP^SCMCTPU(POS) Q ;inactive position
|
|---|
| 202 | .S LASTDT=+$O(^SCTM(404.52,"AIDT",POS,1,-DT)),POSH=+$O(^SCTM(404.52,"AIDT",POS,1,LASTDT,0)) Q:'POSH
|
|---|
| 203 | .I $O(^SCTM(404.52,"AIDT",POS,0,-9999999))<LASTDT Q ;inactivation already scheduled
|
|---|
| 204 | .I $P($G(^SCTM(404.52,POSH,0)),U,10) S FLDA(404.52,POSH_",",.091)="" ;already flagged
|
|---|
| 205 | .I '$P($G(^SCTM(404.52,POSH,0)),U,4) Q ;inactive
|
|---|
| 206 | .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
|
|---|
| 207 | .;find provider assigned to position and their person class
|
|---|
| 208 | .S PROV=+$$GETPRTP^SCAPMCU2(POS,DT)
|
|---|
| 209 | .S PC=$$GET^XUA4A72(+PROV)
|
|---|
| 210 | .I '$D(^SD(403.46,+$P(ZERO,U,3),2,+PC)) S ^TMP("SCMCTSK",$J,POSH)="Person Class is not valid for this role"
|
|---|
| 211 | F POS=0:0 S POS=$O(^TMP("SCMCTSK",$J,POS)) Q:'POS S FLDA(404.52,POS_",",.091)=DT
|
|---|
| 212 | VERPR ;verify already flagged positions; SD/499 replaced "AFLG" with "AFLAG"
|
|---|
| 213 | 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
|
|---|
| 214 | .N ZERO,ZEROTP S ZERO=$G(^SCTM(404.52,POSH,0))
|
|---|
| 215 | .I '$P(ZERO,U,4) S FLDA(404.52,POSH_",",.091)="" Q
|
|---|
| 216 | .;SD/499; added verification of the POSSIBLE PRIMARY PRACTITIONER field
|
|---|
| 217 | .;in the TEAM POSITION file
|
|---|
| 218 | .N TP S TP=$P(ZERO,U) S ZEROTP=$G(^SCTM(404.57,TP,0))
|
|---|
| 219 | .I '$P(ZEROTP,U,4) S FLDA(404.52,POSH_",",.091)="" Q
|
|---|
| 220 | .I (-$O(^SCTM(404.52,"AIDT",+ZERO,0,-9999999)))>$P(ZERO,U,2) S FLDA(404.52,POSH_",",.091)=""
|
|---|
| 221 | I $O(FLDA(0)) D FILE^DIE("I","FLDA","ERR")
|
|---|
| 222 | K ^TMP("SCMCTSK",$J)
|
|---|
| 223 | Q
|
|---|
