- 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