SCRPW73 ;BP-CIOFO/KEITH,ESW - Clinic appointment availability extract (cont.) ; 5/28/03 2:27pm
;;5.3;Scheduling;**192,206,223,249,291**;AUG 13, 1993
;
PRT(SDXM,SDREPORT) ;Print report
;Input: SDXM='1' for output to mail message text, '0' otherwise
;Input: SDREPORT=report element to print
;
N SDX,SDY,SDI,SDP,SDPCT,SDMD,SCNA,SDT,SDFLEN
S SDOUT=0,SDFLEN=$S('SDPAST:5,SDREPORT#1:12,1:11)
S SDMD=$O(^TMP("SD",$J,"")),SDMD=$O(^TMP("SD",$J,SDMD)),SDMD=$L(SDMD)
I '$D(^TMP("SD",$J)),$G(SDREPORT)'=5 D Q
.D HDR^SCRPW76(0,SDREPORT) S SDX="No data found within the report parameters selected."
.W !!?(SDIOM-$L(SDX)\2),SDX Q
I '$D(^TMP("SDIPLST",$J)),$G(SDREPORT)=5 D Q
.D HDR^SCRPW76(0,SDREPORT) S SDX="No data found within the report parameters selected."
.W !!?(SDIOM-$L(SDX)\2),SDX Q
I SDREPORT=5 D PRT5^SCRPW78 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^SCRPW76(1,SDREPORT,SDIV,SDCP,SC) Q:SDOUT
.....I SDREPORT=4 D OUT4^SCRPW77 Q
.....S SDX=^TMP("SD",$J,SDIV,SDCP,SC)
.....I $P(SDX,U)+$P(SDX,U,2)+$P(SDX,U,3)'>0,'$D(^TMP("SDNAVA",$J,SDIV,SDCP,SC)) 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(SDREPORT,SDY,SDIV,SDCP,SC,$P(SDT,U,2))
.......I 'SDXM,$Y>(IOSL-SDFLEN) D
........D:SDPAST FOOTER^SCRPW77(SDREPORT) D HDR^SCRPW76(1,SDREPORT,SDIV,SDCP,SC)
........Q
.......Q:SDOUT
.......D OUTPUT(SDREPORT,$P(SDT,U),SDY,SDCOL,4,0,SDPAST,.SDXM)
.......Q
......Q
.....Q:SDOUT
.....S SDX=^TMP("SD",$J,SDIV,SDCP,SC),SDX=$$TRX(SDREPORT,SDX,SDIV,SDCP,SC)
.....D OUTPUT(SDREPORT," Clinic Total:",SDX,SDCOL,0,1,SDPAST,.SDXM)
.....D:SDPAST FOOTER^SCRPW77(SDREPORT)
.....Q
....Q
...Q
..Q
.Q:SDOUT D SUM(SDIV,SDREPORT) Q
Q:SDOUT
;
I SDMD D SUM(0,SDREPORT)
Q
;
TRX(SDREPORT,SDX,SDIV,SDCP,SC,SDT) ;Transform string for output
;Input: SDREPORT=report element to print
;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: string of output values for specified SDREPORT type
;
N SDY
I SDREPORT=1 S SDY=$$TRX1()
I SDREPORT=2 S SDY=$$TRX2()
I SDREPORT=3 S SDY=$$TRX3()
Q SDY
;
TRX1() N SDZ S SDZ=""
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) D
.I '$G(SDCP) S SDZ=$G(^TMP("SDNAVA",$J,SDIV)) Q
.I '$G(SC) S SDZ=$G(^TMP("SDNAVA",$J,SDIV,SDCP)) Q
.I '$G(SDT) S SDZ=$G(^TMP("SDNAVA",$J,SDIV,SDCP,SC)) Q
.S SDZ=$G(^TMP("SDNAVA",$J,SDIV,SDCP,SC,SDT)) Q
S SDY=SDY_U_$P(SDZ,U,1,8)_U_$P(SDZ,U,38,39)
Q SDY
;
TRX2() I '$G(SDCP) S SDY=$P($G(^TMP("SDNAVA",$J,SDIV)),U,9,20) Q SDY
I '$G(SC) S SDY=$P($G(^TMP("SDNAVA",$J,SDIV,SDCP)),U,9,20) Q SDY
I '$G(SDT) S SDY=$P($G(^TMP("SDNAVA",$J,SDIV,SDCP,SC)),U,9,20) Q SDY
S SDY=$P($G(^TMP("SDNAVA",$J,SDIV,SDCP,SC,SDT)),U,9,20)
Q SDY
;
TRX3() I '$G(SDCP) S SDY=$P($G(^TMP("SDNAVA",$J,SDIV)),U,21,37) Q SDY
I '$G(SC) S SDY=$P($G(^TMP("SDNAVA",$J,SDIV,SDCP)),U,21,37) Q SDY
I '$G(SDT) S SDY=$P($G(^TMP("SDNAVA",$J,SDIV,SDCP,SC)),U,21,37) Q SDY
S SDY=$P($G(^TMP("SDNAVA",$J,SDIV,SDCP,SC,SDT)),U,21,37)
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,SDREPORT) ;Print division/facility summary
;Input: SDDIV=division name^number (or '0' for facility total)
;Input: SDREPORT=report element to print
;
I SDREPORT=4!(SDREPORT=5) Q
N SDY,SCNA,SDI
S SDCP="",SDHD=$S(SDIV=0:3,1:2) D HDR^SCRPW76(SDHD,SDREPORT,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
.Q:'$$DATA(1) ;Quit if no data
.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(SDREPORT,SDX,SDIV,SDCP)
.D OUTPUT(SDREPORT,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))
...Q:'$$DATA(2) ;Quit if no data
...I 'SDXM,$Y>(IOSL-SDFLEN) D
....D:SDPAST FOOTER^SCRPW77(SDREPORT) D HDR^SCRPW76(SDHD,SDREPORT,SDIV)
....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
...S SDY=$$OTX("CL"),SDX=$$TRX(SDREPORT,SDX,SDIV,SDCP,SC)
...D OUTPUT(SDREPORT,SDY,SDX,SDCOL,4,0,SDPAST,.SDXM)
...Q
..Q
.Q
Q:SDOUT S SDX=$G(^TMP("SD",$J,SDIV)),SDX=$$TRX(SDREPORT,SDX,SDIV)
I $G(SDFMT)="S"&($G(SDFMTS)="CP") D:SDPAST FOOTER^SCRPW77(SDREPORT) Q
S SDY=$S(SDIV=0:"Facility",1:"Division")_" total:" D OUTPUT(SDREPORT,SDY,SDX,SDCOL,0,1,SDPAST,.SDXM,1)
D:SDPAST FOOTER^SCRPW77(SDREPORT)
Q
;
DATA(SDS) ;Check for data to print
;Input: SDS=subscript level
;Output: '1' if data, '0' otherwise
N SDCK,SDNODE,SDI,SDCT S (SDCT,SDCK)=0
Q:SDFMT'="S" 1
I 'SDPAST S SDCK=($P(SDX,U)+$P(SDX,U,2)+$P(SDX,U,3)>0) Q SDCK
I $P(SDX,U)+$P(SDX,U,2)+$P(SDX,U,3)>0 Q 1
I SDS=1 S SDNODE=$G(^TMP("SDNAVA",$J,SDIV,SDCP))
I SDS=2 S SDNODE=$G(^TMP("SDNAVA",$J,SDIV,SDCP,SC))
F SDI=1:1:39 S SDCT=SDCT+$P(SDNODE,U,SDI)
S SDCK=SDCT>0
Q SDCK
;
OUTPUT(SDREPORT,SDTX,SDX,SDCOL,SDC,SDL,SDPAST,SDXM,SDTL) ;Write output or load summary message
;Input: SDREPORT=report element to print
;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)
;Input: SDTL='1' if this is a totals line
;
N SDI,SDPCT
G:$G(SDXM) OUTXM F SDI=1:1:SDL W !
D:SDREPORT=1 OUT1 D:SDREPORT=2 OUT2 D:SDREPORT=3 OUT3
Q
;
OUT1 N SDL1,SDL2,SDL3
W !?(SDCOL+SDC),SDTX
F SDI=1:1:$S(SDPAST:12,1:3) D MANI(SDX,SDI,$G(SDTL)) D
.W ?(SDCOL+34+SDL1+(SDI-1*7)),$J(+$P(SDX,U,SDI),$S(((SDI<3)&(SDL3>7)):SDL3,SDI=3:(6-SDL1),1:7),$$OPD())_$S(SDI=3:"%",1:"")
.Q
I SDPAST F SDI=0,1 D
.W ?(SDCOL+118+(SDI*7)),$J(+$P(SDX,U,13+SDI),6,0)_"%"
.Q
Q
;
MANI(SDX,SDI,SDTL) ;Manipulate column position for large totals
;
S (SDL1,SDL2)=0,SDL3=$L($P(SDX,U,SDI))
I $G(SDTL) D
.I SDI=1,SDL3>7 S SDL1=(7-SDL3)
.I SDI=2,SDL3>6 S SDL1=1
.I SDI=3 S SDL1=3
.Q
Q
;
OUT2 W !?(SDCOL+SDC),SDTX
F SDI=0:1:5 D
.W ?(36+(SDI*16)),$J(+$P(SDX,U,(1+(SDI*2))),8,0)
.W ?(44+(SDI*16)),$J(+$P(SDX,U,(2+(SDI*2))),8,1)
.Q
Q
;
OUT3 W !?(SDCOL+SDC),SDTX
W ?30,$J(+$P(SDX,U),6,0),?36,$J(+$P(SDX,U,2),6,1)
F SDI=0:1:4 D
.W ?(42+(SDI*18)),$J(+$P(SDX,U,(3+(SDI*3))),6,0)
.W ?(48+(SDI*18)),$J(+$P(SDX,U,(4+(SDI*3))),6,1)
.W ?(54+(SDI*18)),$J(+$P(SDX,U,(5+(SDI*3))),6,1)
.Q
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("")
D:SDREPORT=1 OUTXM1 D:SDREPORT=2 OUTXM2 D:SDREPORT=3 OUTXM3
Q
;
OUTXM1 N SDL1,SDL2,SDL3
S SDZ="",$E(SDZ,SDC)=SDTX
F SDI=1:1:$S(SDPAST:12,1:3) D MANI(SDX,SDI,$G(SDTL)) D
.S $E(SDZ,(35+SDL1+(SDI-1*7)))=$J(+$P(SDX,U,SDI),$S(((SDI<3)&(SDL3>7)):SDL3,SDI=3:(6-SDL1),1:7),$$OPD())_$S(SDI=3:"%",1:"")
I SDPAST F SDI=0,1 D
.S $E(SDZ,(119+(SDI*7)))=$J(+$P(SDX,U,13+SDI),6,0)_"%"
D XMTX(SDZ)
Q
;
OUTXM2 S SDZ="",$E(SDZ,SDC)=SDTX
F SDI=0:1:5 D
.S $E(SDZ,(37+(SDI*16)))=$J(+$P(SDX,U,(1+(SDI*2))),8,0)
.S $E(SDZ,(45+(SDI*16)))=$J(+$P(SDX,U,(2+(SDI*2))),8,1)
.Q
D XMTX(SDZ)
Q
;
OUTXM3 S SDZ="",$E(SDZ,SDC)=SDTX
S $E(SDZ,31)=$J(+$P(SDX,U),6,0),$E(SDZ,37)=$J(+$P(SDX,U,2),6,1)
F SDI=0:1:4 D
.S $E(SDZ,(43+(SDI*18)))=$J(+$P(SDX,U,(3+(SDI*3))),6,0)
.S $E(SDZ,(49+(SDI*18)))=$J(+$P(SDX,U,(4+(SDI*3))),6,1)
.S $E(SDZ,(55+(SDI*18)))=$J(+$P(SDX,U,(5+(SDI*3))),6,1)
.Q
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" D Q SDZ
.S SDZ=$P($G(^SC(+SC,0)),U) S:'$L(SDZ) SDZ="UNKNOWN"
.I SDREPORT=3 S SDZ=$E(SDZ,1,26)
.Q
S SDSC1=$O(^DIC(40.7,"C",$E(SDCP,1,3),""))
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 S SDZ=SDCP_" "_SDZ I SDREPORT=3 S SDZ=$E(SDZ,1,30)
Q SDZ
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPW73 9992 printed Sep 23, 2025@20:20:27 Page 2
SCRPW73 ;BP-CIOFO/KEITH,ESW - Clinic appointment availability extract (cont.) ; 5/28/03 2:27pm
+1 ;;5.3;Scheduling;**192,206,223,249,291**;AUG 13, 1993
+2 ;
PRT(SDXM,SDREPORT) ;Print report
+1 ;Input: SDXM='1' for output to mail message text, '0' otherwise
+2 ;Input: SDREPORT=report element to print
+3 ;
+4 NEW SDX,SDY,SDI,SDP,SDPCT,SDMD,SCNA,SDT,SDFLEN
+5 SET SDOUT=0
SET SDFLEN=$SELECT('SDPAST:5,SDREPORT#1:12,1:11)
+6 SET SDMD=$ORDER(^TMP("SD",$JOB,""))
SET SDMD=$ORDER(^TMP("SD",$JOB,SDMD))
SET SDMD=$LENGTH(SDMD)
+7 IF '$DATA(^TMP("SD",$JOB))
IF $GET(SDREPORT)'=5
Begin DoDot:1
+8 DO HDR^SCRPW76(0,SDREPORT)
SET SDX="No data found within the report parameters selected."
+9 WRITE !!?(SDIOM-$LENGTH(SDX)\2),SDX
QUIT
End DoDot:1
QUIT
+10 IF '$DATA(^TMP("SDIPLST",$JOB))
IF $GET(SDREPORT)=5
Begin DoDot:1
+11 DO HDR^SCRPW76(0,SDREPORT)
SET SDX="No data found within the report parameters selected."
+12 WRITE !!?(SDIOM-$LENGTH(SDX)\2),SDX
QUIT
End DoDot:1
QUIT
+13 IF SDREPORT=5
DO PRT5^SCRPW78
QUIT
+14 SET SDIV=9999999
FOR
SET SDIV=$ORDER(^TMP("SD",$JOB,SDIV))
if SDIV=""!SDOUT
QUIT
Begin DoDot:1
+15 IF SDFMT="D"
Begin DoDot:2
+16 SET SDCP=""
FOR
SET SDCP=$ORDER(^TMP("SD",$JOB,SDIV,SDCP))
if SDCP=""!SDOUT
QUIT
Begin DoDot:3
+17 SET SCNA=""
FOR
SET SCNA=$ORDER(^TMP("SDS",$JOB,SDCP,SCNA))
if SCNA=""!SDOUT
QUIT
Begin DoDot:4
+18 SET SC=0
FOR
SET SC=$ORDER(^TMP("SDS",$JOB,SDCP,SCNA,SC))
if 'SC!SDOUT
QUIT
Begin DoDot:5
+19 if '$DATA(^TMP("SD",$JOB,SDIV,SDCP,SC))
QUIT
+20 DO HDR^SCRPW76(1,SDREPORT,SDIV,SDCP,SC)
if SDOUT
QUIT
+21 IF SDREPORT=4
DO OUT4^SCRPW77
QUIT
+22 SET SDX=^TMP("SD",$JOB,SDIV,SDCP,SC)
+23 IF $PIECE(SDX,U)+$PIECE(SDX,U,2)+$PIECE(SDX,U,3)'>0
IF '$DATA(^TMP("SDNAVA",$JOB,SDIV,SDCP,SC))
Begin DoDot:6
+24 SET SDY="No availability found"_$SELECT($LENGTH($PIECE(SDX,U,4)):": "_$PIECE(SDX,U,4)_".",1:".")
+25 WRITE !!?(SDIOM-$LENGTH(SDY)\2),SDY
QUIT
End DoDot:6
QUIT
+26 SET SDI=""
FOR
SET SDI=$ORDER(^TMP("SD",$JOB,SDIV,SDCP,SC,SDI))
if SDI=""!SDOUT
QUIT
Begin DoDot:6
+27 SET SDX=^TMP("SD",$JOB,SDIV,SDCP,SC,SDI)
+28 FOR SDP=1:1
SET SDY=$PIECE(SDX,U,SDP)
if '$LENGTH(SDY)!SDOUT
QUIT
Begin DoDot:7
+29 SET SDY=$TRANSLATE(SDY,"~","^")
SET SDT=$$DAY(SDI,SDP,SDBDT)
+30 SET SDY=$$TRX(SDREPORT,SDY,SDIV,SDCP,SC,$PIECE(SDT,U,2))
+31 IF 'SDXM
IF $Y>(IOSL-SDFLEN)
Begin DoDot:8
+32 if SDPAST
DO FOOTER^SCRPW77(SDREPORT)
DO HDR^SCRPW76(1,SDREPORT,SDIV,SDCP,SC)
+33 QUIT
End DoDot:8
+34 if SDOUT
QUIT
+35 DO OUTPUT(SDREPORT,$PIECE(SDT,U),SDY,SDCOL,4,0,SDPAST,.SDXM)
+36 QUIT
End DoDot:7
+37 QUIT
End DoDot:6
+38 if SDOUT
QUIT
+39 SET SDX=^TMP("SD",$JOB,SDIV,SDCP,SC)
SET SDX=$$TRX(SDREPORT,SDX,SDIV,SDCP,SC)
+40 DO OUTPUT(SDREPORT," Clinic Total:",SDX,SDCOL,0,1,SDPAST,.SDXM)
+41 if SDPAST
DO FOOTER^SCRPW77(SDREPORT)
+42 QUIT
End DoDot:5
+43 QUIT
End DoDot:4
+44 QUIT
End DoDot:3
+45 QUIT
End DoDot:2
+46 if SDOUT
QUIT
DO SUM(SDIV,SDREPORT)
QUIT
End DoDot:1
+47 if SDOUT
QUIT
+48 ;
+49 IF SDMD
DO SUM(0,SDREPORT)
+50 QUIT
+51 ;
TRX(SDREPORT,SDX,SDIV,SDCP,SC,SDT) ;Transform string for output
+1 ;Input: SDREPORT=report element to print
+2 ;Input: SDX=output numbers to transform
+3 ;Input: SDIV=medical center division
+4 ;Input: SDCP=credit pair (optional)
+5 ;Input: SC=clinic ien (optional)
+6 ;Input: SDT=date for detail by day (optional)
+7 ;Output: string of output values for specified SDREPORT type
+8 ;
+9 NEW SDY
+10 IF SDREPORT=1
SET SDY=$$TRX1()
+11 IF SDREPORT=2
SET SDY=$$TRX2()
+12 IF SDREPORT=3
SET SDY=$$TRX3()
+13 QUIT SDY
+14 ;
TRX1() NEW SDZ
SET SDZ=""
+1 SET SDY=$PIECE(SDX,U,2)_U_$PIECE(SDX,U)_U
+2 SET SDY=SDY_$SELECT(+$PIECE(SDX,U,2)=0:0,1:$PIECE(SDX,U)*100\$PIECE(SDX,U,2))
+3 SET SDY=SDY_U_$PIECE(SDX,U,3)
Begin DoDot:1
+4 IF '$GET(SDCP)
SET SDZ=$GET(^TMP("SDNAVA",$JOB,SDIV))
QUIT
+5 IF '$GET(SC)
SET SDZ=$GET(^TMP("SDNAVA",$JOB,SDIV,SDCP))
QUIT
+6 IF '$GET(SDT)
SET SDZ=$GET(^TMP("SDNAVA",$JOB,SDIV,SDCP,SC))
QUIT
+7 SET SDZ=$GET(^TMP("SDNAVA",$JOB,SDIV,SDCP,SC,SDT))
QUIT
End DoDot:1
+8 SET SDY=SDY_U_$PIECE(SDZ,U,1,8)_U_$PIECE(SDZ,U,38,39)
+9 QUIT SDY
+10 ;
TRX2() IF '$GET(SDCP)
SET SDY=$PIECE($GET(^TMP("SDNAVA",$JOB,SDIV)),U,9,20)
QUIT SDY
+1 IF '$GET(SC)
SET SDY=$PIECE($GET(^TMP("SDNAVA",$JOB,SDIV,SDCP)),U,9,20)
QUIT SDY
+2 IF '$GET(SDT)
SET SDY=$PIECE($GET(^TMP("SDNAVA",$JOB,SDIV,SDCP,SC)),U,9,20)
QUIT SDY
+3 SET SDY=$PIECE($GET(^TMP("SDNAVA",$JOB,SDIV,SDCP,SC,SDT)),U,9,20)
+4 QUIT SDY
+5 ;
TRX3() IF '$GET(SDCP)
SET SDY=$PIECE($GET(^TMP("SDNAVA",$JOB,SDIV)),U,21,37)
QUIT SDY
+1 IF '$GET(SC)
SET SDY=$PIECE($GET(^TMP("SDNAVA",$JOB,SDIV,SDCP)),U,21,37)
QUIT SDY
+2 IF '$GET(SDT)
SET SDY=$PIECE($GET(^TMP("SDNAVA",$JOB,SDIV,SDCP,SC)),U,21,37)
QUIT SDY
+3 SET SDY=$PIECE($GET(^TMP("SDNAVA",$JOB,SDIV,SDCP,SC,SDT)),U,21,37)
+4 QUIT SDY
+5 ;
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,SDREPORT) ;Print division/facility summary
+1 ;Input: SDDIV=division name^number (or '0' for facility total)
+2 ;Input: SDREPORT=report element to print
+3 ;
+4 IF SDREPORT=4!(SDREPORT=5)
QUIT
+5 NEW SDY,SCNA,SDI
+6 SET SDCP=""
SET SDHD=$SELECT(SDIV=0:3,1:2)
DO HDR^SCRPW76(SDHD,SDREPORT,SDIV)
+7 FOR
SET SDCP=$ORDER(^TMP("SD",$JOB,SDIV,SDCP))
if SDCP=""!SDOUT
QUIT
Begin DoDot:1
+8 SET SDX=^TMP("SD",$JOB,SDIV,SDCP)
SET SDY=$GET(^TMP("SD",$JOB,SDIV))
+9 FOR SDI=1:1:3
SET $PIECE(SDY,U,SDI)=$PIECE(SDY,U,SDI)+$PIECE(SDX,U,SDI)
+10 SET ^TMP("SD",$JOB,SDIV)=SDY
+11 ;Quit if no data
if '$$DATA(1)
QUIT
+12 IF SDMD
SET SDY=$GET(^TMP("SD",$JOB,0,SDCP))
Begin DoDot:2
+13 FOR SDI=1:1:3
SET $PIECE(SDY,U,SDI)=$PIECE(SDY,U,SDI)+$PIECE(SDX,U,SDI)
+14 SET ^TMP("SD",$JOB,0,SDCP)=SDY
End DoDot:2
+15 SET SDY=$$OTX("CP")
SET SDX=$$TRX(SDREPORT,SDX,SDIV,SDCP)
+16 DO OUTPUT(SDREPORT,SDY,SDX,SDCOL,0,1,SDPAST,.SDXM)
+17 SET SCNA=""
FOR
SET SCNA=$ORDER(^TMP("SDS",$JOB,SDCP,SCNA))
if SCNA=""!SDOUT
QUIT
Begin DoDot:2
+18 SET SC=0
FOR
SET SC=$ORDER(^TMP("SDS",$JOB,SDCP,SCNA,SC))
if 'SC!SDOUT
QUIT
Begin DoDot:3
+19 SET SDX=$GET(^TMP("SD",$JOB,SDIV,SDCP,SC))
+20 ;Quit if no data
if '$$DATA(2)
QUIT
+21 IF 'SDXM
IF $Y>(IOSL-SDFLEN)
Begin DoDot:4
+22 if SDPAST
DO FOOTER^SCRPW77(SDREPORT)
DO HDR^SCRPW76(SDHD,SDREPORT,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 SET SDY=$$OTX("CL")
SET SDX=$$TRX(SDREPORT,SDX,SDIV,SDCP,SC)
+30 DO OUTPUT(SDREPORT,SDY,SDX,SDCOL,4,0,SDPAST,.SDXM)
+31 QUIT
End DoDot:3
+32 QUIT
End DoDot:2
+33 QUIT
End DoDot:1
+34 if SDOUT
QUIT
SET SDX=$GET(^TMP("SD",$JOB,SDIV))
SET SDX=$$TRX(SDREPORT,SDX,SDIV)
+35 IF $GET(SDFMT)="S"&($GET(SDFMTS)="CP")
if SDPAST
DO FOOTER^SCRPW77(SDREPORT)
QUIT
+36 SET SDY=$SELECT(SDIV=0:"Facility",1:"Division")_" total:"
DO OUTPUT(SDREPORT,SDY,SDX,SDCOL,0,1,SDPAST,.SDXM,1)
+37 if SDPAST
DO FOOTER^SCRPW77(SDREPORT)
+38 QUIT
+39 ;
DATA(SDS) ;Check for data to print
+1 ;Input: SDS=subscript level
+2 ;Output: '1' if data, '0' otherwise
+3 NEW SDCK,SDNODE,SDI,SDCT
SET (SDCT,SDCK)=0
+4 if SDFMT'="S"
QUIT 1
+5 IF 'SDPAST
SET SDCK=($PIECE(SDX,U)+$PIECE(SDX,U,2)+$PIECE(SDX,U,3)>0)
QUIT SDCK
+6 IF $PIECE(SDX,U)+$PIECE(SDX,U,2)+$PIECE(SDX,U,3)>0
QUIT 1
+7 IF SDS=1
SET SDNODE=$GET(^TMP("SDNAVA",$JOB,SDIV,SDCP))
+8 IF SDS=2
SET SDNODE=$GET(^TMP("SDNAVA",$JOB,SDIV,SDCP,SC))
+9 FOR SDI=1:1:39
SET SDCT=SDCT+$PIECE(SDNODE,U,SDI)
+10 SET SDCK=SDCT>0
+11 QUIT SDCK
+12 ;
OUTPUT(SDREPORT,SDTX,SDX,SDCOL,SDC,SDL,SDPAST,SDXM,SDTL) ;Write output or load summary message
+1 ;Input: SDREPORT=report element to print
+2 ;Input: SDTX=category text value
+3 ;Input: SDX=output count values
+4 ;Input: SDCOL=margin adjusted column control
+5 ;Input: SDC=column to start line
+6 ;Input: SDL=number of additional linefeeds
+7 ;Input: SDPAST='0' if dates > TODAY, '1' otherwise
+8 ;Input: SDXM=mail message line number message text (optional)
+9 ;Input: SDTL='1' if this is a totals line
+10 ;
+11 NEW SDI,SDPCT
+12 if $GET(SDXM)
GOTO OUTXM
FOR SDI=1:1:SDL
WRITE !
+13 if SDREPORT=1
DO OUT1
if SDREPORT=2
DO OUT2
if SDREPORT=3
DO OUT3
+14 QUIT
+15 ;
OUT1 NEW SDL1,SDL2,SDL3
+1 WRITE !?(SDCOL+SDC),SDTX
+2 FOR SDI=1:1:$SELECT(SDPAST:12,1:3)
DO MANI(SDX,SDI,$GET(SDTL))
Begin DoDot:1
+3 WRITE ?(SDCOL+34+SDL1+(SDI-1*7)),$JUSTIFY(+$PIECE(SDX,U,SDI),$SELECT(((SDI<3)&(SDL3>7)):SDL3,SDI=3:(6-SDL1),1:7),$$OPD())_$SELECT(SDI=3:"%",1:"")
+4 QUIT
End DoDot:1
+5 IF SDPAST
FOR SDI=0,1
Begin DoDot:1
+6 WRITE ?(SDCOL+118+(SDI*7)),$JUSTIFY(+$PIECE(SDX,U,13+SDI),6,0)_"%"
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
MANI(SDX,SDI,SDTL) ;Manipulate column position for large totals
+1 ;
+2 SET (SDL1,SDL2)=0
SET SDL3=$LENGTH($PIECE(SDX,U,SDI))
+3 IF $GET(SDTL)
Begin DoDot:1
+4 IF SDI=1
IF SDL3>7
SET SDL1=(7-SDL3)
+5 IF SDI=2
IF SDL3>6
SET SDL1=1
+6 IF SDI=3
SET SDL1=3
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
OUT2 WRITE !?(SDCOL+SDC),SDTX
+1 FOR SDI=0:1:5
Begin DoDot:1
+2 WRITE ?(36+(SDI*16)),$JUSTIFY(+$PIECE(SDX,U,(1+(SDI*2))),8,0)
+3 WRITE ?(44+(SDI*16)),$JUSTIFY(+$PIECE(SDX,U,(2+(SDI*2))),8,1)
+4 QUIT
End DoDot:1
+5 QUIT
+6 ;
OUT3 WRITE !?(SDCOL+SDC),SDTX
+1 WRITE ?30,$JUSTIFY(+$PIECE(SDX,U),6,0),?36,$JUSTIFY(+$PIECE(SDX,U,2),6,1)
+2 FOR SDI=0:1:4
Begin DoDot:1
+3 WRITE ?(42+(SDI*18)),$JUSTIFY(+$PIECE(SDX,U,(3+(SDI*3))),6,0)
+4 WRITE ?(48+(SDI*18)),$JUSTIFY(+$PIECE(SDX,U,(4+(SDI*3))),6,1)
+5 WRITE ?(54+(SDI*18)),$JUSTIFY(+$PIECE(SDX,U,(5+(SDI*3))),6,1)
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
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 if SDREPORT=1
DO OUTXM1
if SDREPORT=2
DO OUTXM2
if SDREPORT=3
DO OUTXM3
+5 QUIT
+6 ;
OUTXM1 NEW SDL1,SDL2,SDL3
+1 SET SDZ=""
SET $EXTRACT(SDZ,SDC)=SDTX
+2 FOR SDI=1:1:$SELECT(SDPAST:12,1:3)
DO MANI(SDX,SDI,$GET(SDTL))
Begin DoDot:1
+3 SET $EXTRACT(SDZ,(35+SDL1+(SDI-1*7)))=$JUSTIFY(+$PIECE(SDX,U,SDI),$SELECT(((SDI<3)&(SDL3>7)):SDL3,SDI=3:(6-SDL1),1:7),$$OPD())_$SELECT(SDI=3:"%",1:"")
End DoDot:1
+4 IF SDPAST
FOR SDI=0,1
Begin DoDot:1
+5 SET $EXTRACT(SDZ,(119+(SDI*7)))=$JUSTIFY(+$PIECE(SDX,U,13+SDI),6,0)_"%"
End DoDot:1
+6 DO XMTX(SDZ)
+7 QUIT
+8 ;
OUTXM2 SET SDZ=""
SET $EXTRACT(SDZ,SDC)=SDTX
+1 FOR SDI=0:1:5
Begin DoDot:1
+2 SET $EXTRACT(SDZ,(37+(SDI*16)))=$JUSTIFY(+$PIECE(SDX,U,(1+(SDI*2))),8,0)
+3 SET $EXTRACT(SDZ,(45+(SDI*16)))=$JUSTIFY(+$PIECE(SDX,U,(2+(SDI*2))),8,1)
+4 QUIT
End DoDot:1
+5 DO XMTX(SDZ)
+6 QUIT
+7 ;
OUTXM3 SET SDZ=""
SET $EXTRACT(SDZ,SDC)=SDTX
+1 SET $EXTRACT(SDZ,31)=$JUSTIFY(+$PIECE(SDX,U),6,0)
SET $EXTRACT(SDZ,37)=$JUSTIFY(+$PIECE(SDX,U,2),6,1)
+2 FOR SDI=0:1:4
Begin DoDot:1
+3 SET $EXTRACT(SDZ,(43+(SDI*18)))=$JUSTIFY(+$PIECE(SDX,U,(3+(SDI*3))),6,0)
+4 SET $EXTRACT(SDZ,(49+(SDI*18)))=$JUSTIFY(+$PIECE(SDX,U,(4+(SDI*3))),6,1)
+5 SET $EXTRACT(SDZ,(55+(SDI*18)))=$JUSTIFY(+$PIECE(SDX,U,(5+(SDI*3))),6,1)
+6 QUIT
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"
Begin DoDot:1
+4 SET SDZ=$PIECE($GET(^SC(+SC,0)),U)
if '$LENGTH(SDZ)
SET SDZ="UNKNOWN"
+5 IF SDREPORT=3
SET SDZ=$EXTRACT(SDZ,1,26)
+6 QUIT
End DoDot:1
QUIT SDZ
+7 SET SDSC1=$ORDER(^DIC(40.7,"C",$EXTRACT(SDCP,1,3),""))
+8 SET SDSC1=$PIECE($GET(^DIC(40.7,+SDSC1,0)),U)
SET SDSC1=$TRANSLATE(SDSC1,"/","-")
+9 if '$LENGTH(SDSC1)
SET SDSC1="UNKNOWN"
+10 IF $EXTRACT(SDCP,4,6)="000"
SET SDSC2="(NONE)"
GOTO CPO1
+11 SET SDSC2=$ORDER(^DIC(40.7,"C",$EXTRACT(SDCP,4,6),""))
+12 SET SDSC2=$PIECE($GET(^DIC(40.7,+SDSC2,0)),U)
SET SDSC2=$TRANSLATE(SDSC2,"/","-")
+13 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 SET SDZ=SDCP_" "_SDZ
IF SDREPORT=3
SET SDZ=$EXTRACT(SDZ,1,30)
+1 QUIT SDZ
