BSDOAS ; cmi/anch/maw - Original Clinic Availability Setup ; [ 01/02/2004 10:48 AM ]
;;5.3;PIMS;**1007**;FEB 27, 2007
;
;cmi/anch/maw 2/23/2007 added option for PATCH 1007 item 1007.32
;
ASK ; ask clinic and set variables
S BSDD=$$READ^BDGF("D^::EX","Select Date") Q:'BSDD
;
; get clinic arrays based on subtotal category
D CLINIC^BSDU(2) Q:$D(BSDQ)
;
S Y=$$BROWSE^BDGF Q:"PB"'[Y I Y="B" D EN Q ;browse in list mgr mode
D ZIS^BDGF("PQ","START^BSDOAS","ORIGINAL AVAILABILITY SETUP","BSDD;VAUTC*;VAUTD*")
Q
;
START ;EP; -- re-entry for printing to paper
D INIT,PRINT Q
;
EN ;EP; -- main entry point for month-at-a-glance list templates
NEW VALMCNT,DIR,DIC
;BSDANS = answer to date to start display
S VALMCC=1 ;1=screen mode, 0=scrolling mode
D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BSDAM ORIGINAL CLINIC DISPLAY")
Q
;
HDR ;EP; -- header code
S VALMHDR(1)=$$SP(23)_"Original Availability Setup Display"
S VALMHDR(2)=$$SP(30)_"For date: "_$$FMTE^XLFDT(BSDD)
Q
;
INIT ;EP; -- init variables and list array
S VALMCNT=0 K ^TMP("BSDM",$J),^TMP("BSD",$J)
NEW BSDAR S BSDAR=$S(VAUTC:"^SC",1:"VAUTC")
S BSDIOM=150,BSDTOT=BSDIOM-15 ;used in place of 80 & 65 below
;
; -- loop by clinic
NEW CLN,NAME,BSDS,BSDSCD,BSDPC,BSDH,BSDCS
S CLN=0 F S CLN=$O(@BSDAR@(CLN)) Q:'CLN D
. Q:'$$GET1^DIQ(44,CLN,3.5,"I") ;No Div entered for this clinic
. I $D(VAUTD) Q:(VAUTD'=1&('$D(VAUTD($$GET1^DIQ(44,CLN,3.5,"I"))))) ;this Div notd
. S NAME=$$GET1^DIQ(44,CLN,.01) ;set clinic's name
. I $D(^SC("AIHSPC",CLN)) D Q ;quit if principal clinic
.. D SET("PRINCIPAL CLINIC: "_NAME_" - "_$$FMTE^XLFDT(BSDD),.VALMCNT)
. S BSDSCD=$$GET1^DIQ(44,CLN,8) ;clinic code
. S BSDPC=$$GET1^DIQ(44,CLN,1916) ;principal clinic
. S BSDCS=$P($G(^SC(CLN,"SL")),U,3)
. N BSDPTR
. I $D(^SC(CLN,"OST",BSDD,1)) D
.. S BSDPTR=$G(^SC(CLN,"OST",BSDD,1))
. I '$D(^SC(CLN,"OST",BSDD,1)) D
.. S BSDPTR=$$UP^XLFSTR($E($$DOW(BSDD,""),1,2))_" "_$E(BSDD,6,7)_" "_$G(^SC(CLN,$$DOWN(BSDD),9999999,1))
. D SET(NAME_" - "_$$FMTE^XLFDT(BSDD),.VALMCNT)
. S LINE=" TIME " F Y=BSDCS:1:BSDTOT\16+BSDCS S LINE=LINE_$E("|"_$S('Y:0,1:(Y-1#12+1))_" ",1,8)
. D SET(LINE,.VALMCNT)
. S LINE=" DATE |"
. D SET(LINE,.VALMCNT)
. D SET(BSDPTR,.VALMCNT)
. D SET("",.VALMCNT)
;
; add legend to display to explain 1s, 0s, As, Bs, *s, etc.
S VALMCNT=VALMCNT+1,^TMP("BSDM",$J,VALMCNT,0)="" ;extra line
NEW BSDX D LEGEND^BSDU(.BSDX)
S X=0 F S X=$O(BSDX(X)) Q:'X D
. D SET(BSDX(X),.VALMCNT)
;
K ^TMP("BSD",$J)
Q
;
WMH ;Write month heading lines
W !!," TIME",?7 F Y=BSDCS:1:BSDTOT\16+BSDCS W $E("|"_$S('BSDD:0,1:(BSDD-1#12+1))_" ",1,8)
W !," DATE",?7,"|"
F Y=1:1:BSDTOT\(8) W $J("|",8)
S BSDCNT=0 ;reset count after printing time headings
Q
;
SET(LINE,NUM) ; -- sets display line into array
S NUM=NUM+1
S ^TMP("BSDM",$J,NUM,0)=LINE
Q
;
HELP ;EP; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ;EP; -- exit code
D CLEAR^VALM1
K ^TMP("BSDM",$J)
S VALMNOFF=1 ;suppress form feed before next question
Q
;
EXPND ;EP; -- expand code
Q
;
PAUSE ; -- end of action pause
D PAUSE^BDGF Q
;
DT W $$FMTE^XLFDT(Y) Q
;
DOW(X,F) Q $$DOW^XLFDT(X,F)
;
DOWN(DOW) ;-- get the node to display for Day of Week
S DOW=$$DOW^XLFDT(DOW,1)
Q "T"_DOW
;
HELP1 ;EP; help for print individual dates question
D MSG^BDGF("The report will display the Original,",2,0)
D MSG^BDGF("Availability Setup based on the date.",1,0)
D MSG^BDGF("passed in.",1,1)
Q
;
PRINT ; print report to paper
U IO D HDG
NEW X S X=0 F S X=$O(^TMP("BSDM",$J,X)) Q:'X D
. I $Y>(IOSL-4) D HDG
. W !,^TMP("BSDM",$J,X,0)
D ^%ZISC,EXIT
Q
;
HDG ; heading for paper report
D HDR W @IOF,?30,"Original Availability Setup"
F I=1:1 Q:'$D(VALMHDR(I)) W !,VALMHDR(I)
W !,$$REPEAT^XLFSTR("-",80)
W !,"Clinic Pattern"
W !,$$REPEAT^XLFSTR("=",80)
Q
;
PAD(D,L) ;EP -- SUBRTN to pad length of data
; -- D=data L=length
Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
;
SP(N) ; -- SUBRTN to pad N number of spaces
Q $$PAD(" ",N)
;
END D KVAR^VADPT K SDAPTYP,SDSC,%,%DT,ASKC,COV,DA,DIC,DIE,DP,DR
K HEY,HSI,HY,J,SB,SC,SDDIF,SDJ,SDLN,SD17,SDMAX,SDU,SDYC,SI,SL
K SSC,STARTDAY,STR,SDZPR,WY,X,XX,Y,S,SD,SDAP16,SDEDT,SDTY,SM
K SS,ST,ARG,CCX,CCXN,HX,I,PXR,SDINA,SDW,COLLAT,SDDIS,SDMM,SDMLT1
K SDAV,SDHX,SDSOH,SDT
Q
BSDOAS ; cmi/anch/maw - Original Clinic Availability Setup ; [ 01/02/2004 10:48 AM ]
+1 ;;5.3;PIMS;**1007**;FEB 27, 2007
+2 ;
+3 ;cmi/anch/maw 2/23/2007 added option for PATCH 1007 item 1007.32
+4 ;
ASK ; ask clinic and set variables
+1 SET BSDD=$$READ^BDGF("D^::EX","Select Date")
IF 'BSDD
QUIT
+2 ;
+3 ; get clinic arrays based on subtotal category
+4 DO CLINIC^BSDU(2)
IF $DATA(BSDQ)
QUIT
+5 ;
+6 ;browse in list mgr mode
SET Y=$$BROWSE^BDGF
IF "PB"'[Y
QUIT
IF Y="B"
DO EN
QUIT
+7 DO ZIS^BDGF("PQ","START^BSDOAS","ORIGINAL AVAILABILITY SETUP","BSDD;VAUTC*;VAUTD*")
+8 QUIT
+9 ;
START ;EP; -- re-entry for printing to paper
+1 DO INIT
DO PRINT
QUIT
+2 ;
EN ;EP; -- main entry point for month-at-a-glance list templates
+1 NEW VALMCNT,DIR,DIC
+2 ;BSDANS = answer to date to start display
+3 ;1=screen mode, 0=scrolling mode
SET VALMCC=1
+4 DO TERM^VALM0
DO CLEAR^VALM1
+5 DO EN^VALM("BSDAM ORIGINAL CLINIC DISPLAY")
+6 QUIT
+7 ;
HDR ;EP; -- header code
+1 SET VALMHDR(1)=$$SP(23)_"Original Availability Setup Display"
+2 SET VALMHDR(2)=$$SP(30)_"For date: "_$$FMTE^XLFDT(BSDD)
+3 QUIT
+4 ;
INIT ;EP; -- init variables and list array
+1 SET VALMCNT=0
KILL ^TMP("BSDM",$JOB),^TMP("BSD",$JOB)
+2 NEW BSDAR
SET BSDAR=$SELECT(VAUTC:"^SC",1:"VAUTC")
+3 ;used in place of 80 & 65 below
SET BSDIOM=150
SET BSDTOT=BSDIOM-15
+4 ;
+5 ; -- loop by clinic
+6 NEW CLN,NAME,BSDS,BSDSCD,BSDPC,BSDH,BSDCS
+7 SET CLN=0
FOR
SET CLN=$ORDER(@BSDAR@(CLN))
IF 'CLN
QUIT
Begin DoDot:1
+8 ;No Div entered for this clinic
IF '$$GET1^DIQ(44,CLN,3.5,"I")
QUIT
+9 ;this Div notd
IF $DATA(VAUTD)
IF (VAUTD'=1&('$DATA(VAUTD($$GET1^DIQ(44,CLN,3.5,"I")))))
QUIT
+10 ;set clinic's name
SET NAME=$$GET1^DIQ(44,CLN,.01)
+11 ;quit if principal clinic
IF $DATA(^SC("AIHSPC",CLN))
Begin DoDot:2
+12 DO SET("PRINCIPAL CLINIC: "_NAME_" - "_$$FMTE^XLFDT(BSDD),.VALMCNT)
End DoDot:2
QUIT
+13 ;clinic code
SET BSDSCD=$$GET1^DIQ(44,CLN,8)
+14 ;principal clinic
SET BSDPC=$$GET1^DIQ(44,CLN,1916)
+15 SET BSDCS=$PIECE($GET(^SC(CLN,"SL")),U,3)
+16 NEW BSDPTR
+17 IF $DATA(^SC(CLN,"OST",BSDD,1))
Begin DoDot:2
+18 SET BSDPTR=$GET(^SC(CLN,"OST",BSDD,1))
End DoDot:2
+19 IF '$DATA(^SC(CLN,"OST",BSDD,1))
Begin DoDot:2
+20 SET BSDPTR=$$UP^XLFSTR($EXTRACT($$DOW(BSDD,""),1,2))_" "_$EXTRACT(BSDD,6,7)_" "_$GET(^SC(CLN,$$DOWN(BSDD),9999999,1))
End DoDot:2
+21 DO SET(NAME_" - "_$$FMTE^XLFDT(BSDD),.VALMCNT)
+22 SET LINE=" TIME "
FOR Y=BSDCS:1:BSDTOT\16+BSDCS
SET LINE=LINE_$EXTRACT("|"_$SELECT('Y:0,1:(Y-1#12+1))_" ",1,8)
+23 DO SET(LINE,.VALMCNT)
+24 SET LINE=" DATE |"
+25 DO SET(LINE,.VALMCNT)
+26 DO SET(BSDPTR,.VALMCNT)
+27 DO SET("",.VALMCNT)
End DoDot:1
+28 ;
+29 ; add legend to display to explain 1s, 0s, As, Bs, *s, etc.
+30 ;extra line
SET VALMCNT=VALMCNT+1
SET ^TMP("BSDM",$JOB,VALMCNT,0)=""
+31 NEW BSDX
DO LEGEND^BSDU(.BSDX)
+32 SET X=0
FOR
SET X=$ORDER(BSDX(X))
IF 'X
QUIT
Begin DoDot:1
+33 DO SET(BSDX(X),.VALMCNT)
End DoDot:1
+34 ;
+35 KILL ^TMP("BSD",$JOB)
+36 QUIT
+37 ;
WMH ;Write month heading lines
+1 WRITE !!," TIME",?7
FOR Y=BSDCS:1:BSDTOT\16+BSDCS
WRITE $EXTRACT("|"_$SELECT('BSDD:0,1:(BSDD-1#12+1))_" ",1,8)
+2 WRITE !," DATE",?7,"|"
+3 FOR Y=1:1:BSDTOT\(8)
WRITE $JUSTIFY("|",8)
+4 ;reset count after printing time headings
SET BSDCNT=0
+5 QUIT
+6 ;
SET(LINE,NUM) ; -- sets display line into array
+1 SET NUM=NUM+1
+2 SET ^TMP("BSDM",$JOB,NUM,0)=LINE
+3 QUIT
+4 ;
HELP ;EP; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ;EP; -- exit code
+1 DO CLEAR^VALM1
+2 KILL ^TMP("BSDM",$JOB)
+3 ;suppress form feed before next question
SET VALMNOFF=1
+4 QUIT
+5 ;
EXPND ;EP; -- expand code
+1 QUIT
+2 ;
PAUSE ; -- end of action pause
+1 DO PAUSE^BDGF
QUIT
+2 ;
DT WRITE $$FMTE^XLFDT(Y)
QUIT
+1 ;
DOW(X,F) QUIT $$DOW^XLFDT(X,F)
+1 ;
DOWN(DOW) ;-- get the node to display for Day of Week
+1 SET DOW=$$DOW^XLFDT(DOW,1)
+2 QUIT "T"_DOW
+3 ;
HELP1 ;EP; help for print individual dates question
+1 DO MSG^BDGF("The report will display the Original,",2,0)
+2 DO MSG^BDGF("Availability Setup based on the date.",1,0)
+3 DO MSG^BDGF("passed in.",1,1)
+4 QUIT
+5 ;
PRINT ; print report to paper
+1 USE IO
DO HDG
+2 NEW X
SET X=0
FOR
SET X=$ORDER(^TMP("BSDM",$JOB,X))
IF 'X
QUIT
Begin DoDot:1
+3 IF $Y>(IOSL-4)
DO HDG
+4 WRITE !,^TMP("BSDM",$JOB,X,0)
End DoDot:1
+5 DO ^%ZISC
DO EXIT
+6 QUIT
+7 ;
HDG ; heading for paper report
+1 DO HDR
WRITE @IOF,?30,"Original Availability Setup"
+2 FOR I=1:1
IF '$DATA(VALMHDR(I))
QUIT
WRITE !,VALMHDR(I)
+3 WRITE !,$$REPEAT^XLFSTR("-",80)
+4 WRITE !,"Clinic Pattern"
+5 WRITE !,$$REPEAT^XLFSTR("=",80)
+6 QUIT
+7 ;
PAD(D,L) ;EP -- SUBRTN to pad length of data
+1 ; -- D=data L=length
+2 QUIT $EXTRACT(D_$$REPEAT^XLFSTR(" ",L),1,L)
+3 ;
SP(N) ; -- SUBRTN to pad N number of spaces
+1 QUIT $$PAD(" ",N)
+2 ;
END DO KVAR^VADPT
KILL SDAPTYP,SDSC,%,%DT,ASKC,COV,DA,DIC,DIE,DP,DR
+1 KILL HEY,HSI,HY,J,SB,SC,SDDIF,SDJ,SDLN,SD17,SDMAX,SDU,SDYC,SI,SL
+2 KILL SSC,STARTDAY,STR,SDZPR,WY,X,XX,Y,S,SD,SDAP16,SDEDT,SDTY,SM
+3 KILL SS,ST,ARG,CCX,CCXN,HX,I,PXR,SDINA,SDW,COLLAT,SDDIS,SDMM,SDMLT1
+4 KILL SDAV,SDHX,SDSOH,SDT
+5 QUIT
