SCMCEV1 ;ALB/CMM - TEAM EVENT DRIVER UTILITIES ; 03/20/96
;;5.3;Scheduling;**41,130,140**;AUG 13, 1993
;
ENROLL(DFN,TIEN,ENDATE,DISDATE,CNAME) ;
;enroll DFN patient in team TIEN
;DFN - patient ien
;TIEN - team ien
;ENDATE - clinic enrollment date
;DISDATE - clinic discharge date
;CNAME - clinic name
;
N OKAY,ERR,PUR,SC,SCERR,TNAME,TEXT
S TNAME=$P($G(^SCTM(404.51,TIEN,0)),"^") ;team name
S OKAY=$$ACPTTM^SCAPMC6(DFN,TIEN,,ENDATE,"ERR")
I OKAY=0 Q
;okay = ien of 404.42
S PUR(1,0)="Automatic Team Enrollment/Update via Clinic: "_CNAME
I '$D(SCERR) D
.D WP^DIE(404.42,+OKAY_",","1","A","PUR","SCERR")
.S TEXT="Enrolled in Team: "_TNAME
.D:'$G(DGQUIET) EN^DDIOL(TEXT,"","!,?10")
K SCERR,ERR
I $D(DISDATE) D
.S PUR(1,0)="Automatic Team Discharge via Clinic: "_CNAME
.Q:'$$POSASS^SCMCEV2(DFN,TIEN)
.S OKAY=$$INPTTM^SCAPMC7(DFN,TIEN,DISDATE,"ERR")
.I OKAY'=0 D
..D WP^DIE(404.42,+OKAY_",","1","A","PUR","SCERR")
..S TEXT="Discharged from Team: "_TNAME
..D:'$G(DGQUIET) EN^DDIOL(TEXT,"","!,?10")
Q
;
UPDATE(DFN,TIEN,EDATE,DDATE,CNAME) ;
;update enrollment date/discharge date
;DFN - patient ien
;TIEN - team ien
;EDATE - enrollment date
;DDATE - discharge date
;CNAME - clinic name
;
N TPA,TDATE,TEXT,TNAME
S TNAME=$P($G(^SCTM(404.51,TIEN,0)),"^") ;team name
I '$D(^SCPT(404.42,"AIDT",DFN,TIEN)) D ENROLL(TIEN,DFN,EDATE,DDATE,CNAME) Q
; ^ new enrollment
S TDATE=$O(^SCPT(404.42,"AIDT",DFN,TIEN,"")) ; -team assignment date (most recent)
S TPA=$O(^SCPT(404.42,"AIDT",DFN,TIEN,TDATE,"")) ; team assignment ien
Q:'$D(^SCPT(404.42,+TPA,0))
K SC($J,404.42),SCERR
I EDATE'=0 D
.S SC($J,404.42,TPA_",",.13)=DUZ
.S SC($J,404.42,TPA_",",.14)=DT
.S SC($J,404.42,TPA_",",.02)=$P(EDATE,".") ;date only
.D FILE^DIE("","SC($J)","SCERR")
.S PUR(1,0)="Automatic Team Update via Clinic: "_CNAME
.D WP^DIE(404.42,TPA_",","1","A","PUR","SCERR")
.S TEXT="Update Team Enrollment "_TNAME
.D:'$G(DGQUIET) EN^DDIOL(TEXT,"","!,?10")
I +DDATE'=0 D
.Q:'$$POSASS^SCMCEV2(DFN,TIEN)
.; ^ assigned to a position
.S OKAY=$$INPTTM^SCAPMC7(DFN,TPA,DDATE,"ERR") ; discharge from team
.I OKAY'=0 D
..D WP^DIE(404.42,+OKAY_",","1","A","PUR","SCERR")
..S TEXT="Discharged from Team: "_TNAME
..D:'$G(DGQUIET) EN^DDIOL(TEXT,"","!,?10")
Q
;
DELT(DFN,CLN) ;deleted clinic entry/enrollment date w/'@'
;DFN - patient ien
;CLN - clinic ien
;
N CHECK,TM,EDATE,OKAY,CNAME,ERR,TEXT,TNAME
S CNAME=$P($G(^SC(+CLN,0)),"^") ;clinic name
S CHECK=$$CHK^SCMCEV2(DFN,CLN,2)
; ^ auto discharge okay
Q:'+CHECK
;check if assigned to a position on team
S TM=+$P(CHECK,"^",2) ;team ien
S OKAY=$$POSASS^SCMCEV2(DFN,TM)
Q:'OKAY
;delete entry
S ERR=$$DELTE(DFN,TM)
I ERR D
.;deleted entry
.S TNAME=$P($G(^SCTM(404.51,TM,0)),"^") ;team name
.S TEXT="Deleted team "_TNAME_" assignment due to deleting clinic assignment"
.D:'$G(DGQUIET) EN^DDIOL(TEXT,"","!,?10")
Q
;
DELTE(DFN,TIEN) ;delete team assignment entry
;DFN - patient ien
;TIEN - team ien
N PTA,ADATE,RET
S RET=1
S ADATE=$O(^SCPT(404.42,"AIDT",DFN,TIEN,-($$FMADD^XLFDT(DT,1))))
I ADATE="" S RET=0 G EXD
S PTA=$O(^SCPT(404.42,"AIDT",DFN,TIEN,ADATE,""))
I PTA="" S RET=0 G EXD
S DA=PTA,DIK="^SCPT(404.42,"
D ^DIK
K DA,DIK
EXD Q RET
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCEV1 3317 printed Nov 22, 2024@17:50:12 Page 2
SCMCEV1 ;ALB/CMM - TEAM EVENT DRIVER UTILITIES ; 03/20/96
+1 ;;5.3;Scheduling;**41,130,140**;AUG 13, 1993
+2 ;
ENROLL(DFN,TIEN,ENDATE,DISDATE,CNAME) ;
+1 ;enroll DFN patient in team TIEN
+2 ;DFN - patient ien
+3 ;TIEN - team ien
+4 ;ENDATE - clinic enrollment date
+5 ;DISDATE - clinic discharge date
+6 ;CNAME - clinic name
+7 ;
+8 NEW OKAY,ERR,PUR,SC,SCERR,TNAME,TEXT
+9 ;team name
SET TNAME=$PIECE($GET(^SCTM(404.51,TIEN,0)),"^")
+10 SET OKAY=$$ACPTTM^SCAPMC6(DFN,TIEN,,ENDATE,"ERR")
+11 IF OKAY=0
QUIT
+12 ;okay = ien of 404.42
+13 SET PUR(1,0)="Automatic Team Enrollment/Update via Clinic: "_CNAME
+14 IF '$DATA(SCERR)
Begin DoDot:1
+15 DO WP^DIE(404.42,+OKAY_",","1","A","PUR","SCERR")
+16 SET TEXT="Enrolled in Team: "_TNAME
+17 if '$GET(DGQUIET)
DO EN^DDIOL(TEXT,"","!,?10")
End DoDot:1
+18 KILL SCERR,ERR
+19 IF $DATA(DISDATE)
Begin DoDot:1
+20 SET PUR(1,0)="Automatic Team Discharge via Clinic: "_CNAME
+21 if '$$POSASS^SCMCEV2(DFN,TIEN)
QUIT
+22 SET OKAY=$$INPTTM^SCAPMC7(DFN,TIEN,DISDATE,"ERR")
+23 IF OKAY'=0
Begin DoDot:2
+24 DO WP^DIE(404.42,+OKAY_",","1","A","PUR","SCERR")
+25 SET TEXT="Discharged from Team: "_TNAME
+26 if '$GET(DGQUIET)
DO EN^DDIOL(TEXT,"","!,?10")
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;
UPDATE(DFN,TIEN,EDATE,DDATE,CNAME) ;
+1 ;update enrollment date/discharge date
+2 ;DFN - patient ien
+3 ;TIEN - team ien
+4 ;EDATE - enrollment date
+5 ;DDATE - discharge date
+6 ;CNAME - clinic name
+7 ;
+8 NEW TPA,TDATE,TEXT,TNAME
+9 ;team name
SET TNAME=$PIECE($GET(^SCTM(404.51,TIEN,0)),"^")
+10 IF '$DATA(^SCPT(404.42,"AIDT",DFN,TIEN))
DO ENROLL(TIEN,DFN,EDATE,DDATE,CNAME)
QUIT
+11 ; ^ new enrollment
+12 ; -team assignment date (most recent)
SET TDATE=$ORDER(^SCPT(404.42,"AIDT",DFN,TIEN,""))
+13 ; team assignment ien
SET TPA=$ORDER(^SCPT(404.42,"AIDT",DFN,TIEN,TDATE,""))
+14 if '$DATA(^SCPT(404.42,+TPA,0))
QUIT
+15 KILL SC($JOB,404.42),SCERR
+16 IF EDATE'=0
Begin DoDot:1
+17 SET SC($JOB,404.42,TPA_",",.13)=DUZ
+18 SET SC($JOB,404.42,TPA_",",.14)=DT
+19 ;date only
SET SC($JOB,404.42,TPA_",",.02)=$PIECE(EDATE,".")
+20 DO FILE^DIE("","SC($J)","SCERR")
+21 SET PUR(1,0)="Automatic Team Update via Clinic: "_CNAME
+22 DO WP^DIE(404.42,TPA_",","1","A","PUR","SCERR")
+23 SET TEXT="Update Team Enrollment "_TNAME
+24 if '$GET(DGQUIET)
DO EN^DDIOL(TEXT,"","!,?10")
End DoDot:1
+25 IF +DDATE'=0
Begin DoDot:1
+26 if '$$POSASS^SCMCEV2(DFN,TIEN)
QUIT
+27 ; ^ assigned to a position
+28 ; discharge from team
SET OKAY=$$INPTTM^SCAPMC7(DFN,TPA,DDATE,"ERR")
+29 IF OKAY'=0
Begin DoDot:2
+30 DO WP^DIE(404.42,+OKAY_",","1","A","PUR","SCERR")
+31 SET TEXT="Discharged from Team: "_TNAME
+32 if '$GET(DGQUIET)
DO EN^DDIOL(TEXT,"","!,?10")
End DoDot:2
End DoDot:1
+33 QUIT
+34 ;
DELT(DFN,CLN) ;deleted clinic entry/enrollment date w/'@'
+1 ;DFN - patient ien
+2 ;CLN - clinic ien
+3 ;
+4 NEW CHECK,TM,EDATE,OKAY,CNAME,ERR,TEXT,TNAME
+5 ;clinic name
SET CNAME=$PIECE($GET(^SC(+CLN,0)),"^")
+6 SET CHECK=$$CHK^SCMCEV2(DFN,CLN,2)
+7 ; ^ auto discharge okay
+8 if '+CHECK
QUIT
+9 ;check if assigned to a position on team
+10 ;team ien
SET TM=+$PIECE(CHECK,"^",2)
+11 SET OKAY=$$POSASS^SCMCEV2(DFN,TM)
+12 if 'OKAY
QUIT
+13 ;delete entry
+14 SET ERR=$$DELTE(DFN,TM)
+15 IF ERR
Begin DoDot:1
+16 ;deleted entry
+17 ;team name
SET TNAME=$PIECE($GET(^SCTM(404.51,TM,0)),"^")
+18 SET TEXT="Deleted team "_TNAME_" assignment due to deleting clinic assignment"
+19 if '$GET(DGQUIET)
DO EN^DDIOL(TEXT,"","!,?10")
End DoDot:1
+20 QUIT
+21 ;
DELTE(DFN,TIEN) ;delete team assignment entry
+1 ;DFN - patient ien
+2 ;TIEN - team ien
+3 NEW PTA,ADATE,RET
+4 SET RET=1
+5 SET ADATE=$ORDER(^SCPT(404.42,"AIDT",DFN,TIEN,-($$FMADD^XLFDT(DT,1))))
+6 IF ADATE=""
SET RET=0
GOTO EXD
+7 SET PTA=$ORDER(^SCPT(404.42,"AIDT",DFN,TIEN,ADATE,""))
+8 IF PTA=""
SET RET=0
GOTO EXD
+9 SET DA=PTA
SET DIK="^SCPT(404.42,"
+10 DO ^DIK
+11 KILL DA,DIK
EXD QUIT RET
