BDGIPL1 ; IHS/ANMC/LJF - ALPHA LIST OF CURRENT INPTS ;
;;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 ALPHA
NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BDG IPL ALPHA")
D CLEAR^VALM1
Q
;
HDR ; -- header code
NEW X
S VALMHDR(1)=$$SP(12)_"** "_$$CONF^BDGF_" **"
Q
;
INIT ; -- init variables and list array
NEW WD,DFN,BDGCNT,NAME
I $E(IOST,1,2)="C-" D MSG^BDGF("Please wait while I compile the listing...",2,0)
K ^TMP("BDGIPL",$J),^TMP("BDGIPL1",$J)
S VALMCNT=0,BDGCNT=1
;
; loop thru inpatients and put in alphabetical order
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
.. S ^TMP("BDGIPL1",$J,$$GET1^DIQ(2,DFN,.01),DFN)=""
;
; pull sorted list and create display array
S NM=0 F S NM=$O(^TMP("BDGIPL1",$J,NM)) Q:NM="" D
. S DFN=0 F S DFN=$O(^TMP("BDGIPL1",$J,NM,DFN)) Q:'DFN D
.. D LINE
;
K ^TMP("BDGIPL1",$J)
Q
;
LINE ; set up dislay line for patient
NEW LINE,X
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,18) ;name
S LINE=$$PAD(LINE,25)_$$HRCND^BDGF2($$HRCN^BDGF2(DFN,DUZ(2)))
S LINE=$$PAD(LINE,35)_$$AGE(DFN) ;age
S LINE=$$PAD(LINE,43)_$E($$GET1^DIQ(9000001,DFN,1118),1,15) ;commun
S LINE=$$PAD(LINE,60)_$$INS ;insurnace coverage
D SET(LINE,.VALMCNT,BDGCNT,DFN)
;
S LINE=$$SP(6)_"Admitted to "_$$WRDABRV^BDGF1(DFN) ;ward
S X=$G(^DPT(DFN,.101))
I X]"" S LINE=LINE_" ("_X_")" ;room
S LINE=$$PAD(LINE,30)_$$GET1^DIQ(45.7,+$G(^DPT(DFN,.103)),99) ;srv
S LINE=$$PAD(LINE,37)_$$CURPRV^BDGF1(DFN,30) ;attn prov
S LINE=$$PAD(LINE,57)_" on "_$P($$INPT1^BDGF1(DFN,DT),"@") ;admit date
S LINE=$$PAD(LINE,69)_"("_$$CURLOS^BDGF1(DFN,1)_")" ;los
D SET(LINE,.VALMCNT,BDGCNT,DFN)
D SET("",.VALMCNT,BDGCNT,DFN)
;
; increment counter
S BDGCNT=BDGCNT+1
Q
;
SET(LINE,NUM,COUNT,IEN) ;EP - put display line into array
S NUM=NUM+1
S ^TMP("BDGIPL",$J,NUM,0)=LINE
S ^TMP("BDGIPL",$J,"IDX",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
. S BDGLN=^TMP("BDGIPL",$J,BDGX,0)
. W !,BDGLN
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
;
HDG ; heading for paper report
S BDGPG=$G(BDGPG)+1 I BDGPG>1 W @IOF
W !,BDGTIME,?16,$$CONF^BDGF,?71,"Page: ",BDGPG
W !,BDGDATE,?24,"Alphabetical List of Current Inpatients",?76,BDGUSR
W !,$$REPEAT^XLFSTR("-",80)
W !?5,"Patient",?25,"HRCN",?35,"Age",?43,"Community",?60,"Insurance"
W !?6,"Ward (Room)",?29,"Srv",?36,"Provider",?60,"Admit Date (LOS)"
W !,$$REPEAT^XLFSTR("=",80)
Q
;
INS() ; returns combination of MCR/MCD/PI
NEW DATE,ANS
S DATE=$G(^DPT(DFN,.105)) I 'DATE Q "" ;admission ien
S DATE=+$G(^DGPM(DATE,0)) ;admit date
Q $$INSUR^BDGF2(DFN,DATE)
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("BDGIPL",$J)
Q
;
EXPND ; -- expand code
D FULL^VALM1
NEW X,Y,Z
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) Q
K DFN S X=0 F S X=$O(VALMY(X)) Q:X="" D
. S Y=0 F S Y=$O(^TMP("BDGIPL",$J,"IDX",Y)) Q:Y="" Q:$G(DFN) D
.. S Z=$O(^TMP("BDGIPL",$J,"IDX",Y,0))
.. Q:^TMP("BDGIPL",$J,"IDX",Y,Z)=""
.. I Z=X S DFN=^TMP("BDGIPL",$J,"IDX",Y,Z)
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
BDGIPL1 ; IHS/ANMC/LJF - ALPHA LIST OF CURRENT INPTS ;
+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 IF $EXTRACT(IOST,1,2)="P-"
DO INIT
DO PRINT
QUIT
+7 ;
EN ; -- main entry point for BDG IPL ALPHA
+1 NEW VALMCNT
DO TERM^VALM0
DO CLEAR^VALM1
+2 DO EN^VALM("BDG IPL ALPHA")
+3 DO CLEAR^VALM1
+4 QUIT
+5 ;
HDR ; -- header code
+1 NEW X
+2 SET VALMHDR(1)=$$SP(12)_"** "_$$CONF^BDGF_" **"
+3 QUIT
+4 ;
INIT ; -- init variables and list array
+1 NEW WD,DFN,BDGCNT,NAME
+2 IF $EXTRACT(IOST,1,2)="C-"
DO MSG^BDGF("Please wait while I compile the listing...",2,0)
+3 KILL ^TMP("BDGIPL",$JOB),^TMP("BDGIPL1",$JOB)
+4 SET VALMCNT=0
SET BDGCNT=1
+5 ;
+6 ; loop thru inpatients and put in alphabetical order
+7 SET WD=0
FOR
SET WD=$ORDER(^DPT("CN",WD))
IF WD=""
QUIT
Begin DoDot:1
+8 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("CN",WD,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+9 SET ^TMP("BDGIPL1",$JOB,$$GET1^DIQ(2,DFN,.01),DFN)=""
End DoDot:2
End DoDot:1
+10 ;
+11 ; pull sorted list and create display array
+12 SET NM=0
FOR
SET NM=$ORDER(^TMP("BDGIPL1",$JOB,NM))
IF NM=""
QUIT
Begin DoDot:1
+13 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("BDGIPL1",$JOB,NM,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+14 DO LINE
End DoDot:2
End DoDot:1
+15 ;
+16 KILL ^TMP("BDGIPL1",$JOB)
+17 QUIT
+18 ;
LINE ; set up dislay line for patient
+1 NEW LINE,X
+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,18)
+4 SET LINE=$$PAD(LINE,25)_$$HRCND^BDGF2($$HRCN^BDGF2(DFN,DUZ(2)))
+5 ;age
SET LINE=$$PAD(LINE,35)_$$AGE(DFN)
+6 ;commun
SET LINE=$$PAD(LINE,43)_$EXTRACT($$GET1^DIQ(9000001,DFN,1118),1,15)
+7 ;insurnace coverage
SET LINE=$$PAD(LINE,60)_$$INS
+8 DO SET(LINE,.VALMCNT,BDGCNT,DFN)
+9 ;
+10 ;ward
SET LINE=$$SP(6)_"Admitted to "_$$WRDABRV^BDGF1(DFN)
+11 SET X=$GET(^DPT(DFN,.101))
+12 ;room
IF X]""
SET LINE=LINE_" ("_X_")"
+13 ;srv
SET LINE=$$PAD(LINE,30)_$$GET1^DIQ(45.7,+$GET(^DPT(DFN,.103)),99)
+14 ;attn prov
SET LINE=$$PAD(LINE,37)_$$CURPRV^BDGF1(DFN,30)
+15 ;admit date
SET LINE=$$PAD(LINE,57)_" on "_$PIECE($$INPT1^BDGF1(DFN,DT),"@")
+16 ;los
SET LINE=$$PAD(LINE,69)_"("_$$CURLOS^BDGF1(DFN,1)_")"
+17 DO SET(LINE,.VALMCNT,BDGCNT,DFN)
+18 DO SET("",.VALMCNT,BDGCNT,DFN)
+19 ;
+20 ; increment counter
+21 SET BDGCNT=BDGCNT+1
+22 QUIT
+23 ;
SET(LINE,NUM,COUNT,IEN) ;EP - put display line into array
+1 SET NUM=NUM+1
+2 SET ^TMP("BDGIPL",$JOB,NUM,0)=LINE
+3 SET ^TMP("BDGIPL",$JOB,"IDX",NUM,COUNT)=IEN
+4 QUIT
+5 ;
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 SET BDGLN=^TMP("BDGIPL",$JOB,BDGX,0)
+8 WRITE !,BDGLN
End DoDot:1
+9 ;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
+10 DO PRTKL^BDGF
DO EXIT
+11 ;D ^%ZISC,PRTKL^BDGF,EXIT cmi/anch/maw 2/22/2007 orig line
+12 QUIT
+13 ;
HDG ; heading for paper report
+1 SET BDGPG=$GET(BDGPG)+1
IF BDGPG>1
WRITE @IOF
+2 WRITE !,BDGTIME,?16,$$CONF^BDGF,?71,"Page: ",BDGPG
+3 WRITE !,BDGDATE,?24,"Alphabetical List of Current Inpatients",?76,BDGUSR
+4 WRITE !,$$REPEAT^XLFSTR("-",80)
+5 WRITE !?5,"Patient",?25,"HRCN",?35,"Age",?43,"Community",?60,"Insurance"
+6 WRITE !?6,"Ward (Room)",?29,"Srv",?36,"Provider",?60,"Admit Date (LOS)"
+7 WRITE !,$$REPEAT^XLFSTR("=",80)
+8 QUIT
+9 ;
INS() ; returns combination of MCR/MCD/PI
+1 NEW DATE,ANS
+2 ;admission ien
SET DATE=$GET(^DPT(DFN,.105))
IF 'DATE
QUIT ""
+3 ;admit date
SET DATE=+$GET(^DGPM(DATE,0))
+4 QUIT $$INSUR^BDGF2(DFN,DATE)
+5 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("BDGIPL",$JOB)
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 DO FULL^VALM1
+2 NEW X,Y,Z
+3 DO EN^VALM2(XQORNOD(0),"OS")
+4 IF '$DATA(VALMY)
QUIT
+5 KILL DFN
SET X=0
FOR
SET X=$ORDER(VALMY(X))
IF X=""
QUIT
Begin DoDot:1
+6 SET Y=0
FOR
SET Y=$ORDER(^TMP("BDGIPL",$JOB,"IDX",Y))
IF Y=""
QUIT
IF $GET(DFN)
QUIT
Begin DoDot:2
+7 SET Z=$ORDER(^TMP("BDGIPL",$JOB,"IDX",Y,0))
+8 IF ^TMP("BDGIPL",$JOB,"IDX",Y,Z)=""
QUIT
+9 IF Z=X
SET DFN=^TMP("BDGIPL",$JOB,"IDX",Y,Z)
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
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
