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