- 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 Feb 19, 2025@00:07:58 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