Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SCMCTSK

SCMCTSK.m

Go to the documentation of this file.
  1. SCMCTSK ;ALB/JDS/ART - PCMM ;02/26/2015
  1. ;;5.3;Scheduling;**264,278,272,297,581,603**;AUG 13, 1993;Build 79
  1. ;
  1. Q
  1. RPT1 ;REPORT
  1. N DHD,DIOBEG,DIC,FLDS,BY
  1. S DIOBEG="D INACTIVE^SCMCTSK",DIC="^SCPT(404.43,",(FLDS,BY)="[SCMC PENDING UNASSIGN]"
  1. S DHD="Patients Flagged for Inactivation from PACT" ;603
  1. D EN1^DIP
  1. Q
  1. INACTIVE ;run every night to determine if patient can be inactivated from
  1. ;team
  1. ;Inactivation happens for patients without activity for 20 months
  1. N I,TEAMNM,SDDT,TYDT
  1. D DT^DICRW S X="T-8M" D ^%DT S STDT=Y ;603
  1. S X="T-20M" D ^%DT S TYDT=+Y ;603
  1. RPT ;enter for report with STDT and TYDT defined
  1. S A="^SCPT(404.43,""ADFN""",L=""""""
  1. S Q=A_")"
  1. F S Q=$Q(@Q) Q:Q'[A D
  1. .S ENTRY=+$P(Q,",",6)
  1. .S TEAM=$P(Q,",",4)
  1. .;I $P($G(^SCTM(404.51,+TEAM,0)),U,16) Q ;no automatic for this team
  1. .;I $G(^DPT(DFN,.35)) D DIS Q ;Patient is deceased
  1. .I $P(Q,",",5)>STDT Q ;Later
  1. .S ZERO=$G(^SCPT(404.43,+ENTRY,0))
  1. .I $P(ZERO,U,4) Q ;Already unassigned
  1. .I '$P(ZERO,U,5) Q ;not Primary Care
  1. .;I $P(ZERO,U,16) Q ;No Automatic unassign
  1. .;Check if any activity
  1. .S DFN=$P(Q,",",3),DFN=+$G(^SCPT(404.42,+DFN,0))
  1. .S SEEN=0
  1. .S TEAM=$P(Q,",",4),TEAMNM=$P($G(^SCTM(404.51,+TEAM,0)),U)
  1. .;who was provider for this position
  1. .Q:$$SEEN1(DFN,+$P(ZERO,U,2))
  1. .;I $G(DIS) D DIS Q
  1. .S ^TMP("SCMCTSK",$J,ENTRY)=""
  1. Q
  1. SEEN1(DFN,POS) ;
  1. S SEEN=0
  1. K PROV F I=0:0 S I=$O(^SCTM(404.52,"B",+$G(POS),I)) Q:'I D
  1. .N A S A=$G(^SCTM(404.52,+I,0)) I $P(A,U,4) S PROV(+$P(A,U,3))="" Q
  1. .I $P(A,U,2)<TYDT K PROV(+$P(A,U,3))
  1. F PROV=0:0 S PROV=$O(PROV(PROV)) Q:'PROV D SEEN
  1. Q SEEN
  1. SEEN ;See if seen in last 24 months go through visits
  1. F I=0:0 S I=$O(^AUPNVSIT("AA",DFN,I)) Q:'I Q:(9999999-I<TYDT) D Q:SEEN
  1. .F J=0:0 S J=$O(^AUPNVSIT("AA",DFN,I,J)) Q:'J D
  1. ..F P=0:0 S P=$O(^AUPNVPRV("AD",J,P)) Q:'P S:PROV=(+$G(^AUPNVPRV(P,0))) SEEN=1 Q:SEEN ;GET THE PROVIDERJ
  1. Q
  1. DIS ;discharge
  1. N ZERO S ZERO=$G(^SCPT(404.43,+ENTRY,0))
  1. I $P(ZERO,U,4) Q ;Already discharged
  1. ;I $P(ZERO,U,16) Q
  1. S DA=ENTRY,DIE="^SCPT(404.43,",DR=".04////"_DT_";.12////IU"
  1. D ^DIE
  1. ;
  1. Q
  1. DEATH ;Called from date of death event
  1. ;DG FIELD MONITOR protocol, which calls SCMC PCMM INACTIVATE ON DATE OF DEATH
  1. ;
  1. I $G(DGFILE)'=2 Q
  1. I $G(DGFIELD)'=.351 Q
  1. S DFN=+$G(DGDA)
  1. N DEATH,I,DR,DIE,SCI,SCJ,SCTP,SCERR
  1. D DEM^VADPT S DEATH=$G(VADM(6))
  1. ;update CPMM patient Events (404.54) - 603
  1. D UPDEVNT(DFN,DEATH)
  1. Q:'DEATH
  1. ;DISPOSITION WAIT LIST
  1. F I=0:0 S I=$O(^SDWL(409.3,"B",+$G(DFN),I)) Q:'I S A=$G(^SDWL(409.3,I,0)) D
  1. .I $G(^SDWL(409.3,I,"DIS")) Q
  1. .N FDA
  1. .S FDA(409.3,I_",",21)="D"
  1. .S FDA(409.3,I_",",19)=DT
  1. .S FDA(409.3,I_",",23)="C"
  1. .S FDA(409.3,I_",",20)=DUZ
  1. .D UPDATE^DIE("","FDA")
  1. Q
  1. ;
  1. UPDEVNT(SCDFN,SCDTDTH) ;create/update patient event record (404.54)
  1. ; new for patch 603
  1. ; Inputs: SCDFN - patient DFN
  1. ; SCDTDTH - patient date of death
  1. ; Output: new or updated record in 404.54
  1. ;
  1. ; ICR - 10103 - XLFDT - Supported APIs for date & time
  1. ; ICR - 2053 - Data Base Server API: Editing Utilities (DIE) - supported, public
  1. ;
  1. NEW SCEXIST,SCIEN,SCIENS,SCFDA,SCERR
  1. SET SCEXIST=$DATA(^SCPT(404.54,+SCDFN))
  1. IF SCEXIST DO
  1. . SET SCIENS=SCDFN_","
  1. . SET SCFDA(404.54,SCIENS,.02)=$$NOW^XLFDT()
  1. . SET SCFDA(404.54,SCIENS,.03)=$SELECT(+SCDTDTH>0:"AD",1:"AR")
  1. . SET SCFDA(404.54,SCIENS,.04)=$SELECT(+SCDTDTH>0:$TR(SCDTDTH,"^","|"),1:"")
  1. . DO FILE^DIE("K","SCFDA","SCERR")
  1. ELSE DO
  1. . SET SCIENS="+1,"
  1. . SET SCIEN(1)=SCDFN
  1. . SET SCFDA(404.54,SCIENS,.01)=SCDFN
  1. . SET SCFDA(404.54,SCIENS,.02)=$$NOW^XLFDT()
  1. . SET SCFDA(404.54,SCIENS,.03)=$SELECT(+SCDTDTH>0:"AD",1:"AR")
  1. . SET SCFDA(404.54,SCIENS,.04)=$SELECT(+SCDTDTH>0:$TR(SCDTDTH,"^","|"),1:"")
  1. . DO UPDATE^DIE("","SCFDA","SCIEN","SCERR")
  1. QUIT
  1. ;
  1. POST ;
  1. D MES^XPDUTL("Deleting Traditional ASTAT CROSS REFERENCE from FILE 404.43")
  1. D DELIX^DDMOD(404.43,.12,1)
  1. N ENTRY,DGDA,DGFIELD,DGFILE,DATE
  1. K DGLEFDA,YEAR
  1. I '$D(^SCTM(404.46,"B","1.2.3.0")) D
  1. .K DO S DIC(0)="LM",DIC("DR")=".02////1;.03////"_DT,DIC="^SCTM(404.46,",X="1.2.3.0" D FILE^DICN
  1. I '$D(^SCTM(404.45,"B","SD*5.3*264")) D
  1. .S ENTRY=$O(^SCTM(404.46,"B","1.2.3.0",0))
  1. .S DIC("DR")=".02////"_(+ENTRY)_";.03////"_DT_";.04////1",DIC(0)="LM"
  1. .K DO S X="SD*5.3*264",DIC="^SCTM(404.45," D FILE^DICN
  1. D MES^XPDUTL("Removing Patients with Date of Death from Team/Position Assignments")
  1. S YEAR=0
  1. F DATE=0:0 S DATE=$O(^DPT("AEXP1",DATE)) Q:'DATE F DGDA=0:0 S DGDA=$O(^DPT("AEXP1",DATE,DGDA)) Q:'DGDA D
  1. .S DFN=+DGDA D DEM^VADPT I $G(VADM(6)) S DGFILE=2,DGFIELD=.351 D DEATH
  1. .I $E(YEAR,1,3)'=$E(DATE,1,3) S YEAR=$E(DATE,1,3) I "05"[$E(YEAR,3) D MES^XPDUTL("Starting with Dates of Death in "_(1700+YEAR))
  1. Q
  1. POST278 ;postinit for 278
  1. D MES^XPDUTL("Setting up GUI to VistA mapping")
  1. I '$D(^SCTM(404.46,"B","1.2.3.1")) D
  1. .K DO S DIC(0)="LM",DIC("DR")=".02////1;.03////"_DT,DIC="^SCTM(404.46,",X="1.2.3.1" D FILE^DICN
  1. I '$D(^SCTM(404.45,"B","SD*5.3*278")) D
  1. .S ENTRY=$O(^SCTM(404.46,"B","1.2.3.1",0))
  1. .S DIC("DR")=".02////"_(+ENTRY)_";.03////"_DT_";.04////1",DIC(0)="LM"
  1. .K DO S X="SD*5.3*278",DIC="^SCTM(404.45," D FILE^DICN
  1. Q
  1. FTEE(DATA,SCTEAM) ;return list of positions for the team
  1. ;IEN^POSITION^PROVIDER^FTEE
  1. N CNT,I,J,K,A S CNT=1 S SCTEAM=+$G(SCTEAM),DATA(1)="<DATA>"
  1. S A=""
  1. F S A=$O(^SCTM(404.57,"ATMPOS",SCTEAM,A)) Q:A="" D
  1. .F I=0:0 S I=$O(^SCTM(404.57,"ATMPOS",SCTEAM,A,I)) Q:'I D
  1. ..I '$$DATES^SCAPMCU1(404.59,I) Q ;Not an active position
  1. ..;I '$P($G(^SCTM(404.57,I,0)),U,4) Q ;Not PC; include sd/581
  1. ..S J=-(DT+1) S J=$O(^SCTM(404.52,"AIDT",I,1,J)) Q:J=""
  1. ..I $O(^SCTM(404.52,"AIDT",I,0,-(DT+1)))<J Q
  1. ..S K=0 S K=$O(^SCTM(404.52,"AIDT",I,1,J,K)) Q:'K
  1. ..S ZERO=$G(^SCTM(404.52,+K,0)) Q:'$P(ZERO,U,4)
  1. ..S CNT=CNT+1
  1. ..S DATA(CNT)=K_U_A_U_$$GET1^DIQ(200,(+$P(ZERO,U,3))_",",.01)_U_$P(ZERO,U,9)_U_K_U_$P(ZERO,U,3)
  1. Q
  1. FILE(RES,DATA) ;File data on FTEE
  1. N I
  1. F I=1:1 Q:'$D(DATA(I)) D
  1. .S ZERO=$G(^SCTM(404.52,+DATA(I),0))
  1. .I $P(ZERO,U,9)=$P(DATA(I),U,7) Q
  1. .S FLDA(404.52,(+DATA(I))_",",.09)=+$TR($P(DATA(I),U,7)," ")
  1. I $O(FLDA(0)) D FILE^DIE("E","FLDA","ERR")
  1. Q
  1. FTEXR ;Ftee cross reference - this code is obsolete as of SD*5.3*603
  1. ;N DIC,DD,DO,DINUM,DS,ENTRY,VALUE
  1. ;I '$D(^SCTM(404.52,+DA,1,0)) S ^(0)="^404.521DA"
  1. ;S ENTRY=+$G(DA),VALUE=X
  1. ;N DIC,FLDA,Y,DA,X S DIC="^SCTM(404.52,"_ENTRY_",1,",DA(1)=ENTRY
  1. ;S DIC(0)="LM",X="NOW",DIC("DR")=".02////"_VALUE_";.03////"_$G(DUZ)
  1. ;D ^DICN
  1. Q
  1. SCREEN ;Screen for active assignments
  1. N A S A=$G(^SCTM(404.52,D0,0))
  1. N J S J=-(DT+1),J=$O(^SCTM(404.52,"AIDT",+A,1,J)) I J="" S X=0 Q
  1. I '$P($G(^SCTM(404.57,+A,0)),U,4) Q ;Not PC
  1. I '$$DATES^SCAPMCU1(404.59,+A) Q ;Not an active position
  1. I $O(^SCTM(404.52,"AIDT",+A,0,-(DT+1)))<J S X=0 Q
  1. I '$D(^SCTM(404.52,"AIDT",+A,1,J,D0)) S X=0 Q
  1. S X=1 Q