ADGCEN31 ; IHS/ADC/PDW/ENM - PRINT CENSUS AID-PATIENT LIST ; [ 03/25/1999 11:48 AM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
;
;rtn prints listing of admissions, discharges, and transfers
;for each ward specified. Each ward on a separate page.
;Summary page at the end if all wards printed
;
;***> initialize variables
S DGPAGE=0,Y=DGBDT X ^DD("DD") S DGDATE=Y,Y=DGEDT X ^DD("DD")
S DGSITE=$P(^DIC(4,DUZ(2),0),U),DGDUZ=$P(^VA(200,DUZ,0),U,2)
S DGX=0 F DGI="AA","TI","TO","AD","DT" S DGX=DGX+1,DGPOS(DGI)=DGX
S DGDATE=DGDATE_" to "_Y,DGSTOP="",DGWW=0
;
I DGWD="A" G INIT1 ;if all wards then loop
E S DGWW=$P(^DIC(42,DGWD,0),U),^TMP($J,"WARD",DGWW)="" G INIT2
INIT1 S DGWW=$O(^DIC(42,"B",DGWW)) G INIT2:DGWW=""
S DGWW1=$O(^DIC(42,"B",DGWW,0)) ;get wards in alpha order
I $D(^DIC(42,DGWW1,"I")),(^("I")="I") G INIT1 ;screen for inactives
S ^TMP($J,"WARD",DGWW)="" G INIT1
INIT2 ;
;
;***> find ward and print admissions
S DGW=0
WARD S DGW=$O(^TMP($J,"WARD",DGW)) G END:DGW="" S DGTOTL=0 D HEAD
S DGX="AA",DGMOVE="ADMISSIONS",DGDT=0 D FIND G END1:DGSTOP=U
;
;***> print transfers in
TRANSIN S DGX="TI",DGMOVE="WARD TRANSFERS IN",DGDT=0 D FIND G END1:DGSTOP=U
;
;***> print transfers out
TRANSOUT S DGX="TO",DGMOVE="WARD TRANSFERS OUT",DGDT=0 D FIND G END1:DGSTOP=U
;
;***> print discharges
DISCH S DGX="AD",DGMOVE="DISCHARGES",DGDT=0 D FIND G END1:DGSTOP=U
;
;***> print deaths
DEATHS S DGX="DT",DGMOVE="DEATHS",DGDT=0 D FIND G END1:DGSTOP=U
W !!?45,"CENSUS CHANGE FOR WARD: ",$J(DGTOTL,3)
;
;***> newborns
NEWBORN I '$D(^TMP($J,"NEWA",DGW))&('$D(^TMP($J,"NEWD",DGW))) G NEXT
S DGX="NEWA",DGDT=0,DGMOVE="NEWBORN ADMISSIONS" D FIND G END1:DGSTOP=U
S DGX="NEWT",DGDT=0,DGMOVE="NEWBORN TRANSFER" D FIND G END1:DGSTOP=U
S DGX="NEWD",DGDT=0,DGMOVE="NEWBORN DISCHARGES" D FIND G END1:DGSTOP=U
S DGX=$P(DGCT("NEWBORN"),U)-$P(DGCT("NEWBORN"),U,3)-$P(DGCT("NEWBORN"),U,4)
W !!?37,"NEWBORN CENSUS CHANGE FOR WARD: ",$J(DGX,3)
;
NEXT I IOST["C-" K DIR S DIR(0)="E" D ^DIR S DGSTOP=X
G WARD ;close loop, get next ward
;
;
END G ^ADGCEN32 ;print summary page and end
;
END1 G END1^ADGCEN32 ;quit
;
;
;***> find entries and print subrtn
FIND I $Y>(IOSL-6) D NEWPG G F4:DGSTOP=U
W !!?80-$L(DGMOVE)/2,DGMOVE S DGCOUNT=0
F1 S DGDT=$O(^TMP($J,DGX,DGW,DGDT)) G F4:DGDT="" S DGNM=0
F2 S DGNM=$O(^TMP($J,DGX,DGW,DGDT,DGNM)) G F1:DGNM="" S DFN=0
F3 S DFN=$O(^TMP($J,DGX,DGW,DGDT,DGNM,DFN)) G F2:DFN=""
;
S DGCHT=$P(^AUPNPAT(DFN,41,DUZ(2),0),U,2) ;chart number
I $Y>(IOSL-4) D NEWPG G F4:DGSTOP=U
S DGTM=$P(DGDT,".",2),DGTM=$S(DGTM="":"N/A",1:$E(DGTM_"000",1,4))
W !?3,DGTM,?20,DGNM,?50,$J(DGCHT,6) S DGCOUNT=DGCOUNT+1 G F2
;
F4 W !?60,"SUBTOTAL: ",$J(DGCOUNT,3)
I DGX="AA"!(DGX="TI") D G F9
.S DGTOTL=DGTOTL+DGCOUNT
.S DGY=DGPOS(DGX),$P(DGCN(DGW),U,DGY)=DGCOUNT Q
I DGX="NEWA" S $P(DGCT("NEWBORN"),U)=DGCOUNT G F9
I DGX="NEWT" S $P(DGCT("NEWBORN"),U,3)=DGCOUNT G F9
I DGX="NEWD" S $P(DGCT("NEWBORN"),U,4)=DGCOUNT G F9
E S DGTOTL=DGTOTL-DGCOUNT,DGY=DGPOS(DGX),$P(DGCN(DGW),U,DGY)=DGCOUNT
F9 Q ;leave subrtn
;
NEWPG ;***> subrtn for end of page control
I IOST'?1"C-".E D HEAD S DGSTOP="" Q
K DIR S DIR(0)="E" D ^DIR S DGSTOP=X
I DGSTOP'=U D HEAD
Q
;
HEAD ;***> subrtn to print heading
I (IOST["C-")!(DGPAGE>0) W @IOF
S DGLIN="",$P(DGLIN,"=",80)="" W !,DGLIN S DGPAGE=DGPAGE+1
W !?11,"*****Confidential Patient Data Covered by Privacy Act*****"
W !,DGDUZ,?80-$L(DGSITE)/2,DGSITE S DGTY="WARD CENSUS LISTING"
W ! D TIME^ADGUTIL W ?80-$L(DGTY)/2,DGTY,?70,"Page: ",DGPAGE
S Y=DT X ^DD("DD") W !,Y
S DGWARD="*** "_DGW_" ***" W ?80-$L(DGWARD)/2,DGWARD
W !?80-$L(DGDATE)/2,DGDATE,!,DGLIN
I DGW'="SUMMARY" W !?3," Time",?20,"Patient Name",?50,"Chart #" G HD1
W !,"Ward",?15,"Beg Census Admits Net Transfers Discharges Ending Census"
HD1 S DGLIN="",$P(DGLIN,"-",80)="" W !,DGLIN
Q
ADGCEN31 ; IHS/ADC/PDW/ENM - PRINT CENSUS AID-PATIENT LIST ; [ 03/25/1999 11:48 AM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
+2 ;
+3 ;rtn prints listing of admissions, discharges, and transfers
+4 ;for each ward specified. Each ward on a separate page.
+5 ;Summary page at the end if all wards printed
+6 ;
+7 ;***> initialize variables
+8 SET DGPAGE=0
SET Y=DGBDT
XECUTE ^DD("DD")
SET DGDATE=Y
SET Y=DGEDT
XECUTE ^DD("DD")
+9 SET DGSITE=$PIECE(^DIC(4,DUZ(2),0),U)
SET DGDUZ=$PIECE(^VA(200,DUZ,0),U,2)
+10 SET DGX=0
FOR DGI="AA","TI","TO","AD","DT"
SET DGX=DGX+1
SET DGPOS(DGI)=DGX
+11 SET DGDATE=DGDATE_" to "_Y
SET DGSTOP=""
SET DGWW=0
+12 ;
+13 ;if all wards then loop
IF DGWD="A"
GOTO INIT1
+14 IF '$TEST
SET DGWW=$PIECE(^DIC(42,DGWD,0),U)
SET ^TMP($JOB,"WARD",DGWW)=""
GOTO INIT2
INIT1 SET DGWW=$ORDER(^DIC(42,"B",DGWW))
IF DGWW=""
GOTO INIT2
+1 ;get wards in alpha order
SET DGWW1=$ORDER(^DIC(42,"B",DGWW,0))
+2 ;screen for inactives
IF $DATA(^DIC(42,DGWW1,"I"))
IF (^("I")="I")
GOTO INIT1
+3 SET ^TMP($JOB,"WARD",DGWW)=""
GOTO INIT1
INIT2 ;
+1 ;
+2 ;***> find ward and print admissions
+3 SET DGW=0
WARD SET DGW=$ORDER(^TMP($JOB,"WARD",DGW))
IF DGW=""
GOTO END
SET DGTOTL=0
DO HEAD
+1 SET DGX="AA"
SET DGMOVE="ADMISSIONS"
SET DGDT=0
DO FIND
IF DGSTOP=U
GOTO END1
+2 ;
+3 ;***> print transfers in
TRANSIN SET DGX="TI"
SET DGMOVE="WARD TRANSFERS IN"
SET DGDT=0
DO FIND
IF DGSTOP=U
GOTO END1
+1 ;
+2 ;***> print transfers out
TRANSOUT SET DGX="TO"
SET DGMOVE="WARD TRANSFERS OUT"
SET DGDT=0
DO FIND
IF DGSTOP=U
GOTO END1
+1 ;
+2 ;***> print discharges
DISCH SET DGX="AD"
SET DGMOVE="DISCHARGES"
SET DGDT=0
DO FIND
IF DGSTOP=U
GOTO END1
+1 ;
+2 ;***> print deaths
DEATHS SET DGX="DT"
SET DGMOVE="DEATHS"
SET DGDT=0
DO FIND
IF DGSTOP=U
GOTO END1
+1 WRITE !!?45,"CENSUS CHANGE FOR WARD: ",$JUSTIFY(DGTOTL,3)
+2 ;
+3 ;***> newborns
NEWBORN IF '$DATA(^TMP($JOB,"NEWA",DGW))&('$DATA(^TMP($JOB,"NEWD",DGW)))
GOTO NEXT
+1 SET DGX="NEWA"
SET DGDT=0
SET DGMOVE="NEWBORN ADMISSIONS"
DO FIND
IF DGSTOP=U
GOTO END1
+2 SET DGX="NEWT"
SET DGDT=0
SET DGMOVE="NEWBORN TRANSFER"
DO FIND
IF DGSTOP=U
GOTO END1
+3 SET DGX="NEWD"
SET DGDT=0
SET DGMOVE="NEWBORN DISCHARGES"
DO FIND
IF DGSTOP=U
GOTO END1
+4 SET DGX=$PIECE(DGCT("NEWBORN"),U)-$PIECE(DGCT("NEWBORN"),U,3)-$PIECE(DGCT("NEWBORN"),U,4)
+5 WRITE !!?37,"NEWBORN CENSUS CHANGE FOR WARD: ",$JUSTIFY(DGX,3)
+6 ;
NEXT IF IOST["C-"
KILL DIR
SET DIR(0)="E"
DO ^DIR
SET DGSTOP=X
+1 ;close loop, get next ward
GOTO WARD
+2 ;
+3 ;
END ;print summary page and end
GOTO ^ADGCEN32
+1 ;
END1 ;quit
GOTO END1^ADGCEN32
+1 ;
+2 ;
+3 ;***> find entries and print subrtn
FIND IF $Y>(IOSL-6)
DO NEWPG
IF DGSTOP=U
GOTO F4
+1 WRITE !!?80-$LENGTH(DGMOVE)/2,DGMOVE
SET DGCOUNT=0
F1 SET DGDT=$ORDER(^TMP($JOB,DGX,DGW,DGDT))
IF DGDT=""
GOTO F4
SET DGNM=0
F2 SET DGNM=$ORDER(^TMP($JOB,DGX,DGW,DGDT,DGNM))
IF DGNM=""
GOTO F1
SET DFN=0
F3 SET DFN=$ORDER(^TMP($JOB,DGX,DGW,DGDT,DGNM,DFN))
IF DFN=""
GOTO F2
+1 ;
+2 ;chart number
SET DGCHT=$PIECE(^AUPNPAT(DFN,41,DUZ(2),0),U,2)
+3 IF $Y>(IOSL-4)
DO NEWPG
IF DGSTOP=U
GOTO F4
+4 SET DGTM=$PIECE(DGDT,".",2)
SET DGTM=$SELECT(DGTM="":"N/A",1:$EXTRACT(DGTM_"000",1,4))
+5 WRITE !?3,DGTM,?20,DGNM,?50,$JUSTIFY(DGCHT,6)
SET DGCOUNT=DGCOUNT+1
GOTO F2
+6 ;
F4 WRITE !?60,"SUBTOTAL: ",$JUSTIFY(DGCOUNT,3)
+1 IF DGX="AA"!(DGX="TI")
Begin DoDot:1
+2 SET DGTOTL=DGTOTL+DGCOUNT
+3 SET DGY=DGPOS(DGX)
SET $PIECE(DGCN(DGW),U,DGY)=DGCOUNT
QUIT
End DoDot:1
GOTO F9
+4 IF DGX="NEWA"
SET $PIECE(DGCT("NEWBORN"),U)=DGCOUNT
GOTO F9
+5 IF DGX="NEWT"
SET $PIECE(DGCT("NEWBORN"),U,3)=DGCOUNT
GOTO F9
+6 IF DGX="NEWD"
SET $PIECE(DGCT("NEWBORN"),U,4)=DGCOUNT
GOTO F9
+7 IF '$TEST
SET DGTOTL=DGTOTL-DGCOUNT
SET DGY=DGPOS(DGX)
SET $PIECE(DGCN(DGW),U,DGY)=DGCOUNT
F9 ;leave subrtn
QUIT
+1 ;
NEWPG ;***> subrtn for end of page control
+1 IF IOST'?1"C-".E
DO HEAD
SET DGSTOP=""
QUIT
+2 KILL DIR
SET DIR(0)="E"
DO ^DIR
SET DGSTOP=X
+3 IF DGSTOP'=U
DO HEAD
+4 QUIT
+5 ;
HEAD ;***> subrtn to print heading
+1 IF (IOST["C-")!(DGPAGE>0)
WRITE @IOF
+2 SET DGLIN=""
SET $PIECE(DGLIN,"=",80)=""
WRITE !,DGLIN
SET DGPAGE=DGPAGE+1
+3 WRITE !?11,"*****Confidential Patient Data Covered by Privacy Act*****"
+4 WRITE !,DGDUZ,?80-$LENGTH(DGSITE)/2,DGSITE
SET DGTY="WARD CENSUS LISTING"
+5 WRITE !
DO TIME^ADGUTIL
WRITE ?80-$LENGTH(DGTY)/2,DGTY,?70,"Page: ",DGPAGE
+6 SET Y=DT
XECUTE ^DD("DD")
WRITE !,Y
+7 SET DGWARD="*** "_DGW_" ***"
WRITE ?80-$LENGTH(DGWARD)/2,DGWARD
+8 WRITE !?80-$LENGTH(DGDATE)/2,DGDATE,!,DGLIN
+9 IF DGW'="SUMMARY"
WRITE !?3," Time",?20,"Patient Name",?50,"Chart #"
GOTO HD1
+10 WRITE !,"Ward",?15,"Beg Census Admits Net Transfers Discharges Ending Census"
HD1 SET DGLIN=""
SET $PIECE(DGLIN,"-",80)=""
WRITE !,DGLIN
+1 QUIT
