- 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 Feb 19, 2025@00:26:16 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
