- BDGADD1 ; IHS/ANMC/LJF - A&D DETAILED PRINT CONT. ; [ 07/01/2002 10:18 AM ]
- ;;5.3;PIMS;**1003,1013**;MAY 28, 2004
- ;IHS/ITSC/LJF 6/2/2005 PATCH 1003 adjusted code under Deaths to match other sections
- ; added code for mulitple admits and discharges
- ;ihs/cmi/maw 9/14/2011 PATCH 1013 added day surgery
- ;
- PATDATA ;EP; build display lines for patient data
- ; called by INIT^BDGADD
- ;
- D ADMITS,DEATHS,TRANSFER
- D ^BDGADD2 ;day surgery listing
- Q
- ;
- ADMITS ; build array of admits
- ; first for inpatients, then observations, then newborns
- NEW SUB,SUB2,TITLE,TITLE2,X,NAME,DFN,IFN,LINE,DATA
- F SUB="ADMIT","DSCH" D
- . F SUB2="I","O","N","D" D
- .. ;
- .. ; display total admissions for category
- .. S TITLE=$S(SUB2="I":"Inpatient",SUB2="O":"Observation",SUB2="D":"Day Surgery",1:"Newborn")
- .. S TITLE2=$S(SUB="ADMIT":" Admissions:",1:" Discharges:")
- .. S X=$$COUNT(SUB,SUB2) I X>0 D SET("",.VALMCNT),SET($$PAD(TITLE_TITLE2,25)_X,.VALMCNT)
- .. ;
- .. ; loop through admits
- .. S NAME=0 F S NAME=$O(^TMP("BDGAD",$J,SUB,SUB2,NAME)) Q:NAME="" D
- ... S DFN=0 F S DFN=$O(^TMP("BDGAD",$J,SUB,SUB2,NAME,DFN)) Q:'DFN D
- .... ;
- .... ;IHS/ITSC/LJF 6/3/2005 PATCH 1003 add extra loop using IFN
- .... ;S DATA=^TMP("BDGAD",$J,SUB,SUB2,NAME,DFN)
- .... S IFN=0 F S IFN=$O(^TMP("BDGAD",$J,SUB,SUB2,NAME,DFN,IFN)) Q:'IFN D
- ..... S DATA=^TMP("BDGAD",$J,SUB,SUB2,NAME,DFN,IFN)
- ..... ;
- ..... ; PATCH 1003 added extra . to lines below
- ..... S LINE=$E($$GET1^DIQ(2,DFN,.01),1,25)
- ..... S LINE=$$PAD(LINE,27)_$J($$HRCN^BDGF2(DFN,DUZ(2)),6) ;chart
- ..... S LINE=$$PAD(LINE,35)_$P(DATA,U,4) ;age
- ..... S LINE=$$PAD(LINE,40)_$E($$GET1^DIQ(9000001,DFN,1118),1,15) ;community
- ..... S LINE=$$PAD(LINE,58)_$$GET1^DIQ(9009016.5,+$P(DATA,U,2),.02) ;ward
- ..... S LINE=$$PAD(LINE,65)_$$GET1^DIQ(45.7,+$P(DATA,U),99) ;service
- ..... S LINE=$$PAD(LINE,72)_$E($P(DATA,U,3),1,18) ;provider
- ..... K BDGX S BDGX="BDGX" D PCP^BSDU1(DFN,.BDGX) ;pcp
- ..... S LINE=$$PAD(LINE,92)_$E($P($G(BDGX(1)),"/"),1,18)
- ..... ;
- ..... D SET(LINE,.VALMCNT)
- ;end of PATCH 1003 changes
- ;
- Q
- ;
- TRANSFER ; loop through transfers (ward and service)
- NEW SUB,FILE,FIELD,TITLE,X,NAME,DFN,IFN,DATA
- ;
- F SUB="WARD","SERV" D
- . ;
- . ;ward/service abreviations file/field pairs
- . S FILE=$S(SUB="WARD":9009016.5,1:45.7),FIELD=$S(SUB="WARD":.02,1:99)
- . ;
- . ; display total transfers for category
- . S TITLE=$S(SUB="WARD":"Ward",1:"Service")
- . S X=$$COUNT2(SUB)
- . I X>0 D SET("",.VALMCNT),SET(TITLE_" Transfers: "_X,.VALMCNT)
- . ;
- . S NAME=0 F S NAME=$O(^TMP("BDGAD",$J,SUB,NAME)) Q:NAME="" D
- .. S DFN=0 F S DFN=$O(^TMP("BDGAD",$J,SUB,NAME,DFN)) Q:'DFN D
- ... S IFN=0 F S IFN=$O(^TMP("BDGAD",$J,SUB,NAME,DFN,IFN)) Q:'IFN D
- .... ;
- .... S DATA=^TMP("BDGAD",$J,SUB,NAME,DFN,IFN)
- .... ; old ward/srv -> new ward/srv
- .... S LINE=$$PAD($E(NAME,1,17),20) ;name
- .... S LINE=LINE_$J($$HRCN^BDGF2(DFN,DUZ(2)),6) ;chart #
- .... S LINE=$$PAD(LINE,30)_$$GET1^DIQ(FILE,+$P(DATA,U),FIELD)
- .... S LINE=$$PAD(LINE,35)_"-> "_$$GET1^DIQ(FILE,$P(DATA,U,2),FIELD)
- .... D SET(LINE,.VALMCNT)
- Q
- ;
- ;
- DEATHS ; Now display any deaths
- ; display total # of deaths first
- NEW X,NAME,DFN,IFN,DATA,LINE
- ;
- ;S X=$$COUNT("DEATH","") I X>0 D SET($$PAD("Deaths:",25)_X,.VALMCNT)
- S X=$$COUNT("DEATH","") I X>0 D SET("",.VALMCNT),SET($$PAD("Deaths:",25)_X,.VALMCNT)
- ;
- S NAME=0 F S NAME=$O(^TMP("BDGAD",$J,"DEATH",NAME)) Q:NAME="" D
- . S DFN=0 F S DFN=$O(^TMP("BDGAD",$J,"DEATH",NAME,DFN)) Q:'DFN D
- .. ;
- .. ;IHS/ITSC/LJF 6/2/2005 PATCH 1003 changed columns around to match other sections
- .. S DATA=^TMP("BDGAD",$J,"DEATH",NAME,DFN)
- .. S LINE=$$PAD($E($$GET1^DIQ(2,DFN,.01),1,17),25) ;name
- .. S LINE=$$PAD(LINE,27)_$J($$HRCN^BDGF2(DFN,DUZ(2)),6) ;chart#
- .. S LINE=$$PAD(LINE,35)_$P(DATA,U,4) ;age
- .. S LINE=$$PAD(LINE,40)_$E($$GET1^DIQ(9000001,DFN,1118),1,20) ;com
- .. S LINE=$$PAD(LINE,58)_$$GET1^DIQ(9009016.5,+$P(DATA,U,2),.02) ;wd
- .. ;S LINE=$$PAD(LINE,70)_$$GET1^DIQ(45.7,+$P(DATA,U,2),99) ;srv
- .. S LINE=$$PAD(LINE,65)_$$GET1^DIQ(45.7,+$P(DATA,U),99) ;srv; PATCH 1003 fixed code
- .. S LINE=$$PAD(LINE,72)_$E($P(DATA,U,3),1,20) ;prov
- .. ; PATCH 1003 - 2 new lines
- .. K BDGX S BDGX="BDGX" D PCP^BSDU1(DFN,.BDGX) ;pcp
- .. S LINE=$$PAD(LINE,92)_$E($P($G(BDGX(1)),"/"),1,18)
- .. ;
- .. D SET(LINE,.VALMCNT)
- Q
- ;
- COUNT(X,X1) ; returns # of events based on type sent in X and X1
- ; X can = "ADMIT" or "DSCH" or "DEATH"
- ; X1 can = "O" or "I" or "N" or "" if X="DEATH"
- ;
- NEW PIECE,SV,N,COUNT,SNM
- S PIECE=$S(X="ADMIT":3,X="DSCH":4,1:7) ;piece in ^BDGCTX node
- S SV=0 F S SV=$O(^BDGCTX(SV)) Q:'SV D
- . S SNM=$$GET1^DIQ(45.7,SV,.01)
- . I X'="DEATH",X1="I" Q:SNM="NEWBORN" Q:SNM["OBSERVATION" Q:SNM="DAY SURGERY"
- . I X'="DEATH",X1="O" Q:SNM'["OBSERVATION"
- . I X'="DEATH",X1="N" Q:SNM'="NEWBORN"
- . I X'="DEATH",X1="D" Q:SNM'="DAY SURGERY"
- . ;
- . S N=$G(^BDGCTX(SV,1,BDGT,0))
- . S COUNT=$G(COUNT)+$P(N,U,PIECE)+$P(N,U,PIECE+10)
- Q +$G(COUNT)
- ;
- COUNT2(X) ; returns # of events based on type sent in X and X1
- ; X can = "WARD" or "SERV"
- ;
- NEW GBL,SV,N,COUNT
- S GBL=$S(X="WARD":"^BDGCWD",1:"^BDGCTX")
- S SV=0 F S SV=$O(@GBL@(SV)) Q:'SV D
- . S N=$G(@GBL@(SV,1,BDGT,0))
- . S COUNT=$G(COUNT)+$P(N,U,5)+$P(N,U,15)
- Q +$G(COUNT)
- ;
- SET(LINE,NUM) ; put display line into array
- D SET^BDGADD(LINE,.NUM)
- 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)
- BDGADD1 ; IHS/ANMC/LJF - A&D DETAILED PRINT CONT. ; [ 07/01/2002 10:18 AM ]
- +1 ;;5.3;PIMS;**1003,1013**;MAY 28, 2004
- +2 ;IHS/ITSC/LJF 6/2/2005 PATCH 1003 adjusted code under Deaths to match other sections
- +3 ; added code for mulitple admits and discharges
- +4 ;ihs/cmi/maw 9/14/2011 PATCH 1013 added day surgery
- +5 ;
- PATDATA ;EP; build display lines for patient data
- +1 ; called by INIT^BDGADD
- +2 ;
- +3 DO ADMITS
- DO DEATHS
- DO TRANSFER
- +4 ;day surgery listing
- DO ^BDGADD2
- +5 QUIT
- +6 ;
- ADMITS ; build array of admits
- +1 ; first for inpatients, then observations, then newborns
- +2 NEW SUB,SUB2,TITLE,TITLE2,X,NAME,DFN,IFN,LINE,DATA
- +3 FOR SUB="ADMIT","DSCH"
- Begin DoDot:1
- +4 FOR SUB2="I","O","N","D"
- Begin DoDot:2
- +5 ;
- +6 ; display total admissions for category
- +7 SET TITLE=$SELECT(SUB2="I":"Inpatient",SUB2="O":"Observation",SUB2="D":"Day Surgery",1:"Newborn")
- +8 SET TITLE2=$SELECT(SUB="ADMIT":" Admissions:",1:" Discharges:")
- +9 SET X=$$COUNT(SUB,SUB2)
- IF X>0
- DO SET("",.VALMCNT)
- DO SET($$PAD(TITLE_TITLE2,25)_X,.VALMCNT)
- +10 ;
- +11 ; loop through admits
- +12 SET NAME=0
- FOR
- SET NAME=$ORDER(^TMP("BDGAD",$JOB,SUB,SUB2,NAME))
- IF NAME=""
- QUIT
- Begin DoDot:3
- +13 SET DFN=0
- FOR
- SET DFN=$ORDER(^TMP("BDGAD",$JOB,SUB,SUB2,NAME,DFN))
- IF 'DFN
- QUIT
- Begin DoDot:4
- +14 ;
- +15 ;IHS/ITSC/LJF 6/3/2005 PATCH 1003 add extra loop using IFN
- +16 ;S DATA=^TMP("BDGAD",$J,SUB,SUB2,NAME,DFN)
- +17 SET IFN=0
- FOR
- SET IFN=$ORDER(^TMP("BDGAD",$JOB,SUB,SUB2,NAME,DFN,IFN))
- IF 'IFN
- QUIT
- Begin DoDot:5
- +18 SET DATA=^TMP("BDGAD",$JOB,SUB,SUB2,NAME,DFN,IFN)
- +19 ;
- +20 ; PATCH 1003 added extra . to lines below
- +21 SET LINE=$EXTRACT($$GET1^DIQ(2,DFN,.01),1,25)
- +22 ;chart
- SET LINE=$$PAD(LINE,27)_$JUSTIFY($$HRCN^BDGF2(DFN,DUZ(2)),6)
- +23 ;age
- SET LINE=$$PAD(LINE,35)_$PIECE(DATA,U,4)
- +24 ;community
- SET LINE=$$PAD(LINE,40)_$EXTRACT($$GET1^DIQ(9000001,DFN,1118),1,15)
- +25 ;ward
- SET LINE=$$PAD(LINE,58)_$$GET1^DIQ(9009016.5,+$PIECE(DATA,U,2),.02)
- +26 ;service
- SET LINE=$$PAD(LINE,65)_$$GET1^DIQ(45.7,+$PIECE(DATA,U),99)
- +27 ;provider
- SET LINE=$$PAD(LINE,72)_$EXTRACT($PIECE(DATA,U,3),1,18)
- +28 ;pcp
- KILL BDGX
- SET BDGX="BDGX"
- DO PCP^BSDU1(DFN,.BDGX)
- +29 SET LINE=$$PAD(LINE,92)_$EXTRACT($PIECE($GET(BDGX(1)),"/"),1,18)
- +30 ;
- +31 DO SET(LINE,.VALMCNT)
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +32 ;end of PATCH 1003 changes
- +33 ;
- +34 QUIT
- +35 ;
- TRANSFER ; loop through transfers (ward and service)
- +1 NEW SUB,FILE,FIELD,TITLE,X,NAME,DFN,IFN,DATA
- +2 ;
- +3 FOR SUB="WARD","SERV"
- Begin DoDot:1
- +4 ;
- +5 ;ward/service abreviations file/field pairs
- +6 SET FILE=$SELECT(SUB="WARD":9009016.5,1:45.7)
- SET FIELD=$SELECT(SUB="WARD":.02,1:99)
- +7 ;
- +8 ; display total transfers for category
- +9 SET TITLE=$SELECT(SUB="WARD":"Ward",1:"Service")
- +10 SET X=$$COUNT2(SUB)
- +11 IF X>0
- DO SET("",.VALMCNT)
- DO SET(TITLE_" Transfers: "_X,.VALMCNT)
- +12 ;
- +13 SET NAME=0
- FOR
- SET NAME=$ORDER(^TMP("BDGAD",$JOB,SUB,NAME))
- IF NAME=""
- QUIT
- Begin DoDot:2
- +14 SET DFN=0
- FOR
- SET DFN=$ORDER(^TMP("BDGAD",$JOB,SUB,NAME,DFN))
- IF 'DFN
- QUIT
- Begin DoDot:3
- +15 SET IFN=0
- FOR
- SET IFN=$ORDER(^TMP("BDGAD",$JOB,SUB,NAME,DFN,IFN))
- IF 'IFN
- QUIT
- Begin DoDot:4
- +16 ;
- +17 SET DATA=^TMP("BDGAD",$JOB,SUB,NAME,DFN,IFN)
- +18 ; old ward/srv -> new ward/srv
- +19 ;name
- SET LINE=$$PAD($EXTRACT(NAME,1,17),20)
- +20 ;chart #
- SET LINE=LINE_$JUSTIFY($$HRCN^BDGF2(DFN,DUZ(2)),6)
- +21 SET LINE=$$PAD(LINE,30)_$$GET1^DIQ(FILE,+$PIECE(DATA,U),FIELD)
- +22 SET LINE=$$PAD(LINE,35)_"-> "_$$GET1^DIQ(FILE,$PIECE(DATA,U,2),FIELD)
- +23 DO SET(LINE,.VALMCNT)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +24 QUIT
- +25 ;
- +26 ;
- DEATHS ; Now display any deaths
- +1 ; display total # of deaths first
- +2 NEW X,NAME,DFN,IFN,DATA,LINE
- +3 ;
- +4 ;S X=$$COUNT("DEATH","") I X>0 D SET($$PAD("Deaths:",25)_X,.VALMCNT)
- +5 SET X=$$COUNT("DEATH","")
- IF X>0
- DO SET("",.VALMCNT)
- DO SET($$PAD("Deaths:",25)_X,.VALMCNT)
- +6 ;
- +7 SET NAME=0
- FOR
- SET NAME=$ORDER(^TMP("BDGAD",$JOB,"DEATH",NAME))
- IF NAME=""
- QUIT
- Begin DoDot:1
- +8 SET DFN=0
- FOR
- SET DFN=$ORDER(^TMP("BDGAD",$JOB,"DEATH",NAME,DFN))
- IF 'DFN
- QUIT
- Begin DoDot:2
- +9 ;
- +10 ;IHS/ITSC/LJF 6/2/2005 PATCH 1003 changed columns around to match other sections
- +11 SET DATA=^TMP("BDGAD",$JOB,"DEATH",NAME,DFN)
- +12 ;name
- SET LINE=$$PAD($EXTRACT($$GET1^DIQ(2,DFN,.01),1,17),25)
- +13 ;chart#
- SET LINE=$$PAD(LINE,27)_$JUSTIFY($$HRCN^BDGF2(DFN,DUZ(2)),6)
- +14 ;age
- SET LINE=$$PAD(LINE,35)_$PIECE(DATA,U,4)
- +15 ;com
- SET LINE=$$PAD(LINE,40)_$EXTRACT($$GET1^DIQ(9000001,DFN,1118),1,20)
- +16 ;wd
- SET LINE=$$PAD(LINE,58)_$$GET1^DIQ(9009016.5,+$PIECE(DATA,U,2),.02)
- +17 ;S LINE=$$PAD(LINE,70)_$$GET1^DIQ(45.7,+$P(DATA,U,2),99) ;srv
- +18 ;srv; PATCH 1003 fixed code
- SET LINE=$$PAD(LINE,65)_$$GET1^DIQ(45.7,+$PIECE(DATA,U),99)
- +19 ;prov
- SET LINE=$$PAD(LINE,72)_$EXTRACT($PIECE(DATA,U,3),1,20)
- +20 ; PATCH 1003 - 2 new lines
- +21 ;pcp
- KILL BDGX
- SET BDGX="BDGX"
- DO PCP^BSDU1(DFN,.BDGX)
- +22 SET LINE=$$PAD(LINE,92)_$EXTRACT($PIECE($GET(BDGX(1)),"/"),1,18)
- +23 ;
- +24 DO SET(LINE,.VALMCNT)
- End DoDot:2
- End DoDot:1
- +25 QUIT
- +26 ;
- COUNT(X,X1) ; returns # of events based on type sent in X and X1
- +1 ; X can = "ADMIT" or "DSCH" or "DEATH"
- +2 ; X1 can = "O" or "I" or "N" or "" if X="DEATH"
- +3 ;
- +4 NEW PIECE,SV,N,COUNT,SNM
- +5 ;piece in ^BDGCTX node
- SET PIECE=$SELECT(X="ADMIT":3,X="DSCH":4,1:7)
- +6 SET SV=0
- FOR
- SET SV=$ORDER(^BDGCTX(SV))
- IF 'SV
- QUIT
- Begin DoDot:1
- +7 SET SNM=$$GET1^DIQ(45.7,SV,.01)
- +8 IF X'="DEATH"
- IF X1="I"
- IF SNM="NEWBORN"
- QUIT
- IF SNM["OBSERVATION"
- QUIT
- IF SNM="DAY SURGERY"
- QUIT
- +9 IF X'="DEATH"
- IF X1="O"
- IF SNM'["OBSERVATION"
- QUIT
- +10 IF X'="DEATH"
- IF X1="N"
- IF SNM'="NEWBORN"
- QUIT
- +11 IF X'="DEATH"
- IF X1="D"
- IF SNM'="DAY SURGERY"
- QUIT
- +12 ;
- +13 SET N=$GET(^BDGCTX(SV,1,BDGT,0))
- +14 SET COUNT=$GET(COUNT)+$PIECE(N,U,PIECE)+$PIECE(N,U,PIECE+10)
- End DoDot:1
- +15 QUIT +$GET(COUNT)
- +16 ;
- COUNT2(X) ; returns # of events based on type sent in X and X1
- +1 ; X can = "WARD" or "SERV"
- +2 ;
- +3 NEW GBL,SV,N,COUNT
- +4 SET GBL=$SELECT(X="WARD":"^BDGCWD",1:"^BDGCTX")
- +5 SET SV=0
- FOR
- SET SV=$ORDER(@GBL@(SV))
- IF 'SV
- QUIT
- Begin DoDot:1
- +6 SET N=$GET(@GBL@(SV,1,BDGT,0))
- +7 SET COUNT=$GET(COUNT)+$PIECE(N,U,5)+$PIECE(N,U,15)
- End DoDot:1
- +8 QUIT +$GET(COUNT)
- +9 ;
- SET(LINE,NUM) ; put display line into array
- +1 DO SET^BDGADD(LINE,.NUM)
- +2 QUIT
- +3 ;
- 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)
