SDPPENR1 ;ALB/CAW - Patient Profile - Enrollments ; 5/13/92
;;5.3;Scheduling;**6,140**;Aug 13, 1993
;
;
EN1 ; Enrollments
N SD,SD1,SDCL,SDEN,SDFLN,SDOPT,SDSTAT,SDSTART,SDSTOP
S SD=0,SDFST=9,SDSEC=53,SDFLN=7,SDLEN=28,$P(SDASH,"-",IOM+1)="",SDSTART=$S($D(SDBEG):SDBEG,1:SDBD),SDSTOP=$S($D(SDEND):SDEND,1:SDED)
F S SD=$O(^DPT(DFN,"DE",SD)) Q:'SD S SD1=0,SDCL=$G(^(SD,0)) F S SD1=$O(^DPT(DFN,"DE",SD,1,SD1)) Q:'SD1 S SDEN=$G(^(SD1,0)) D CHECKS
S SD=-9999999.99 F S SD=$O(^TMP("SDENR",$J,SD)) Q:'SD S SD1=0 F S SD1=$O(^TMP("SDENR",$J,SD,SD1)) Q:'SD1 S SDCL=^(SD1,0),SDEN=^(1),SDDT=$E(SD,2,999) D INFO
K ^TMP("SDENR",$J) Q
;
CHECKS ; Checks
; Check for specified clinic
I $D(SDY),SDY'=+SDCL Q
; Add all active enrollments if printing regardless of date range
I SDPRINT,$P(SDEN,U,3)="" D CHKSET
; Check for active enrollments
I SDACT,$P(SDEN,U,3)'="" Q
; Check for date range
I +SDEN>SDSTOP!(+SDEN<SDSTART) Q
; Otherwise file info
CHKSET S ^TMP("SDENR",$J,-$P(SDEN,U),SD1,0)=SDCL,^(1)=SDEN
Q
INFO ;
;
CLINIC ; Enrollment Clinic and Enrollment Date
S X="",X=$$SETSTR^VALM1("Clinic:",X,1,SDFLN)
S X=$$SETSTR^VALM1($P($G(^SC(+SDCL,0)),U),X,SDFST,SDLEN)
S X=$$SETSTR^VALM1("Enroll. Date:",X,39,13)
S X=$$SETSTR^VALM1($TR($$FMTE^XLFDT(+SDEN,"5DF")," ","0"),X,SDSEC,SDLEN)
D SET(X)
STATUS ; Current Status and Enrollement Discharge Date
S X="",X=$$SETSTR^VALM1("Status:",X,1,SDFLN)
S SDSTAT=$S($P(SDEN,U,3)="":"ACTIVE",1:"INACTIVE")
S X=$$SETSTR^VALM1(SDSTAT,X,SDFST,SDLEN)
I $P(SDEN,U,3)'="" D
.S X=$$SETSTR^VALM1("Disch. Date:",X,40,12)
.S X=$$SETSTR^VALM1($$FDATE^VALM1($P(SDEN,U,3)),X,SDSEC,SDLEN)
D SET(X)
OPT ; OPT or AC and Review Date
S X="",X=$$SETSTR^VALM1("OPT/AC:",X,1,SDFLN)
S SDOPT=$S($P(SDEN,U,2)="O":"OPT",$P(SDEN,U,2)="A":"AC",1:"UNKNOWN")
S X=$$SETSTR^VALM1(SDOPT,X,SDFST,SDLEN)
I $P(SDEN,U,5)'="" D
.S X=$$SETSTR^VALM1("Review Date:",X,40,12)
.S X=$$SETSTR^VALM1($$FDATE^VALM1($P(SDEN,U,5)),X,SDSEC,SDLEN)
D SET(X)
REASON ; Reason for Discharge
I $P(SDEN,U,4)'="" D
.S X="",X=$$SETSTR^VALM1("Reason:",X,1,SDFLN)
.S X=$$SETSTR^VALM1($P(SDEN,U,4),X,SDFST,70)
.D SET(X)
D SET("")
Q
SET(X) ; Set in ^TMP global for display
;
S SDLN=SDLN+1,^TMP("SDPPALL",$J,SDLN,0)=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDPPENR1 2285 printed Dec 13, 2024@02:59:46 Page 2
SDPPENR1 ;ALB/CAW - Patient Profile - Enrollments ; 5/13/92
+1 ;;5.3;Scheduling;**6,140**;Aug 13, 1993
+2 ;
+3 ;
EN1 ; Enrollments
+1 NEW SD,SD1,SDCL,SDEN,SDFLN,SDOPT,SDSTAT,SDSTART,SDSTOP
+2 SET SD=0
SET SDFST=9
SET SDSEC=53
SET SDFLN=7
SET SDLEN=28
SET $PIECE(SDASH,"-",IOM+1)=""
SET SDSTART=$SELECT($DATA(SDBEG):SDBEG,1:SDBD)
SET SDSTOP=$SELECT($DATA(SDEND):SDEND,1:SDED)
+3 FOR
SET SD=$ORDER(^DPT(DFN,"DE",SD))
if 'SD
QUIT
SET SD1=0
SET SDCL=$GET(^(SD,0))
FOR
SET SD1=$ORDER(^DPT(DFN,"DE",SD,1,SD1))
if 'SD1
QUIT
SET SDEN=$GET(^(SD1,0))
DO CHECKS
+4 SET SD=-9999999.99
FOR
SET SD=$ORDER(^TMP("SDENR",$JOB,SD))
if 'SD
QUIT
SET SD1=0
FOR
SET SD1=$ORDER(^TMP("SDENR",$JOB,SD,SD1))
if 'SD1
QUIT
SET SDCL=^(SD1,0)
SET SDEN=^(1)
SET SDDT=$EXTRACT(SD,2,999)
DO INFO
+5 KILL ^TMP("SDENR",$JOB)
QUIT
+6 ;
CHECKS ; Checks
+1 ; Check for specified clinic
+2 IF $DATA(SDY)
IF SDY'=+SDCL
QUIT
+3 ; Add all active enrollments if printing regardless of date range
+4 IF SDPRINT
IF $PIECE(SDEN,U,3)=""
DO CHKSET
+5 ; Check for active enrollments
+6 IF SDACT
IF $PIECE(SDEN,U,3)'=""
QUIT
+7 ; Check for date range
+8 IF +SDEN>SDSTOP!(+SDEN<SDSTART)
QUIT
+9 ; Otherwise file info
CHKSET SET ^TMP("SDENR",$JOB,-$PIECE(SDEN,U),SD1,0)=SDCL
SET ^(1)=SDEN
+1 QUIT
INFO ;
+1 ;
CLINIC ; Enrollment Clinic and Enrollment Date
+1 SET X=""
SET X=$$SETSTR^VALM1("Clinic:",X,1,SDFLN)
+2 SET X=$$SETSTR^VALM1($PIECE($GET(^SC(+SDCL,0)),U),X,SDFST,SDLEN)
+3 SET X=$$SETSTR^VALM1("Enroll. Date:",X,39,13)
+4 SET X=$$SETSTR^VALM1($TRANSLATE($$FMTE^XLFDT(+SDEN,"5DF")," ","0"),X,SDSEC,SDLEN)
+5 DO SET(X)
STATUS ; Current Status and Enrollement Discharge Date
+1 SET X=""
SET X=$$SETSTR^VALM1("Status:",X,1,SDFLN)
+2 SET SDSTAT=$SELECT($PIECE(SDEN,U,3)="":"ACTIVE",1:"INACTIVE")
+3 SET X=$$SETSTR^VALM1(SDSTAT,X,SDFST,SDLEN)
+4 IF $PIECE(SDEN,U,3)'=""
Begin DoDot:1
+5 SET X=$$SETSTR^VALM1("Disch. Date:",X,40,12)
+6 SET X=$$SETSTR^VALM1($$FDATE^VALM1($PIECE(SDEN,U,3)),X,SDSEC,SDLEN)
End DoDot:1
+7 DO SET(X)
OPT ; OPT or AC and Review Date
+1 SET X=""
SET X=$$SETSTR^VALM1("OPT/AC:",X,1,SDFLN)
+2 SET SDOPT=$SELECT($PIECE(SDEN,U,2)="O":"OPT",$PIECE(SDEN,U,2)="A":"AC",1:"UNKNOWN")
+3 SET X=$$SETSTR^VALM1(SDOPT,X,SDFST,SDLEN)
+4 IF $PIECE(SDEN,U,5)'=""
Begin DoDot:1
+5 SET X=$$SETSTR^VALM1("Review Date:",X,40,12)
+6 SET X=$$SETSTR^VALM1($$FDATE^VALM1($PIECE(SDEN,U,5)),X,SDSEC,SDLEN)
End DoDot:1
+7 DO SET(X)
REASON ; Reason for Discharge
+1 IF $PIECE(SDEN,U,4)'=""
Begin DoDot:1
+2 SET X=""
SET X=$$SETSTR^VALM1("Reason:",X,1,SDFLN)
+3 SET X=$$SETSTR^VALM1($PIECE(SDEN,U,4),X,SDFST,70)
+4 DO SET(X)
End DoDot:1
+5 DO SET("")
+6 QUIT
SET(X) ; Set in ^TMP global for display
+1 ;
+2 SET SDLN=SDLN+1
SET ^TMP("SDPPALL",$JOB,SDLN,0)=X
+3 QUIT
