- BDGIPL9 ; IHS/ANMC/LJF - CURR INPTS ON SI/DNR LIST ;
- ;;5.3;PIMS;**1007**;FEB 27, 2007
- ;
- ;
- ;cmi/anch/maw 2/22/2007 added code in PRINT to not close device if multiple copies PATCH 1007 item 1007.39
- ;
- ;
- I $E(IOST,1,2)="P-" D INIT,PRINT Q
- ;
- EN ; -- main entry point for BDG IPL SI/DNR
- ; assumes BDGSRT and BDGSRT2 are set
- NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
- D EN^VALM("BDG IPL BY SI/DNR")
- D CLEAR^VALM1
- Q
- ;
- HDR ; -- header code
- NEW X
- S VALMHDR(1)=$$SP(12)_"** "_$$CONF^BDGF_" **"
- S X=$S(BDGSRT="A":"For ALL Ward Locations",1:$P(BDGSRT,U,2))
- S VALMHDR(2)=$$SP(75-$L(X)\2)_X
- Q
- ;
- INIT ; -- init variables and list array
- NEW WD,DFN,BDGCNT,NAME
- K ^TMP("BDGIPL",$J),^TMP("BDGIPL1",$J)
- S VALMCNT=0,BDGCNT=1
- ;
- ; if only one ward chosen
- I BDGSRT D
- . S WD=$P(BDGSRT,U,2),DFN=0 F S DFN=$O(^DPT("CN",WD,DFN)) Q:'DFN D
- .. ;
- .. ; quit if patient not on SI or DNR lists
- .. S X=$P($G(^DPT(DFN,"DAC")),U) Q:X=""
- .. ;
- .. I (X'="D") S ^TMP("BDGIPL1",$J,"S",WD,$$GET1^DIQ(2,DFN,.01),DFN)=""
- .. I (X'="S") S ^TMP("BDGIPL1",$J,"D",WD,$$GET1^DIQ(2,DFN,.01),DFN)=""
- ;
- ; OR for all wards, find current inpatients & sort by ward then name
- E S WD=0 F S WD=$O(^DPT("CN",WD)) Q:WD="" D
- . S DFN=0 F S DFN=$O(^DPT("CN",WD,DFN)) Q:'DFN D
- .. ;
- .. ; quit if patient not on SI or DNR lists
- .. S X=$P($G(^DPT(DFN,"DAC")),U) Q:X=""
- .. ;
- .. I (X'="D") S ^TMP("BDGIPL1",$J,"S",WD,$$GET1^DIQ(2,DFN,.01),DFN)=""
- .. I (X'="S") S ^TMP("BDGIPL1",$J,"D",WD,$$GET1^DIQ(2,DFN,.01),DFN)=""
- ;
- ; pull sorted list and create display array
- F BDGI="S","D" D
- . ;
- . ; display subheading
- . I BDGSRT2=1 D ;include DNR patients on list
- .. S X=$S(BDGI="S":"Seriously Ill List",1:"Do Not Resuscitate List")
- .. D SET($G(IORVON)_X_$G(IORVOFF),.VALMCNT,BDGCNT,"")
- . ;
- . S WD=0 F S WD=$O(^TMP("BDGIPL1",$J,BDGI,WD)) Q:WD="" D
- .. ;
- .. I BDGSRT="A" D ;display ward subheading
- ... D SET($$SP(2)_$G(IOUON)_"WARD: "_WD_$G(IOUOFF),.VALMCNT,BDGCNT,"")
- .. ;
- .. S NAME=0 F S NAME=$O(^TMP("BDGIPL1",$J,BDGI,WD,NAME)) Q:NAME="" D
- ... S DFN=0 F S DFN=$O(^TMP("BDGIPL1",$J,BDGI,WD,NAME,DFN)) Q:'DFN D
- .... D LINE
- . ;
- . D SET("",.VALMCNT,BDGCNT-1,"")
- ;
- K ^TMP("BDGIPL1",$J)
- Q
- ;
- LINE ; set up dislay line for patient
- NEW LINE
- S LINE=$S($E(IOST,1,2)="P-":$$SP(5),1:$J(BDGCNT,3)_") ")
- S LINE=$$PAD(LINE,5)_$E($$GET1^DIQ(2,DFN,.01),1,16) ;name
- S LINE=$$PAD(LINE,23)_$J($$HRCN^BDGF2(DFN,DUZ(2)),6)
- S LINE=$$PAD(LINE,31)_$$AGE(DFN) ;age
- S LINE=$$PAD(LINE,39)_$G(^DPT(DFN,.101)) ;room
- S LINE=$$PAD(LINE,47)_$$GET1^DIQ(45.7,+$G(^DPT(DFN,.103)),99) ;srv
- S LINE=$$PAD(LINE,53)_$$CURPRV^BDGF1(DFN,15) ;prov
- ; put date added to SI/DNR list in last column
- S LINE=$$PAD(LINE,69)_$$NUMDATE^BDGF($P(^DPT(DFN,"DAC"),U,2))
- D SET(LINE,.VALMCNT,BDGCNT,DFN)
- ;
- ; increment counter
- S BDGCNT=BDGCNT+1
- Q
- ;
- SET(LINE,NUM,COUNT,IEN) ; put display line into array
- D SET^BDGIPL1(LINE,.NUM,COUNT,IEN)
- Q
- ;
- PRINT ; print report to paper
- NEW BDGX,BDGLN,BDGPG
- U IO D INIT^BDGF,HDG
- ;
- ; loop thru display array
- S BDGX=0 F S BDGX=$O(^TMP("BDGIPL",$J,BDGX)) Q:'BDGX D
- . I $Y>(IOSL-4) D HDG
- . W !,^TMP("BDGIPL",$J,BDGX,0)
- I '$G(BDGCOP) D ^%ZISC ;cmi/anch/maw 2/22/2007 added for no close of device if multiple copies PATCH 1007 item 1007.39
- D PRTKL^BDGF,EXIT
- ;D ^%ZISC,PRTKL^BDGF,EXIT cmi/anch/maw 2/22/2007 orig line
- Q ;cmi/anch/maw 7/25/2007 quit missing patch 1007
- ;
- HDG ; heading for paper report
- S BDGPG=$G(BDGPG)+1 I BDGPG>1 W @IOF
- W !,BDGUSR,?13,"***",$$CONF^BDGF,"***"
- NEW X S X="Seriously Ill"_$S(BDGSRT2=1:"/DNR ",1:"")_" List"
- W !,BDGDATE,?(80-$L(X)\2),X,?71,"Page: ",BDGPG
- S X=$S(BDGSRT="A":"For ALL Ward Locations",1:$P(BDGSRT,U,2))
- W !,BDGTIME,?(80-$L(X)\2),X
- W !,$$REPEAT^XLFSTR("-",80)
- W !?5,"Patient",?23,"Chart #",?31,"Age",?39,"Room",?47,"Srv"
- W ?53,"Provider",?69,"Added"
- W !,$$REPEAT^XLFSTR("=",80)
- Q
- ;
- HELP ; -- help code
- S X="?" D DISP^XQORM1 W !!
- Q
- ;
- EXIT ; -- exit code
- K ^TMP("BDGIPL",$J)
- ;K BDGSRT cmi/anch/maw 7/25/2007 is needed for multiple copies patch 1007
- Q
- ;
- EXPND ; -- expand code
- 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)
- ;
- AGE(P) ; return formatted age
- NEW X S X=$$GET1^DIQ(9000001,DFN,1102.98)
- S X=$J($P(X," "),3)_" "_$E($P(X," ",2),1,2)
- Q X
- BDGIPL9 ; IHS/ANMC/LJF - CURR INPTS ON SI/DNR LIST ;
- +1 ;;5.3;PIMS;**1007**;FEB 27, 2007
- +2 ;
- +3 ;
- +4 ;cmi/anch/maw 2/22/2007 added code in PRINT to not close device if multiple copies PATCH 1007 item 1007.39
- +5 ;
- +6 ;
- +7 IF $EXTRACT(IOST,1,2)="P-"
- DO INIT
- DO PRINT
- QUIT
- +8 ;
- EN ; -- main entry point for BDG IPL SI/DNR
- +1 ; assumes BDGSRT and BDGSRT2 are set
- +2 NEW VALMCNT
- DO TERM^VALM0
- DO CLEAR^VALM1
- +3 DO EN^VALM("BDG IPL BY SI/DNR")
- +4 DO CLEAR^VALM1
- +5 QUIT
- +6 ;
- HDR ; -- header code
- +1 NEW X
- +2 SET VALMHDR(1)=$$SP(12)_"** "_$$CONF^BDGF_" **"
- +3 SET X=$SELECT(BDGSRT="A":"For ALL Ward Locations",1:$PIECE(BDGSRT,U,2))
- +4 SET VALMHDR(2)=$$SP(75-$LENGTH(X)\2)_X
- +5 QUIT
- +6 ;
- INIT ; -- init variables and list array
- +1 NEW WD,DFN,BDGCNT,NAME
- +2 KILL ^TMP("BDGIPL",$JOB),^TMP("BDGIPL1",$JOB)
- +3 SET VALMCNT=0
- SET BDGCNT=1
- +4 ;
- +5 ; if only one ward chosen
- +6 IF BDGSRT
- Begin DoDot:1
- +7 SET WD=$PIECE(BDGSRT,U,2)
- SET DFN=0
- FOR
- SET DFN=$ORDER(^DPT("CN",WD,DFN))
- IF 'DFN
- QUIT
- Begin DoDot:2
- +8 ;
- +9 ; quit if patient not on SI or DNR lists
- +10 SET X=$PIECE($GET(^DPT(DFN,"DAC")),U)
- IF X=""
- QUIT
- +11 ;
- +12 IF (X'="D")
- SET ^TMP("BDGIPL1",$JOB,"S",WD,$$GET1^DIQ(2,DFN,.01),DFN)=""
- +13 IF (X'="S")
- SET ^TMP("BDGIPL1",$JOB,"D",WD,$$GET1^DIQ(2,DFN,.01),DFN)=""
- End DoDot:2
- End DoDot:1
- +14 ;
- +15 ; OR for all wards, find current inpatients & sort by ward then name
- +16 IF '$TEST
- SET WD=0
- FOR
- SET WD=$ORDER(^DPT("CN",WD))
- IF WD=""
- QUIT
- Begin DoDot:1
- +17 SET DFN=0
- FOR
- SET DFN=$ORDER(^DPT("CN",WD,DFN))
- IF 'DFN
- QUIT
- Begin DoDot:2
- +18 ;
- +19 ; quit if patient not on SI or DNR lists
- +20 SET X=$PIECE($GET(^DPT(DFN,"DAC")),U)
- IF X=""
- QUIT
- +21 ;
- +22 IF (X'="D")
- SET ^TMP("BDGIPL1",$JOB,"S",WD,$$GET1^DIQ(2,DFN,.01),DFN)=""
- +23 IF (X'="S")
- SET ^TMP("BDGIPL1",$JOB,"D",WD,$$GET1^DIQ(2,DFN,.01),DFN)=""
- End DoDot:2
- End DoDot:1
- +24 ;
- +25 ; pull sorted list and create display array
- +26 FOR BDGI="S","D"
- Begin DoDot:1
- +27 ;
- +28 ; display subheading
- +29 ;include DNR patients on list
- IF BDGSRT2=1
- Begin DoDot:2
- +30 SET X=$SELECT(BDGI="S":"Seriously Ill List",1:"Do Not Resuscitate List")
- +31 DO SET($GET(IORVON)_X_$GET(IORVOFF),.VALMCNT,BDGCNT,"")
- End DoDot:2
- +32 ;
- +33 SET WD=0
- FOR
- SET WD=$ORDER(^TMP("BDGIPL1",$JOB,BDGI,WD))
- IF WD=""
- QUIT
- Begin DoDot:2
- +34 ;
- +35 ;display ward subheading
- IF BDGSRT="A"
- Begin DoDot:3
- +36 DO SET($$SP(2)_$GET(IOUON)_"WARD: "_WD_$GET(IOUOFF),.VALMCNT,BDGCNT,"")
- End DoDot:3
- +37 ;
- +38 SET NAME=0
- FOR
- SET NAME=$ORDER(^TMP("BDGIPL1",$JOB,BDGI,WD,NAME))
- IF NAME=""
- QUIT
- Begin DoDot:3
- +39 SET DFN=0
- FOR
- SET DFN=$ORDER(^TMP("BDGIPL1",$JOB,BDGI,WD,NAME,DFN))
- IF 'DFN
- QUIT
- Begin DoDot:4
- +40 DO LINE
- End DoDot:4
- End DoDot:3
- End DoDot:2
- +41 ;
- +42 DO SET("",.VALMCNT,BDGCNT-1,"")
- End DoDot:1
- +43 ;
- +44 KILL ^TMP("BDGIPL1",$JOB)
- +45 QUIT
- +46 ;
- LINE ; set up dislay line for patient
- +1 NEW LINE
- +2 SET LINE=$SELECT($EXTRACT(IOST,1,2)="P-":$$SP(5),1:$JUSTIFY(BDGCNT,3)_") ")
- +3 ;name
- SET LINE=$$PAD(LINE,5)_$EXTRACT($$GET1^DIQ(2,DFN,.01),1,16)
- +4 SET LINE=$$PAD(LINE,23)_$JUSTIFY($$HRCN^BDGF2(DFN,DUZ(2)),6)
- +5 ;age
- SET LINE=$$PAD(LINE,31)_$$AGE(DFN)
- +6 ;room
- SET LINE=$$PAD(LINE,39)_$GET(^DPT(DFN,.101))
- +7 ;srv
- SET LINE=$$PAD(LINE,47)_$$GET1^DIQ(45.7,+$GET(^DPT(DFN,.103)),99)
- +8 ;prov
- SET LINE=$$PAD(LINE,53)_$$CURPRV^BDGF1(DFN,15)
- +9 ; put date added to SI/DNR list in last column
- +10 SET LINE=$$PAD(LINE,69)_$$NUMDATE^BDGF($PIECE(^DPT(DFN,"DAC"),U,2))
- +11 DO SET(LINE,.VALMCNT,BDGCNT,DFN)
- +12 ;
- +13 ; increment counter
- +14 SET BDGCNT=BDGCNT+1
- +15 QUIT
- +16 ;
- SET(LINE,NUM,COUNT,IEN) ; put display line into array
- +1 DO SET^BDGIPL1(LINE,.NUM,COUNT,IEN)
- +2 QUIT
- +3 ;
- PRINT ; print report to paper
- +1 NEW BDGX,BDGLN,BDGPG
- +2 USE IO
- DO INIT^BDGF
- DO HDG
- +3 ;
- +4 ; loop thru display array
- +5 SET BDGX=0
- FOR
- SET BDGX=$ORDER(^TMP("BDGIPL",$JOB,BDGX))
- IF 'BDGX
- QUIT
- Begin DoDot:1
- +6 IF $Y>(IOSL-4)
- DO HDG
- +7 WRITE !,^TMP("BDGIPL",$JOB,BDGX,0)
- End DoDot:1
- +8 ;cmi/anch/maw 2/22/2007 added for no close of device if multiple copies PATCH 1007 item 1007.39
- IF '$GET(BDGCOP)
- DO ^%ZISC
- +9 DO PRTKL^BDGF
- DO EXIT
- +10 ;D ^%ZISC,PRTKL^BDGF,EXIT cmi/anch/maw 2/22/2007 orig line
- +11 ;cmi/anch/maw 7/25/2007 quit missing patch 1007
- QUIT
- +12 ;
- HDG ; heading for paper report
- +1 SET BDGPG=$GET(BDGPG)+1
- IF BDGPG>1
- WRITE @IOF
- +2 WRITE !,BDGUSR,?13,"***",$$CONF^BDGF,"***"
- +3 NEW X
- SET X="Seriously Ill"_$SELECT(BDGSRT2=1:"/DNR ",1:"")_" List"
- +4 WRITE !,BDGDATE,?(80-$LENGTH(X)\2),X,?71,"Page: ",BDGPG
- +5 SET X=$SELECT(BDGSRT="A":"For ALL Ward Locations",1:$PIECE(BDGSRT,U,2))
- +6 WRITE !,BDGTIME,?(80-$LENGTH(X)\2),X
- +7 WRITE !,$$REPEAT^XLFSTR("-",80)
- +8 WRITE !?5,"Patient",?23,"Chart #",?31,"Age",?39,"Room",?47,"Srv"
- +9 WRITE ?53,"Provider",?69,"Added"
- +10 WRITE !,$$REPEAT^XLFSTR("=",80)
- +11 QUIT
- +12 ;
- HELP ; -- help code
- +1 SET X="?"
- DO DISP^XQORM1
- WRITE !!
- +2 QUIT
- +3 ;
- EXIT ; -- exit code
- +1 KILL ^TMP("BDGIPL",$JOB)
- +2 ;K BDGSRT cmi/anch/maw 7/25/2007 is needed for multiple copies patch 1007
- +3 QUIT
- +4 ;
- EXPND ; -- expand code
- +1 QUIT
- +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)
- +2 ;
- AGE(P) ; return formatted age
- +1 NEW X
- SET X=$$GET1^DIQ(9000001,DFN,1102.98)
- +2 SET X=$JUSTIFY($PIECE(X," "),3)_" "_$EXTRACT($PIECE(X," ",2),1,2)
- +3 QUIT X