BSDWLL ; IHS/ITSC/LJF, WAR - WAITING LIST LT CODE ; [ 08/20/2004 11:59 AM ]
;;5.3;PIMS;**1001,1004,1007**;MAY 28, 2004
;IHS/ITSC/WAR 04/27/2004 PATCH 1001 ending date missing in loop
;IHS/OIT/LJF 07/20/2005 PATCH 1004 added comments, subtotals & total to list display
; added ability to print sort categories on separate pages
;cmi/anch/maw 01/15/2007 PATCH 1007 added screen of print by if defined item 1007.28
;
EN ;EP -- main entry point for BSDRM WAITING LIST
I $E(IOST,1,2)'="C-" D INIT,PRINT Q ;printing to paper
NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BSDRM WAITING LIST")
D CLEAR^VALM1
Q
;
HDR ; -- header code
NEW X
S VALMHDR(1)=$$SP(15)_$$CONF^BDGF
S X="Waiting List for "_$$GET1^DIQ(9009017.1,BSDWLN,.01)
S VALMHDR(2)=$$SP(70-$L(X)\2)_X
S X="Sorted by "_$$FIELD(9009017.11,$P(BSDSRT,U,2))
S X=X_"; for "_$P(BSDATE,U,2)
S VALMHDR(3)=$$SP(70-$L(X)\2)_X
Q
;
INIT ; -- init variables and list array
S VALMCNT=0 K ^TMP("BSDWL",$J),^TMP("BSDWL1",$J)
;
; search by date range and sort
NEW BSDSUB,BSDT,BSDN,BSDTPRI,BSDTPROV,BSDTREA,BSDTRES ;cmi/maw added variables for PATCH 1007 item 1007.28
S BSDSUB=$S(+BSDATE=".03":"AC",+BSDATE=".05":"AD",1:"AE")
S BSDT=BSDBD-.0001
F S BSDT=$O(^BSDWL(BSDSUB,BSDT)) Q:'BSDT!(BSDT'<(BSDED+.9999)) D
. S BSDN=0 F S BSDN=$O(^BSDWL(BSDSUB,BSDT,BSDWLN,BSDN)) Q:'BSDN D
.. ;cmi/anch/maw 1/15/2007 added below lines to filter on print by
.. I $G(BSDPRTYN),$G(BSDPRTB)=2 S BSDTPRI=$P($G(^BSDWL(BSDWLN,1,BSDN,0)),U,2) Q:'$D(BSDPRI(BSDTPRI))
.. I $G(BSDPRTYN),$G(BSDPRTB)=3 S BSDTPROV=$P($G(^BSDWL(BSDWLN,1,BSDN,0)),U,6) Q:'$D(BSDPROV(BSDTPROV))
.. I $G(BSDPRTYN),$G(BSDPRTB)=4 S BSDTREA=$P($G(^BSDWL(BSDWLN,1,BSDN,0)),U,9) Q:'$D(BSDREA(BSDTREA))
.. I $G(BSDPRTYN),$G(BSDPRTB)=5 S BSDTRES=$P($G(^BSDWL(BSDWLN,1,BSDN,0)),U,8) Q:'$D(BSDRES(BSDTRES))
.. ;cmi/anch/maw 1/15/2007 end of mods
.. I BSDREM=0,$P($G(^BSDWL(BSDWLN,1,BSDN,0)),U,7)]"" Q ;removed
.. S ^TMP("BSDWL1",$J,$$SORT(BSDWLN,BSDN),BSDT,BSDN)=""
;
; take sorted list and put into display array
NEW A,B,C,LINE,DFN,BSDCNT,FIRST,X
NEW BSDATA,IENS,FILE,SUBCNT,TOTAL ;IHS/OIT/LJF 7/21/2005 PATCH 1004 new variables
S FIRST=1
S A=0 F S A=$O(^TMP("BSDWL1",$J,A)) Q:A="" D
. ;
. ; display sort heading
. ;IHS/OIT/LJF 7/21/2005 PATCH 1004 add ability to print each sort on separate page
. ;I 'FIRST D SET("","",+$G(BSDCNT),.VALMCNT)
. I 'FIRST D
. . I $G(BSDPAG) D SET("NEW PAGE HERE","",+$G(BSDCNT),.VALMCNT) Q
. . D SET("","",+$G(BSDCNT),.VALMCNT)
. ;end of PATCH 1004 changes
. ;
. S FIRST=0
. S X=$S(+BSDSRT=1:$$FMTE^XLFDT(A),1:A) ;printable sort
. S LINE=$$SP(10)_"** "_$$FIELD(9009017.11,$P(BSDSRT,U,2))_": "_X_" **"
. D SET(LINE,"",+$G(BSDCNT),.VALMCNT)
. ;
. ; loop through date and ien
. S B=0 F S B=$O(^TMP("BSDWL1",$J,A,B)) Q:'B D
.. S C=0 F S C=$O(^TMP("BSDWL1",$J,A,B,C)) Q:'C D
... ;
... ; create display line
... S DFN=+^BSDWL(BSDWLN,1,C,0) ;patient ien
... S BSDCNT=$G(BSDCNT)+1,LINE=$J(BSDCNT,3)_". "_$$FMTE^XLFDT(B)
... S LINE=$$PAD(LINE,20)_$E($$GET1^DIQ(2,DFN,.01),1,20) ;patient name
... S LINE=$$PAD(LINE,42)_$J($$HRCN^BDGF2(DFN,+$G(DUZ(2))),6) ;hrcn
... S LINE=$$PAD(LINE,52)_$J($$GET1^DIQ(2,DFN,.033),3) ;age
... S LINE=$$PAD(LINE,60)_$$GET1^DIQ(2,DFN,.02,"I") ;sex
... ;S LINE=$$PAD(LINE,66)_$$GET1^DIQ(2,DFN,.131) ;home phone
... S LINE=$$PAD(LINE,64)_$$GET1^DIQ(2,DFN,.131) ;IHS/OIT/LJF 7/21/2005 PATCH 1004 improved spacing
... ;
... ; and set into display array
... D SET(LINE,C,BSDCNT,.VALMCNT)
... ;
... ;IHS/OIT/LJF 7/21/2005 PATCH 1004 added comments to listing & subcounts
... K BSDATA S IENS=C_","_BSDWLN_",",FILE=9009017.11
... D GETS^DIQ(FILE,IENS,"1","R","BSDATA")
... S X=0 F S X=$O(BSDATA(FILE,IENS,"COMMENTS",X)) Q:'X D
.... D SET($$SP(6)_BSDATA(FILE,IENS,"COMMENTS",X),C,BSDCNT,.VALMCNT)
... D SET(" ",C,BSDCNT,.VALMCNT)
... ;
... S SUBCNT(A)=$G(SUBCNT(A))+1,TOTAL=$G(TOTAL)+1 ;increment counts
. ; add subcount to display
. D SET("Subtotal for "_$S(+BSDSRT=1:$$FMTE^XLFDT(A),1:A)_": "_$G(SUBCNT(A)),C,BSDCNT,.VALMCNT)
;
I $G(TOTAL) D SET("Total on list: "_TOTAL,"",BSDCNT,.VALMCNT)
;end of PATCH 1004 additions
;
I VALMCNT=0 D SET($$SP(20)_"No Data Found","",0,.VALMCNT)
K ^TMP("BSDWL1",$J)
Q
;
SORT(CLN,IEN) ; set sort value for ^tmp
NEW X
S X=$$GET1^DIQ(9009017.11,IEN_","_CLN,$P(BSDSRT,U,2))
I +BSDSRT=1 S X=$$GET1^DIQ(9009017.11,IEN_","_CLN,$P(BSDSRT,U,2),"I")
Q $S(X="":"UNKNOWN",1:X)
;
SET(DATA,IEN,COUNT,NUM) ; puts data line into display array
S NUM=NUM+1 S:COUNT=0 COUNT=1
S ^TMP("BSDWL",$J,NUM,0)=DATA
S ^TMP("BSDWL",$J,"IDX",NUM,COUNT)=IEN
Q
;
PRINT ; print report to paper
U IO D HDG
NEW LINE
S LINE=0 F S LINE=$O(^TMP("BSDWL",$J,LINE)) Q:'LINE D
. I ^TMP("BSDWL",$J,LINE,0)="NEW PAGE HERE" D HDG Q ;IHS/OIT/LJF 7/21/2005 PATCH 1004
. I $Y>(IOSL-4) D HDG
. W !,^TMP("BSDWL",$J,LINE,0)
D ^%ZISC,EXIT
Q
;
HDG ; heading for paper report
D HDR W @IOF
NEW I F I=1:1 Q:'$D(VALMHDR(I)) W !,VALMHDR(I)
W !,$$REPEAT^XLFSTR("-",80)
;
;IHS/OIT/LJF 7/21/2005 PATCH 1004 improved column heading spacing
;W !?6,"Date Selected",?21,"Patient Name",?42,"Chart #",?53,"Age"
;W ?60,"Sex",?65,"Home Phone"
W !?5,"Date Selected",?20,"Patient Name",?42,"Chart #",?52,"Age"
W ?59,"Sex",?64,"Home Phone"
;
W !,$$REPEAT^XLFSTR("=",80)
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("BSDWL",$J)
Q
;
EXPND ; -- expand code
Q
;
GETONE ; -- select entry from listing
NEW X,Y,Z
D FULL^VALM1
S BSDN=""
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) Q
S X=$O(VALMY(0))
S Y=0 F S Y=$O(^TMP("BSDWL",$J,"IDX",Y)) Q:Y="" Q:BSDN]"" D
. S Z=$O(^TMP("BSDWL",$J,"IDX",Y,0))
. Q:^TMP("BSDWL",$J,"IDX",Y,Z)=""
. I Z=X S BSDN=^TMP("BSDWL",$J,"IDX",Y,Z)
Q
;
VIEW ;EP; called by BSDRM WAIT LIST VIEW protocol
NEW BSDN,DFN
D GETONE I BSDN="" D RETURN Q
S DFN=+$$GET1^DIQ(9009017.11,BSDN_","_BSDWLN,.01,"I") ;line added
D EN^BSDWLV,RETURN
Q
;
RETURN ; -- reset variables for return to lt
D TERM^VALM0 S VALMBCK="R" Q
;
FIELD(F,N) ; find field's name
Q $P($G(^DD(F,N,0)),U)
;
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)
BSDWLL ; IHS/ITSC/LJF, WAR - WAITING LIST LT CODE ; [ 08/20/2004 11:59 AM ]
+1 ;;5.3;PIMS;**1001,1004,1007**;MAY 28, 2004
+2 ;IHS/ITSC/WAR 04/27/2004 PATCH 1001 ending date missing in loop
+3 ;IHS/OIT/LJF 07/20/2005 PATCH 1004 added comments, subtotals & total to list display
+4 ; added ability to print sort categories on separate pages
+5 ;cmi/anch/maw 01/15/2007 PATCH 1007 added screen of print by if defined item 1007.28
+6 ;
EN ;EP -- main entry point for BSDRM WAITING LIST
+1 ;printing to paper
IF $EXTRACT(IOST,1,2)'="C-"
DO INIT
DO PRINT
QUIT
+2 NEW VALMCNT
DO TERM^VALM0
DO CLEAR^VALM1
+3 DO EN^VALM("BSDRM WAITING LIST")
+4 DO CLEAR^VALM1
+5 QUIT
+6 ;
HDR ; -- header code
+1 NEW X
+2 SET VALMHDR(1)=$$SP(15)_$$CONF^BDGF
+3 SET X="Waiting List for "_$$GET1^DIQ(9009017.1,BSDWLN,.01)
+4 SET VALMHDR(2)=$$SP(70-$LENGTH(X)\2)_X
+5 SET X="Sorted by "_$$FIELD(9009017.11,$PIECE(BSDSRT,U,2))
+6 SET X=X_"; for "_$PIECE(BSDATE,U,2)
+7 SET VALMHDR(3)=$$SP(70-$LENGTH(X)\2)_X
+8 QUIT
+9 ;
INIT ; -- init variables and list array
+1 SET VALMCNT=0
KILL ^TMP("BSDWL",$JOB),^TMP("BSDWL1",$JOB)
+2 ;
+3 ; search by date range and sort
+4 ;cmi/maw added variables for PATCH 1007 item 1007.28
NEW BSDSUB,BSDT,BSDN,BSDTPRI,BSDTPROV,BSDTREA,BSDTRES
+5 SET BSDSUB=$SELECT(+BSDATE=".03":"AC",+BSDATE=".05":"AD",1:"AE")
+6 SET BSDT=BSDBD-.0001
+7 FOR
SET BSDT=$ORDER(^BSDWL(BSDSUB,BSDT))
IF 'BSDT!(BSDT'<(BSDED+.9999))
QUIT
Begin DoDot:1
+8 SET BSDN=0
FOR
SET BSDN=$ORDER(^BSDWL(BSDSUB,BSDT,BSDWLN,BSDN))
IF 'BSDN
QUIT
Begin DoDot:2
+9 ;cmi/anch/maw 1/15/2007 added below lines to filter on print by
+10 IF $GET(BSDPRTYN)
IF $GET(BSDPRTB)=2
SET BSDTPRI=$PIECE($GET(^BSDWL(BSDWLN,1,BSDN,0)),U,2)
IF '$DATA(BSDPRI(BSDTPRI))
QUIT
+11 IF $GET(BSDPRTYN)
IF $GET(BSDPRTB)=3
SET BSDTPROV=$PIECE($GET(^BSDWL(BSDWLN,1,BSDN,0)),U,6)
IF '$DATA(BSDPROV(BSDTPROV))
QUIT
+12 IF $GET(BSDPRTYN)
IF $GET(BSDPRTB)=4
SET BSDTREA=$PIECE($GET(^BSDWL(BSDWLN,1,BSDN,0)),U,9)
IF '$DATA(BSDREA(BSDTREA))
QUIT
+13 IF $GET(BSDPRTYN)
IF $GET(BSDPRTB)=5
SET BSDTRES=$PIECE($GET(^BSDWL(BSDWLN,1,BSDN,0)),U,8)
IF '$DATA(BSDRES(BSDTRES))
QUIT
+14 ;cmi/anch/maw 1/15/2007 end of mods
+15 ;removed
IF BSDREM=0
IF $PIECE($GET(^BSDWL(BSDWLN,1,BSDN,0)),U,7)]""
QUIT
+16 SET ^TMP("BSDWL1",$JOB,$$SORT(BSDWLN,BSDN),BSDT,BSDN)=""
End DoDot:2
End DoDot:1
+17 ;
+18 ; take sorted list and put into display array
+19 NEW A,B,C,LINE,DFN,BSDCNT,FIRST,X
+20 ;IHS/OIT/LJF 7/21/2005 PATCH 1004 new variables
NEW BSDATA,IENS,FILE,SUBCNT,TOTAL
+21 SET FIRST=1
+22 SET A=0
FOR
SET A=$ORDER(^TMP("BSDWL1",$JOB,A))
IF A=""
QUIT
Begin DoDot:1
+23 ;
+24 ; display sort heading
+25 ;IHS/OIT/LJF 7/21/2005 PATCH 1004 add ability to print each sort on separate page
+26 ;I 'FIRST D SET("","",+$G(BSDCNT),.VALMCNT)
+27 IF 'FIRST
Begin DoDot:2
+28 IF $GET(BSDPAG)
DO SET("NEW PAGE HERE","",+$GET(BSDCNT),.VALMCNT)
QUIT
+29 DO SET("","",+$GET(BSDCNT),.VALMCNT)
End DoDot:2
+30 ;end of PATCH 1004 changes
+31 ;
+32 SET FIRST=0
+33 ;printable sort
SET X=$SELECT(+BSDSRT=1:$$FMTE^XLFDT(A),1:A)
+34 SET LINE=$$SP(10)_"** "_$$FIELD(9009017.11,$PIECE(BSDSRT,U,2))_": "_X_" **"
+35 DO SET(LINE,"",+$GET(BSDCNT),.VALMCNT)
+36 ;
+37 ; loop through date and ien
+38 SET B=0
FOR
SET B=$ORDER(^TMP("BSDWL1",$JOB,A,B))
IF 'B
QUIT
Begin DoDot:2
+39 SET C=0
FOR
SET C=$ORDER(^TMP("BSDWL1",$JOB,A,B,C))
IF 'C
QUIT
Begin DoDot:3
+40 ;
+41 ; create display line
+42 ;patient ien
SET DFN=+^BSDWL(BSDWLN,1,C,0)
+43 SET BSDCNT=$GET(BSDCNT)+1
SET LINE=$JUSTIFY(BSDCNT,3)_". "_$$FMTE^XLFDT(B)
+44 ;patient name
SET LINE=$$PAD(LINE,20)_$EXTRACT($$GET1^DIQ(2,DFN,.01),1,20)
+45 ;hrcn
SET LINE=$$PAD(LINE,42)_$JUSTIFY($$HRCN^BDGF2(DFN,+$GET(DUZ(2))),6)
+46 ;age
SET LINE=$$PAD(LINE,52)_$JUSTIFY($$GET1^DIQ(2,DFN,.033),3)
+47 ;sex
SET LINE=$$PAD(LINE,60)_$$GET1^DIQ(2,DFN,.02,"I")
+48 ;S LINE=$$PAD(LINE,66)_$$GET1^DIQ(2,DFN,.131) ;home phone
+49 ;IHS/OIT/LJF 7/21/2005 PATCH 1004 improved spacing
SET LINE=$$PAD(LINE,64)_$$GET1^DIQ(2,DFN,.131)
+50 ;
+51 ; and set into display array
+52 DO SET(LINE,C,BSDCNT,.VALMCNT)
+53 ;
+54 ;IHS/OIT/LJF 7/21/2005 PATCH 1004 added comments to listing & subcounts
+55 KILL BSDATA
SET IENS=C_","_BSDWLN_","
SET FILE=9009017.11
+56 DO GETS^DIQ(FILE,IENS,"1","R","BSDATA")
+57 SET X=0
FOR
SET X=$ORDER(BSDATA(FILE,IENS,"COMMENTS",X))
IF 'X
QUIT
Begin DoDot:4
+58 DO SET($$SP(6)_BSDATA(FILE,IENS,"COMMENTS",X),C,BSDCNT,.VALMCNT)
End DoDot:4
+59 DO SET(" ",C,BSDCNT,.VALMCNT)
+60 ;
+61 ;increment counts
SET SUBCNT(A)=$GET(SUBCNT(A))+1
SET TOTAL=$GET(TOTAL)+1
End DoDot:3
End DoDot:2
+62 ; add subcount to display
+63 DO SET("Subtotal for "_$SELECT(+BSDSRT=1:$$FMTE^XLFDT(A),1:A)_": "_$GET(SUBCNT(A)),C,BSDCNT,.VALMCNT)
End DoDot:1
+64 ;
+65 IF $GET(TOTAL)
DO SET("Total on list: "_TOTAL,"",BSDCNT,.VALMCNT)
+66 ;end of PATCH 1004 additions
+67 ;
+68 IF VALMCNT=0
DO SET($$SP(20)_"No Data Found","",0,.VALMCNT)
+69 KILL ^TMP("BSDWL1",$JOB)
+70 QUIT
+71 ;
SORT(CLN,IEN) ; set sort value for ^tmp
+1 NEW X
+2 SET X=$$GET1^DIQ(9009017.11,IEN_","_CLN,$PIECE(BSDSRT,U,2))
+3 IF +BSDSRT=1
SET X=$$GET1^DIQ(9009017.11,IEN_","_CLN,$PIECE(BSDSRT,U,2),"I")
+4 QUIT $SELECT(X="":"UNKNOWN",1:X)
+5 ;
SET(DATA,IEN,COUNT,NUM) ; puts data line into display array
+1 SET NUM=NUM+1
IF COUNT=0
SET COUNT=1
+2 SET ^TMP("BSDWL",$JOB,NUM,0)=DATA
+3 SET ^TMP("BSDWL",$JOB,"IDX",NUM,COUNT)=IEN
+4 QUIT
+5 ;
PRINT ; print report to paper
+1 USE IO
DO HDG
+2 NEW LINE
+3 SET LINE=0
FOR
SET LINE=$ORDER(^TMP("BSDWL",$JOB,LINE))
IF 'LINE
QUIT
Begin DoDot:1
+4 ;IHS/OIT/LJF 7/21/2005 PATCH 1004
IF ^TMP("BSDWL",$JOB,LINE,0)="NEW PAGE HERE"
DO HDG
QUIT
+5 IF $Y>(IOSL-4)
DO HDG
+6 WRITE !,^TMP("BSDWL",$JOB,LINE,0)
End DoDot:1
+7 DO ^%ZISC
DO EXIT
+8 QUIT
+9 ;
HDG ; heading for paper report
+1 DO HDR
WRITE @IOF
+2 NEW I
FOR I=1:1
IF '$DATA(VALMHDR(I))
QUIT
WRITE !,VALMHDR(I)
+3 WRITE !,$$REPEAT^XLFSTR("-",80)
+4 ;
+5 ;IHS/OIT/LJF 7/21/2005 PATCH 1004 improved column heading spacing
+6 ;W !?6,"Date Selected",?21,"Patient Name",?42,"Chart #",?53,"Age"
+7 ;W ?60,"Sex",?65,"Home Phone"
+8 WRITE !?5,"Date Selected",?20,"Patient Name",?42,"Chart #",?52,"Age"
+9 WRITE ?59,"Sex",?64,"Home Phone"
+10 ;
+11 WRITE !,$$REPEAT^XLFSTR("=",80)
+12 QUIT
+13 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("BSDWL",$JOB)
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
GETONE ; -- select entry from listing
+1 NEW X,Y,Z
+2 DO FULL^VALM1
+3 SET BSDN=""
+4 DO EN^VALM2(XQORNOD(0),"OS")
+5 IF '$DATA(VALMY)
QUIT
+6 SET X=$ORDER(VALMY(0))
+7 SET Y=0
FOR
SET Y=$ORDER(^TMP("BSDWL",$JOB,"IDX",Y))
IF Y=""
QUIT
IF BSDN]""
QUIT
Begin DoDot:1
+8 SET Z=$ORDER(^TMP("BSDWL",$JOB,"IDX",Y,0))
+9 IF ^TMP("BSDWL",$JOB,"IDX",Y,Z)=""
QUIT
+10 IF Z=X
SET BSDN=^TMP("BSDWL",$JOB,"IDX",Y,Z)
End DoDot:1
+11 QUIT
+12 ;
VIEW ;EP; called by BSDRM WAIT LIST VIEW protocol
+1 NEW BSDN,DFN
+2 DO GETONE
IF BSDN=""
DO RETURN
QUIT
+3 ;line added
SET DFN=+$$GET1^DIQ(9009017.11,BSDN_","_BSDWLN,.01,"I")
+4 DO EN^BSDWLV
DO RETURN
+5 QUIT
+6 ;
RETURN ; -- reset variables for return to lt
+1 DO TERM^VALM0
SET VALMBCK="R"
QUIT
+2 ;
FIELD(F,N) ; find field's name
+1 QUIT $PIECE($GET(^DD(F,N,0)),U)
+2 ;
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)
