- 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 Feb 19, 2025@00:08:01 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