BSDCCR3 ; IHS/ANMC/LJF - CLINIC CAPACITY REPORT CONT. ;
;;5.3;PIMS;;APR 26, 2002
;COPY OF SCRPW73 BEFORE PATCH #223
;IHS/ANMC/LJF 10/06/2000 changed credit pair to clinic code-name
; added changes to make report narrower
; use IHS footer for future & past dates
; and only at end of report
; 8/24/2001 fixed parameter passing, used user's choice
; shortened display of clinic name
;
PRT(SDXM) ;Print report
;Input: SDXM='1' for output to mail message text, '0' otherwise
;
N SDX,SDY,SDI,SDP,SDPCT,SDMD,SCNA,SDFOOT,SDT
S SDOUT=0 D HINI^BSDCCR2,FOOT^BSDCCR5(.SDFOOT)
S SDMD=$O(^TMP("SD",$J,"")),SDMD=$O(^TMP("SD",$J,SDMD)),SDMD=$L(SDMD)
I '$D(^TMP("SD",$J)) D Q
.D HDR^BSDCCR2(0) S SDX="No data found within the report parameters selected."
.W !!?(SDIOM-$L(SDX)\2),SDX Q
S SDIV=9999999 F S SDIV=$O(^TMP("SD",$J,SDIV)) Q:SDIV=""!SDOUT D
.I SDFMT="D" D
..S SDCP="" F S SDCP=$O(^TMP("SD",$J,SDIV,SDCP)) Q:SDCP=""!SDOUT D
...S SCNA="" F S SCNA=$O(^TMP("SDS",$J,SDCP,SCNA)) Q:SCNA=""!SDOUT D
....S SC=0 F S SC=$O(^TMP("SDS",$J,SDCP,SCNA,SC)) Q:'SC!SDOUT D
.....Q:'$D(^TMP("SD",$J,SDIV,SDCP,SC))
.....D HDR^BSDCCR2(1,SDIV,SDCP,SC) Q:SDOUT S SDX=^TMP("SD",$J,SDIV,SDCP,SC)
.....I $P(SDX,U)+$P(SDX,U,2)+$P(SDX,U,3)'>0 D Q
......S SDY="No availability found"_$S($L($P(SDX,U,4)):": "_$P(SDX,U,4)_".",1:".")
......W !!?(SDIOM-$L(SDY)\2),SDY Q
.....S SDI="" F S SDI=$O(^TMP("SD",$J,SDIV,SDCP,SC,SDI)) Q:SDI=""!SDOUT D
......S SDX=^TMP("SD",$J,SDIV,SDCP,SC,SDI)
......F SDP=1:1 S SDY=$P(SDX,U,SDP) Q:'$L(SDY)!SDOUT D
.......S SDY=$TR(SDY,"~","^"),SDT=$$DAY(SDI,SDP,SDBDT)
.......S SDY=$$TRX(SDY,SDIV,SDCP,SC,$P(SDT,U,2))
.......;I 'SDXM,$Y>(IOSL-$S(SDPAST:12,1:5)) D ;IHS/ANMC/LJF 10/6/2000
.......I 'SDXM,$Y>(IOSL-$S(SDPAST:5,1:5)) D ;IHS/ANMC/LJF 10/6/2000
........;D:SDPAST FOOTER D HDR^BSDCCR2(1,SDIV,SDCP,SC) ;IHS/ANMC/LJF 10/6/2000
........D HDR^BSDCCR2(1,SDIV,SDCP,SC) ;IHS/ANMC/LJF 10/6/2000
........Q
.......Q:SDOUT
.......D OUTPUT($P(SDT,U),SDY,SDCOL,4,0,SDPAST,.SDXM)
.......Q
......Q
.....Q:SDOUT
.....S SDX=^TMP("SD",$J,SDIV,SDCP,SC),SDX=$$TRX(SDX,SDIV,SDCP,SC)
.....D OUTPUT(" Clinic Total:",SDX,SDCOL,0,1,SDPAST,.SDXM)
.....;D:SDPAST FOOTER ;IHS/ANMC/LJF 10/6/2000
.....Q
....Q
...Q
..Q
.Q:SDOUT D SUM(SDIV) Q
Q:SDOUT
;
I SDMD D SUM(0)
Q
;
TRX(SDX,SDIV,SDCP,SC,SDT) ;Transform string for output
;Input: SDX=output numbers to transform
;Input: SDIV=medical center division
;Input: SDCP=credit pair (optional)
;Input: SC=clinic ien (optional)
;Input: SDT=date for detail by day (optional)
;Output: (prospective report)=clinic_capacity^available_slots^%_slots_
; available
; (retrospective report)=clinic_capacity^available_slots^
; %_slots_available^clinic_encounters^next_ava._flag_'0'_appts.
; ^next_ava._flag_'0'_ave._wait_time^next_ava._flag_'1'_appts.
; ^next_ava._flag_'1'_ave._wait_time^next_ava._flag_'2'_appts.
; ^next_ava._flag_'2'_ave._wait_time^next_ava._flag_'3'_appts.
; ^next_ava._flag_'3'_ave._wait_time
;
N SDY
S SDY=$P(SDX,U,2)_U_$P(SDX,U)_U
S SDY=SDY_$S(+$P(SDX,U,2)=0:0,1:$P(SDX,U)*100\$P(SDX,U,2))
S SDY=SDY_U_$P(SDX,U,3)
I '$G(SDCP) S SDY=SDY_U_$G(^TMP("SDNAVA",$J,SDIV)) Q SDY
I '$G(SC) S SDY=SDY_U_$G(^TMP("SDNAVA",$J,SDIV,SDCP)) Q SDY
I '$G(SDT) S SDY=SDY_U_$G(^TMP("SDNAVA",$J,SDIV,SDCP,SC)) Q SDY
S SDY=SDY_U_$G(^TMP("SDNAVA",$J,SDIV,SDCP,SC,SDT))
Q SDY
;
DAY(SDI,SDP,SDBDT) ;Produce date/day value
;Input: SDI=array subscript incrementor
;Input: SDP=$PIECE of string containing related date data
;Input: SDBDT=report start date
N X1,X2,X,%H,Y,SDT,SDAY
S X1=SDBDT,X2=-1 D C^%DTC
S X1=X,X2=SDI*12+SDP D C^%DTC S SDT=X
D DW^%DTC S SDAY=X,Y=SDT X ^DD("DD")
Q Y_" "_$S($E(SDT,6)=0:"-",1:"")_"- "_SDAY_U_SDT
;
SUM(SDIV) ;Print division/facility summary
;Input: SDDIV=division name^number (or '0' for facility total)
;
N SDY,SCNA,SDI
S SDCP="",SDHD=$S(SDIV=0:3,1:2) D HDR^BSDCCR2(SDHD,SDIV)
F S SDCP=$O(^TMP("SD",$J,SDIV,SDCP)) Q:SDCP=""!SDOUT D
.S SDX=^TMP("SD",$J,SDIV,SDCP),SDY=$G(^TMP("SD",$J,SDIV))
.F SDI=1:1:3 S $P(SDY,U,SDI)=$P(SDY,U,SDI)+$P(SDX,U,SDI)
.S ^TMP("SD",$J,SDIV)=SDY
.I SDFMT="S" Q:$P(SDX,U)+$P(SDX,U,2)+$P(SDX,U,3)'>0
.I SDMD S SDY=$G(^TMP("SD",$J,0,SDCP)) D
..F SDI=1:1:3 S $P(SDY,U,SDI)=$P(SDY,U,SDI)+$P(SDX,U,SDI)
..S ^TMP("SD",$J,0,SDCP)=SDY
.S SDY=$$OTX("CP"),SDX=$$TRX(SDX,SDIV,SDCP)
.D OUTPUT(SDY,SDX,SDCOL,0,1,SDPAST,.SDXM)
.S SCNA="" F S SCNA=$O(^TMP("SDS",$J,SDCP,SCNA)) Q:SCNA=""!SDOUT D
..S SC=0 F S SC=$O(^TMP("SDS",$J,SDCP,SCNA,SC)) Q:'SC!SDOUT D
...S SDX=$G(^TMP("SD",$J,SDIV,SDCP,SC))
...I SDFMT="S" Q:$P(SDX,U)+$P(SDX,U,2)+$P(SDX,U,3)'>0
...;I 'SDXM,$Y>(IOSL-$S(SDPAST:12,1:5)) D ;IHS/ANMC/LJF 10/6/2000
...I 'SDXM,$Y>(IOSL-$S(SDPAST:5,1:5)) D ;IHS/ANMC/LJF 10/6/2000
....;D:SDPAST FOOTER D HDR^BSDCCR2(SDHD,SDIV) ;IHS/ANMC/LJF 10/6/2000
....D HDR^BSDCCR2(SDHD,SDIV) ;IHS/ANMC/LJF 10/6/2000
....Q
...Q:SDOUT
...I SDMD S SDY=$G(^TMP("SD",$J,0,SDCP,SC)) D
....F SDI=1:1:3 S $P(SDY,U,SDI)=$P(SDY,U,SDI)+$P(SDX,U,SDI)
....S ^TMP("SD",$J,0,SDCP,SC)=SDY
....Q
...;IHS/ANMC/LJF 10/6/2000 modified lines below
...;S SDY=$$OTX("CL"),SDX=$$TRX(SDX,SDIV,SDCP,SC)
...;D OUTPUT(SDY,SDX,SDCOL,4,0,SDPAST,.SDXM)
...S SDY=" "_$$OTX("CL"),SDX=$$TRX(SDX,SDIV,SDCP,SC)
...D OUTPUT(SDY,SDX,SDCOL,0,0,SDPAST,.SDXM)
...;IHS/ANMC/LJF 10/6/2000 end of code changes
...Q
..Q
.Q
Q:SDOUT S SDX=$G(^TMP("SD",$J,SDIV)),SDX=$$TRX(SDX,SDIV)
S SDY=$S(SDIV=0:"Facility",1:"Division")_" total:" D OUTPUT(SDY,SDX,SDCOL,0,1,SDPAST,.SDXM)
;D:SDPAST FOOTER ;IHS/ANMC/LJF 10/6/2000
I $Y>(IOSL-$S(SDPAST:9,1:5)) D HDR^BSDCCR2(SDHD,SDIV) ;IHS/ANMC/LJF 10/6/2000
D FOOTER ;IHS/ANMC/LJF 10/6/2000
Q
;
N SDI
I SDXM D Q
.D XMTX(" ") F SDI=1:1:7 D XMTX(SDFOOT(SDI))
.Q
;F SDI=1:1:80 Q:$Y>(IOSL-10) W ! ;IHS/ANMC/LJF 10/6/2000
;F SDI=1:1:7 W !,SDFOOT(SDI) ;IHS/ANMC/LJF 10/6/2000
F SDI=1:1:$S(SDPAST:9,1:5) W !,SDFOOT(SDI) ;IHS/ANMC/LJF 10/6/2000
Q
;
OUTPUT(SDTX,SDX,SDCOL,SDC,SDL,SDPAST,SDXM) ;Write output or load summary message
;Input: SDTX=category text value
;Input: SDX=output count values
;Input: SDCOL=margin adjusted column control
;Input: SDC=column to start line
;Input: SDL=number of additional linefeeds
;Input: SDPAST='0' if dates > TODAY, '1' otherwise
;Input: SDXM=mail message line number message text (optional)
;
N SDI,SDPCT
G:$G(SDXM) OUTXM F SDI=1:1:SDL W !
;
;IHS/ANMC/LJF 10/6/2000; 8/24/2001
;W !?(SDCOL+SDC),SDTX
;F SDI=1:1:$S(SDPAST:12,1:3) D
W !?(SDCOL+SDC),$E(SDTX,1,27)
F SDI=1:1:$S(SDPAST:6,1:3) D
.W ?(SDCOL+34+(SDI-1*8)),$J(+$P(SDX,U,SDI),$S(SDI=3:7,1:8),$$OPD())_$S(SDI=3:"%",1:"")
.Q
;IHS/ANMC/LJF 10/6/2000, 8/24/2001 end of mods
Q
;
OPD() ;Output decimal places
Q $S(SDI<6:0,SDI#2:0,1:1)
;
OUTXM ;Load bulletin message text
;Output: ^TMP("SDXM",$J,SDXM)=mail message text line
N SDZ S:SDC<1 SDC=1
F SDI=1:1:SDL D XMTX("")
S SDZ="",$E(SDZ,SDC)=SDTX
F SDI=1:1:$S(SDPAST:12,1:3) D
.S $E(SDZ,(34+(SDI-1*8)))=$J(+$P(SDX,U,SDI),$S(SDI=3:7,1:8),$$OPD())_$S(SDI=3:"%",1:"")
D XMTX(SDZ)
Q
;
XMTX(SDX) ;Set mail message text line
;Input: SDX=text value
S ^TMP("SDXM",$J,SDXM)=SDX,SDXM=SDXM+1 Q
;
OTX(SDSORT) ;Produce output text for clinic or credit pair
;Input: SDSORT='CL' for clinic name, 'CP' for credit pair
N SDZ,SDSC1,SDSC2
I SDSORT="CL" S SDZ=$P($G(^SC(+SC,0)),U) S:'$L(SDZ) SDZ="UNKNOWN" Q SDZ
S SDSC1=$O(^DIC(40.7,"C",$E(SDCP,1,3),""))
Q SDCP_"-"_$E($$GET1^DIQ(40.7,SDSC1,.01),1,20) ;IHS/ANMC/LJF 10/6/2000
;
S SDSC1=$P($G(^DIC(40.7,+SDSC1,0)),U),SDSC1=$TR(SDSC1,"/","-")
S:'$L(SDSC1) SDSC1="UNKNOWN"
I $E(SDCP,4,6)="000" S SDSC2="(NONE)" G CPO1
S SDSC2=$O(^DIC(40.7,"C",$E(SDCP,4,6),""))
S SDSC2=$P($G(^DIC(40.7,+SDSC2,0)),U),SDSC2=$TR(SDSC2,"/","-")
S:'$L(SDSC2) SDSC2="UNKNOWN"
CPO1 I $L(SDSC1)<13 S SDZ=SDSC1_"/"_$E(SDSC2,1,(13+(13-$L(SDSC1)))) G CPOTQ
I $L(SDSC2)<13 S SDZ=$E(SDSC1,1,(13+(13-$L(SDSC2))))_"/"_SDSC2 G CPOTQ
S SDZ=$E(SDSC1,1,13)_"/"_$E(SDSC2,1,13)
CPOTQ Q SDCP_" "_SDZ
;
HDRXM ;Create header in mail message
;
N SDX,SDI,SDZ
I SDPAGE>1 F SDI=1:1:5 D XMTX("")
D XMTX($E(SDLINE,1,$S(SDPAST:130,1:79)))
S SDZ="",$E(SDZ,($S(SDPAST:130,1:79)-$L(SDTITL)\2))=SDTITL D XMTX(SDZ)
D HDRX^BSDCCR2(SDTY) S SDI=0
F S SDI=$O(SDTIT(SDI)) Q:'SDI S SDZ="" D
.S $E(SDZ,($S(SDPAST:130,1:79)-$L(SDTIT(SDI))\2))=SDTIT(SDI) D XMTX(SDZ)
.Q
D XMTX($E(SDLINE,1,$S(SDPAST:130,1:79))),XMTX("For clinic availability dates "_SDPBDT_" through "_SDPEDT)
S SDZ="Date extracted: "_SDPNOW D XMTX(SDZ),XMTX($E(SDLINE,1,$S(SDPAST:130,1:79)))
S SDPAGE=SDPAGE+1 D:SDTY SUBTXM(SDTY) Q
;
SUBTXM(SDTY) ;Create message header subtitles
N SDI
S SDZ="",$E(SDZ,44)="Avail.",$E(SDZ,54)="Pct."
I SDPAST F SDI=0:1:3 D
.S $E(SDZ,(SDCOL+68+(16*SDI)))="---Type '"_SDI_"'---"
.Q
D XMTX(SDZ)
S SDZ="" I SDTY>1 S SDZ="Credit Pair"
S $E(SDZ,36)="Clinic",$E(SDZ,45)="Appt.",$E(SDZ,53)="Slots"
I SDPAST D
.S $E(SDZ,60)="Clinic"
.F SDI=0:1:3 S $E(SDZ,(SDCOL+68+(16*SDI)))="Sched. Wait"
.Q
D XMTX(SDZ)
S SDZ="",$E(SDZ,4)=$S(SDTY=1:"Availability Date",1:"Clinic Name")
S $E(SDZ,34)="Capacity",$E(SDZ,45)="Slots",$E(SDZ,52)="Avail."
I SDPAST D
.S $E(SDZ,62)="Enc."
.F SDI=0:1:3 S $E(SDZ,(SDCOL+68+(16*SDI)))="Appts. Time"
.Q
D XMTX(SDZ)
S SDZ="",$E(SDZ,$S(SDTY>1:1,1:4))=$E(SDLINE,1,$S(SDPAST:130-$S(SDTY=1:4,1:0),1:58))
D XMTX(SDZ)
Q
BSDCCR3 ; IHS/ANMC/LJF - CLINIC CAPACITY REPORT CONT. ;
+1 ;;5.3;PIMS;;APR 26, 2002
+2 ;COPY OF SCRPW73 BEFORE PATCH #223
+3 ;IHS/ANMC/LJF 10/06/2000 changed credit pair to clinic code-name
+4 ; added changes to make report narrower
+5 ; use IHS footer for future & past dates
+6 ; and only at end of report
+7 ; 8/24/2001 fixed parameter passing, used user's choice
+8 ; shortened display of clinic name
+9 ;
PRT(SDXM) ;Print report
+1 ;Input: SDXM='1' for output to mail message text, '0' otherwise
+2 ;
+3 NEW SDX,SDY,SDI,SDP,SDPCT,SDMD,SCNA,SDFOOT,SDT
+4 SET SDOUT=0
DO HINI^BSDCCR2
DO FOOT^BSDCCR5(.SDFOOT)
+5 SET SDMD=$ORDER(^TMP("SD",$JOB,""))
SET SDMD=$ORDER(^TMP("SD",$JOB,SDMD))
SET SDMD=$LENGTH(SDMD)
+6 IF '$DATA(^TMP("SD",$JOB))
Begin DoDot:1
+7 DO HDR^BSDCCR2(0)
SET SDX="No data found within the report parameters selected."
+8 WRITE !!?(SDIOM-$LENGTH(SDX)\2),SDX
QUIT
End DoDot:1
QUIT
+9 SET SDIV=9999999
FOR
SET SDIV=$ORDER(^TMP("SD",$JOB,SDIV))
IF SDIV=""!SDOUT
QUIT
Begin DoDot:1
+10 IF SDFMT="D"
Begin DoDot:2
+11 SET SDCP=""
FOR
SET SDCP=$ORDER(^TMP("SD",$JOB,SDIV,SDCP))
IF SDCP=""!SDOUT
QUIT
Begin DoDot:3
+12 SET SCNA=""
FOR
SET SCNA=$ORDER(^TMP("SDS",$JOB,SDCP,SCNA))
IF SCNA=""!SDOUT
QUIT
Begin DoDot:4
+13 SET SC=0
FOR
SET SC=$ORDER(^TMP("SDS",$JOB,SDCP,SCNA,SC))
IF 'SC!SDOUT
QUIT
Begin DoDot:5
+14 IF '$DATA(^TMP("SD",$JOB,SDIV,SDCP,SC))
QUIT
+15 DO HDR^BSDCCR2(1,SDIV,SDCP,SC)
IF SDOUT
QUIT
SET SDX=^TMP("SD",$JOB,SDIV,SDCP,SC)
+16 IF $PIECE(SDX,U)+$PIECE(SDX,U,2)+$PIECE(SDX,U,3)'>0
Begin DoDot:6
+17 SET SDY="No availability found"_$SELECT($LENGTH($PIECE(SDX,U,4)):": "_$PIECE(SDX,U,4)_".",1:".")
+18 WRITE !!?(SDIOM-$LENGTH(SDY)\2),SDY
QUIT
End DoDot:6
QUIT
+19 SET SDI=""
FOR
SET SDI=$ORDER(^TMP("SD",$JOB,SDIV,SDCP,SC,SDI))
IF SDI=""!SDOUT
QUIT
Begin DoDot:6
+20 SET SDX=^TMP("SD",$JOB,SDIV,SDCP,SC,SDI)
+21 FOR SDP=1:1
SET SDY=$PIECE(SDX,U,SDP)
IF '$LENGTH(SDY)!SDOUT
QUIT
Begin DoDot:7
+22 SET SDY=$TRANSLATE(SDY,"~","^")
SET SDT=$$DAY(SDI,SDP,SDBDT)
+23 SET SDY=$$TRX(SDY,SDIV,SDCP,SC,$PIECE(SDT,U,2))
+24 ;I 'SDXM,$Y>(IOSL-$S(SDPAST:12,1:5)) D ;IHS/ANMC/LJF 10/6/2000
+25 ;IHS/ANMC/LJF 10/6/2000
IF 'SDXM
IF $Y>(IOSL-$SELECT(SDPAST:5,1:5))
Begin DoDot:8
+26 ;D:SDPAST FOOTER D HDR^BSDCCR2(1,SDIV,SDCP,SC) ;IHS/ANMC/LJF 10/6/2000
+27 ;IHS/ANMC/LJF 10/6/2000
DO HDR^BSDCCR2(1,SDIV,SDCP,SC)
+28 QUIT
End DoDot:8
+29 IF SDOUT
QUIT
+30 DO OUTPUT($PIECE(SDT,U),SDY,SDCOL,4,0,SDPAST,.SDXM)
+31 QUIT
End DoDot:7
+32 QUIT
End DoDot:6
+33 IF SDOUT
QUIT
+34 SET SDX=^TMP("SD",$JOB,SDIV,SDCP,SC)
SET SDX=$$TRX(SDX,SDIV,SDCP,SC)
+35 DO OUTPUT(" Clinic Total:",SDX,SDCOL,0,1,SDPAST,.SDXM)
+36 ;D:SDPAST FOOTER ;IHS/ANMC/LJF 10/6/2000
+37 QUIT
End DoDot:5
+38 QUIT
End DoDot:4
+39 QUIT
End DoDot:3
+40 QUIT
End DoDot:2
+41 IF SDOUT
QUIT
DO SUM(SDIV)
QUIT
End DoDot:1
+42 IF SDOUT
QUIT
+43 ;
+44 IF SDMD
DO SUM(0)
+45 QUIT
+46 ;
TRX(SDX,SDIV,SDCP,SC,SDT) ;Transform string for output
+1 ;Input: SDX=output numbers to transform
+2 ;Input: SDIV=medical center division
+3 ;Input: SDCP=credit pair (optional)
+4 ;Input: SC=clinic ien (optional)
+5 ;Input: SDT=date for detail by day (optional)
+6 ;Output: (prospective report)=clinic_capacity^available_slots^%_slots_
+7 ; available
+8 ; (retrospective report)=clinic_capacity^available_slots^
+9 ; %_slots_available^clinic_encounters^next_ava._flag_'0'_appts.
+10 ; ^next_ava._flag_'0'_ave._wait_time^next_ava._flag_'1'_appts.
+11 ; ^next_ava._flag_'1'_ave._wait_time^next_ava._flag_'2'_appts.
+12 ; ^next_ava._flag_'2'_ave._wait_time^next_ava._flag_'3'_appts.
+13 ; ^next_ava._flag_'3'_ave._wait_time
+14 ;
+15 NEW SDY
+16 SET SDY=$PIECE(SDX,U,2)_U_$PIECE(SDX,U)_U
+17 SET SDY=SDY_$SELECT(+$PIECE(SDX,U,2)=0:0,1:$PIECE(SDX,U)*100\$PIECE(SDX,U,2))
+18 SET SDY=SDY_U_$PIECE(SDX,U,3)
+19 IF '$GET(SDCP)
SET SDY=SDY_U_$GET(^TMP("SDNAVA",$JOB,SDIV))
QUIT SDY
+20 IF '$GET(SC)
SET SDY=SDY_U_$GET(^TMP("SDNAVA",$JOB,SDIV,SDCP))
QUIT SDY
+21 IF '$GET(SDT)
SET SDY=SDY_U_$GET(^TMP("SDNAVA",$JOB,SDIV,SDCP,SC))
QUIT SDY
+22 SET SDY=SDY_U_$GET(^TMP("SDNAVA",$JOB,SDIV,SDCP,SC,SDT))
+23 QUIT SDY
+24 ;
DAY(SDI,SDP,SDBDT) ;Produce date/day value
+1 ;Input: SDI=array subscript incrementor
+2 ;Input: SDP=$PIECE of string containing related date data
+3 ;Input: SDBDT=report start date
+4 NEW X1,X2,X,%H,Y,SDT,SDAY
+5 SET X1=SDBDT
SET X2=-1
DO C^%DTC
+6 SET X1=X
SET X2=SDI*12+SDP
DO C^%DTC
SET SDT=X
+7 DO DW^%DTC
SET SDAY=X
SET Y=SDT
XECUTE ^DD("DD")
+8 QUIT Y_" "_$SELECT($EXTRACT(SDT,6)=0:"-",1:"")_"- "_SDAY_U_SDT
+9 ;
SUM(SDIV) ;Print division/facility summary
+1 ;Input: SDDIV=division name^number (or '0' for facility total)
+2 ;
+3 NEW SDY,SCNA,SDI
+4 SET SDCP=""
SET SDHD=$SELECT(SDIV=0:3,1:2)
DO HDR^BSDCCR2(SDHD,SDIV)
+5 FOR
SET SDCP=$ORDER(^TMP("SD",$JOB,SDIV,SDCP))
IF SDCP=""!SDOUT
QUIT
Begin DoDot:1
+6 SET SDX=^TMP("SD",$JOB,SDIV,SDCP)
SET SDY=$GET(^TMP("SD",$JOB,SDIV))
+7 FOR SDI=1:1:3
SET $PIECE(SDY,U,SDI)=$PIECE(SDY,U,SDI)+$PIECE(SDX,U,SDI)
+8 SET ^TMP("SD",$JOB,SDIV)=SDY
+9 IF SDFMT="S"
IF $PIECE(SDX,U)+$PIECE(SDX,U,2)+$PIECE(SDX,U,3)'>0
QUIT
+10 IF SDMD
SET SDY=$GET(^TMP("SD",$JOB,0,SDCP))
Begin DoDot:2
+11 FOR SDI=1:1:3
SET $PIECE(SDY,U,SDI)=$PIECE(SDY,U,SDI)+$PIECE(SDX,U,SDI)
+12 SET ^TMP("SD",$JOB,0,SDCP)=SDY
End DoDot:2
+13 SET SDY=$$OTX("CP")
SET SDX=$$TRX(SDX,SDIV,SDCP)
+14 DO OUTPUT(SDY,SDX,SDCOL,0,1,SDPAST,.SDXM)
+15 SET SCNA=""
FOR
SET SCNA=$ORDER(^TMP("SDS",$JOB,SDCP,SCNA))
IF SCNA=""!SDOUT
QUIT
Begin DoDot:2
+16 SET SC=0
FOR
SET SC=$ORDER(^TMP("SDS",$JOB,SDCP,SCNA,SC))
IF 'SC!SDOUT
QUIT
Begin DoDot:3
+17 SET SDX=$GET(^TMP("SD",$JOB,SDIV,SDCP,SC))
+18 IF SDFMT="S"
IF $PIECE(SDX,U)+$PIECE(SDX,U,2)+$PIECE(SDX,U,3)'>0
QUIT
+19 ;I 'SDXM,$Y>(IOSL-$S(SDPAST:12,1:5)) D ;IHS/ANMC/LJF 10/6/2000
+20 ;IHS/ANMC/LJF 10/6/2000
IF 'SDXM
IF $Y>(IOSL-$SELECT(SDPAST:5,1:5))
Begin DoDot:4
+21 ;D:SDPAST FOOTER D HDR^BSDCCR2(SDHD,SDIV) ;IHS/ANMC/LJF 10/6/2000
+22 ;IHS/ANMC/LJF 10/6/2000
DO HDR^BSDCCR2(SDHD,SDIV)
+23 QUIT
End DoDot:4
+24 IF SDOUT
QUIT
+25 IF SDMD
SET SDY=$GET(^TMP("SD",$JOB,0,SDCP,SC))
Begin DoDot:4
+26 FOR SDI=1:1:3
SET $PIECE(SDY,U,SDI)=$PIECE(SDY,U,SDI)+$PIECE(SDX,U,SDI)
+27 SET ^TMP("SD",$JOB,0,SDCP,SC)=SDY
+28 QUIT
End DoDot:4
+29 ;IHS/ANMC/LJF 10/6/2000 modified lines below
+30 ;S SDY=$$OTX("CL"),SDX=$$TRX(SDX,SDIV,SDCP,SC)
+31 ;D OUTPUT(SDY,SDX,SDCOL,4,0,SDPAST,.SDXM)
+32 SET SDY=" "_$$OTX("CL")
SET SDX=$$TRX(SDX,SDIV,SDCP,SC)
+33 DO OUTPUT(SDY,SDX,SDCOL,0,0,SDPAST,.SDXM)
+34 ;IHS/ANMC/LJF 10/6/2000 end of code changes
+35 QUIT
End DoDot:3
+36 QUIT
End DoDot:2
+37 QUIT
End DoDot:1
+38 IF SDOUT
QUIT
SET SDX=$GET(^TMP("SD",$JOB,SDIV))
SET SDX=$$TRX(SDX,SDIV)
+39 SET SDY=$SELECT(SDIV=0:"Facility",1:"Division")_" total:"
DO OUTPUT(SDY,SDX,SDCOL,0,1,SDPAST,.SDXM)
+40 ;D:SDPAST FOOTER ;IHS/ANMC/LJF 10/6/2000
+41 ;IHS/ANMC/LJF 10/6/2000
IF $Y>(IOSL-$SELECT(SDPAST:9,1:5))
DO HDR^BSDCCR2(SDHD,SDIV)
+42 ;IHS/ANMC/LJF 10/6/2000
DO FOOTER
+43 QUIT
+44 ;
+1 NEW SDI
+2 IF SDXM
Begin DoDot:1
+3 DO XMTX(" ")
FOR SDI=1:1:7
DO XMTX(SDFOOT(SDI))
+4 QUIT
End DoDot:1
QUIT
+5 ;F SDI=1:1:80 Q:$Y>(IOSL-10) W ! ;IHS/ANMC/LJF 10/6/2000
+6 ;F SDI=1:1:7 W !,SDFOOT(SDI) ;IHS/ANMC/LJF 10/6/2000
+7 ;IHS/ANMC/LJF 10/6/2000
FOR SDI=1:1:$SELECT(SDPAST:9,1:5)
WRITE !,SDFOOT(SDI)
+8 QUIT
+9 ;
OUTPUT(SDTX,SDX,SDCOL,SDC,SDL,SDPAST,SDXM) ;Write output or load summary message
+1 ;Input: SDTX=category text value
+2 ;Input: SDX=output count values
+3 ;Input: SDCOL=margin adjusted column control
+4 ;Input: SDC=column to start line
+5 ;Input: SDL=number of additional linefeeds
+6 ;Input: SDPAST='0' if dates > TODAY, '1' otherwise
+7 ;Input: SDXM=mail message line number message text (optional)
+8 ;
+9 NEW SDI,SDPCT
+10 IF $GET(SDXM)
GOTO OUTXM
FOR SDI=1:1:SDL
WRITE !
+11 ;
+12 ;IHS/ANMC/LJF 10/6/2000; 8/24/2001
+13 ;W !?(SDCOL+SDC),SDTX
+14 ;F SDI=1:1:$S(SDPAST:12,1:3) D
+15 WRITE !?(SDCOL+SDC),$EXTRACT(SDTX,1,27)
+16 FOR SDI=1:1:$SELECT(SDPAST:6,1:3)
Begin DoDot:1
+17 WRITE ?(SDCOL+34+(SDI-1*8)),$JUSTIFY(+$PIECE(SDX,U,SDI),$SELECT(SDI=3:7,1:8),$$OPD())_$SELECT(SDI=3:"%",1:"")
+18 QUIT
End DoDot:1
+19 ;IHS/ANMC/LJF 10/6/2000, 8/24/2001 end of mods
+20 QUIT
+21 ;
OPD() ;Output decimal places
+1 QUIT $SELECT(SDI<6:0,SDI#2:0,1:1)
+2 ;
OUTXM ;Load bulletin message text
+1 ;Output: ^TMP("SDXM",$J,SDXM)=mail message text line
+2 NEW SDZ
IF SDC<1
SET SDC=1
+3 FOR SDI=1:1:SDL
DO XMTX("")
+4 SET SDZ=""
SET $EXTRACT(SDZ,SDC)=SDTX
+5 FOR SDI=1:1:$SELECT(SDPAST:12,1:3)
Begin DoDot:1
+6 SET $EXTRACT(SDZ,(34+(SDI-1*8)))=$JUSTIFY(+$PIECE(SDX,U,SDI),$SELECT(SDI=3:7,1:8),$$OPD())_$SELECT(SDI=3:"%",1:"")
End DoDot:1
+7 DO XMTX(SDZ)
+8 QUIT
+9 ;
XMTX(SDX) ;Set mail message text line
+1 ;Input: SDX=text value
+2 SET ^TMP("SDXM",$JOB,SDXM)=SDX
SET SDXM=SDXM+1
QUIT
+3 ;
OTX(SDSORT) ;Produce output text for clinic or credit pair
+1 ;Input: SDSORT='CL' for clinic name, 'CP' for credit pair
+2 NEW SDZ,SDSC1,SDSC2
+3 IF SDSORT="CL"
SET SDZ=$PIECE($GET(^SC(+SC,0)),U)
IF '$LENGTH(SDZ)
SET SDZ="UNKNOWN"
QUIT SDZ
+4 SET SDSC1=$ORDER(^DIC(40.7,"C",$EXTRACT(SDCP,1,3),""))
+5 ;IHS/ANMC/LJF 10/6/2000
QUIT SDCP_"-"_$EXTRACT($$GET1^DIQ(40.7,SDSC1,.01),1,20)
+6 ;
+7 SET SDSC1=$PIECE($GET(^DIC(40.7,+SDSC1,0)),U)
SET SDSC1=$TRANSLATE(SDSC1,"/","-")
+8 IF '$LENGTH(SDSC1)
SET SDSC1="UNKNOWN"
+9 IF $EXTRACT(SDCP,4,6)="000"
SET SDSC2="(NONE)"
GOTO CPO1
+10 SET SDSC2=$ORDER(^DIC(40.7,"C",$EXTRACT(SDCP,4,6),""))
+11 SET SDSC2=$PIECE($GET(^DIC(40.7,+SDSC2,0)),U)
SET SDSC2=$TRANSLATE(SDSC2,"/","-")
+12 IF '$LENGTH(SDSC2)
SET SDSC2="UNKNOWN"
CPO1 IF $LENGTH(SDSC1)<13
SET SDZ=SDSC1_"/"_$EXTRACT(SDSC2,1,(13+(13-$LENGTH(SDSC1))))
GOTO CPOTQ
+1 IF $LENGTH(SDSC2)<13
SET SDZ=$EXTRACT(SDSC1,1,(13+(13-$LENGTH(SDSC2))))_"/"_SDSC2
GOTO CPOTQ
+2 SET SDZ=$EXTRACT(SDSC1,1,13)_"/"_$EXTRACT(SDSC2,1,13)
CPOTQ QUIT SDCP_" "_SDZ
+1 ;
HDRXM ;Create header in mail message
+1 ;
+2 NEW SDX,SDI,SDZ
+3 IF SDPAGE>1
FOR SDI=1:1:5
DO XMTX("")
+4 DO XMTX($EXTRACT(SDLINE,1,$SELECT(SDPAST:130,1:79)))
+5 SET SDZ=""
SET $EXTRACT(SDZ,($SELECT(SDPAST:130,1:79)-$LENGTH(SDTITL)\2))=SDTITL
DO XMTX(SDZ)
+6 DO HDRX^BSDCCR2(SDTY)
SET SDI=0
+7 FOR
SET SDI=$ORDER(SDTIT(SDI))
IF 'SDI
QUIT
SET SDZ=""
Begin DoDot:1
+8 SET $EXTRACT(SDZ,($SELECT(SDPAST:130,1:79)-$LENGTH(SDTIT(SDI))\2))=SDTIT(SDI)
DO XMTX(SDZ)
+9 QUIT
End DoDot:1
+10 DO XMTX($EXTRACT(SDLINE,1,$SELECT(SDPAST:130,1:79)))
DO XMTX("For clinic availability dates "_SDPBDT_" through "_SDPEDT)
+11 SET SDZ="Date extracted: "_SDPNOW
DO XMTX(SDZ)
DO XMTX($EXTRACT(SDLINE,1,$SELECT(SDPAST:130,1:79)))
+12 SET SDPAGE=SDPAGE+1
IF SDTY
DO SUBTXM(SDTY)
QUIT
+13 ;
SUBTXM(SDTY) ;Create message header subtitles
+1 NEW SDI
+2 SET SDZ=""
SET $EXTRACT(SDZ,44)="Avail."
SET $EXTRACT(SDZ,54)="Pct."
+3 IF SDPAST
FOR SDI=0:1:3
Begin DoDot:1
+4 SET $EXTRACT(SDZ,(SDCOL+68+(16*SDI)))="---Type '"_SDI_"'---"
+5 QUIT
End DoDot:1
+6 DO XMTX(SDZ)
+7 SET SDZ=""
IF SDTY>1
SET SDZ="Credit Pair"
+8 SET $EXTRACT(SDZ,36)="Clinic"
SET $EXTRACT(SDZ,45)="Appt."
SET $EXTRACT(SDZ,53)="Slots"
+9 IF SDPAST
Begin DoDot:1
+10 SET $EXTRACT(SDZ,60)="Clinic"
+11 FOR SDI=0:1:3
SET $EXTRACT(SDZ,(SDCOL+68+(16*SDI)))="Sched. Wait"
+12 QUIT
End DoDot:1
+13 DO XMTX(SDZ)
+14 SET SDZ=""
SET $EXTRACT(SDZ,4)=$SELECT(SDTY=1:"Availability Date",1:"Clinic Name")
+15 SET $EXTRACT(SDZ,34)="Capacity"
SET $EXTRACT(SDZ,45)="Slots"
SET $EXTRACT(SDZ,52)="Avail."
+16 IF SDPAST
Begin DoDot:1
+17 SET $EXTRACT(SDZ,62)="Enc."
+18 FOR SDI=0:1:3
SET $EXTRACT(SDZ,(SDCOL+68+(16*SDI)))="Appts. Time"
+19 QUIT
End DoDot:1
+20 DO XMTX(SDZ)
+21 SET SDZ=""
SET $EXTRACT(SDZ,$SELECT(SDTY>1:1,1:4))=$EXTRACT(SDLINE,1,$SELECT(SDPAST:130-$SELECT(SDTY=1:4,1:0),1:58))
+22 DO XMTX(SDZ)
+23 QUIT
