Changeset 623 for WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTSK3.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTSK3.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTSK3.m
r613 r623 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 1 SCMCTSK3 ;ALB/JDS - PCMM Inactivation Reports ; 7/19/05 10:06am 2 ;;5.3;Scheduling;**297**;AUG 13, 1993 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+30" 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 F I=0:0 S I=$O(^SCTM(404.52,"AFLG",I)) Q:'I F POSH=0:0 S POSH=$O(^SCTM(404.52,"AFLG",I,POSH)) Q:'POSH D 213 .N ZERO S ZERO=$G(^SCTM(404.52,POSH,0)) 214 .I '$P(ZERO,U,4) S FLDA(404.52,POSH_",",.091)="" Q 215 .I (-$O(^SCTM(404.52,"AIDT",+ZERO,0,-9999999)))>$P(ZERO,U,2) S FLDA(404.52,POSH_",",.091)="" 216 I $O(FLDA(0)) D FILE^DIE("I","FLDA","ERR") 217 K ^TMP("SCMCTSK",$J) 218 Q
Note:
See TracChangeset
for help on using the changeset viewer.
