- NURSACEN ;HIRMFO/RM,FT-PATIENT CENSUS CALCULATION ;4/30/96 15:42
- ;;4.0;NURSING SERVICE;;Apr 25, 1997;
- CALC ; CALCULATE PATIENT CENSUS FOR NURCENDT=DATE/TIME OF CENSUS
- ; NURCUTDT=$S(D/T FOR CUTOFF TXFR DATE OR 0 FOR NO CUTOFF)
- ; RETURNS ^TMP($J,"NURCEN",NLOC,DFN)=""
- N DFN,NURSADM,NURSDT,NURSI,NURSWD,NLOC,VAIN
- K ^TMP($J,"NURCEN"),^TMP($J,"NURDFN")
- S NURSWD="" F NURSI=0:0 S NURSWD=$O(^DPT("CN",NURSWD)) Q:NURSWD="" F DFN=0:0 S DFN=$O(^DPT("CN",NURSWD,DFN)) Q:DFN'>0 W:$E(IOST)="C" "." D IFADM
- F NURSDT(0)=(NURCENDT-.0000001):0 S NURSDT(0)=$O(^DGPM("AMV3",NURSDT(0))) Q:NURSDT(0)'>0 F DFN=0:0 S DFN=$O(^DGPM("AMV3",NURSDT(0),DFN)) Q:DFN'>0 W:$E(IOST)="C" "." D IFDIS
- K ^TMP($J,"NURDFN") D KVAR^VADPT
- Q
- IFADM ; CHECK TO SEE IF AN ADMISSION EXISTS FROM NURCENDT< ADMISSION < NOW
- S NURSDT=0 D CALCADM I NURSADM F NURSDT=$P(NURSADM,"^",2):0 S NURSDT=$O(^DGPM("ATID3",DFN,NURSDT)) Q:NURSDT'>0!(NURSDT>(9999999-NURCENDT)) S NURSADM=0
- I 'NURSADM D STUTL
- Q
- IFDIS ; CHECK TO SEE IF A DISCHARGE EXISTS BETWEEN CENSUS DATE AND NOW
- I '$D(^TMP($J,"NURDFN",DFN)) S NURSDT=9999999-NURSDT(0) D CALCADM S ^TMP($J,"NURDFN",DFN)="" I 'NURSADM D STUTL
- Q
- CALCADM ;
- S NURSADM=0 F NURSDT=NURSDT:0 S NURSDT=$O(^DGPM("ATID1",DFN,NURSDT)) Q:NURSDT'>0!(NURSDT>(9999999-NURCENDT)) S NURSADM=$O(^DGPM("ATID1",DFN,NURSDT,0))_"^"_NURSDT
- Q
- STUTL ; SETS NLOC=NURSING LOCATION CORR. TO PT. LOC. AT NURCENDT.
- W:$D(NURSMAN) "." S VAINDT=NURCENDT D NLOC Q:'NLOC
- I $G(NURCUTDT) D IFTXFR Q:'NLOC
- S ^TMP($J,"NURCEN",NLOC,DFN)=""
- Q
- NLOC ; GET NURSING LOCATION
- D INP^VADPT
- I 'VAIN(6) S NLOC=0 Q
- F NLOC=0:0 S NLOC=$O(^NURSF(211.4,"C",+VAIN(4),NLOC)) Q:$S(NLOC'>0:1,'$D(^NURSF(211.4,NLOC,1)):0,$P(^(1),U)="A":1,1:0)
- Q
- IFTXFR ; FIND IF PATIENT TRANSFERRED TO DIFFERENT NURSING LOCATION BETWEEN
- ; A CERTAIN CUTOFF DATE AND NURCENDT
- S NLOC(0)=NLOC
- F NDATE=(9999999-NURCENDT):0 S NDATE=$O(^DGPM("ATID2",DFN,NDATE)) Q:(NDATE<(9999999-NURCUTDT))!(NDATE'>0) S VAINDT=NURCUTDT D NLOC Q
- S:'NLOC NLOC=NLOC(0)
- Q
- NURSACEN ;HIRMFO/RM,FT-PATIENT CENSUS CALCULATION ;4/30/96 15:42
- +1 ;;4.0;NURSING SERVICE;;Apr 25, 1997;
- CALC ; CALCULATE PATIENT CENSUS FOR NURCENDT=DATE/TIME OF CENSUS
- +1 ; NURCUTDT=$S(D/T FOR CUTOFF TXFR DATE OR 0 FOR NO CUTOFF)
- +2 ; RETURNS ^TMP($J,"NURCEN",NLOC,DFN)=""
- +3 NEW DFN,NURSADM,NURSDT,NURSI,NURSWD,NLOC,VAIN
- +4 KILL ^TMP($JOB,"NURCEN"),^TMP($JOB,"NURDFN")
- +5 SET NURSWD=""
- FOR NURSI=0:0
- SET NURSWD=$ORDER(^DPT("CN",NURSWD))
- IF NURSWD=""
- QUIT
- FOR DFN=0:0
- SET DFN=$ORDER(^DPT("CN",NURSWD,DFN))
- IF DFN'>0
- QUIT
- IF $EXTRACT(IOST)="C"
- WRITE "."
- DO IFADM
- +6 FOR NURSDT(0)=(NURCENDT-.0000001):0
- SET NURSDT(0)=$ORDER(^DGPM("AMV3",NURSDT(0)))
- IF NURSDT(0)'>0
- QUIT
- FOR DFN=0:0
- SET DFN=$ORDER(^DGPM("AMV3",NURSDT(0),DFN))
- IF DFN'>0
- QUIT
- IF $EXTRACT(IOST)="C"
- WRITE "."
- DO IFDIS
- +7 KILL ^TMP($JOB,"NURDFN")
- DO KVAR^VADPT
- +8 QUIT
- IFADM ; CHECK TO SEE IF AN ADMISSION EXISTS FROM NURCENDT< ADMISSION < NOW
- +1 SET NURSDT=0
- DO CALCADM
- IF NURSADM
- FOR NURSDT=$PIECE(NURSADM,"^",2):0
- SET NURSDT=$ORDER(^DGPM("ATID3",DFN,NURSDT))
- IF NURSDT'>0!(NURSDT>(9999999-NURCENDT))
- QUIT
- SET NURSADM=0
- +2 IF 'NURSADM
- DO STUTL
- +3 QUIT
- IFDIS ; CHECK TO SEE IF A DISCHARGE EXISTS BETWEEN CENSUS DATE AND NOW
- +1 IF '$DATA(^TMP($JOB,"NURDFN",DFN))
- SET NURSDT=9999999-NURSDT(0)
- DO CALCADM
- SET ^TMP($JOB,"NURDFN",DFN)=""
- IF 'NURSADM
- DO STUTL
- +2 QUIT
- CALCADM ;
- +1 SET NURSADM=0
- FOR NURSDT=NURSDT:0
- SET NURSDT=$ORDER(^DGPM("ATID1",DFN,NURSDT))
- IF NURSDT'>0!(NURSDT>(9999999-NURCENDT))
- QUIT
- SET NURSADM=$ORDER(^DGPM("ATID1",DFN,NURSDT,0))_"^"_NURSDT
- +2 QUIT
- STUTL ; SETS NLOC=NURSING LOCATION CORR. TO PT. LOC. AT NURCENDT.
- +1 IF $DATA(NURSMAN)
- WRITE "."
- SET VAINDT=NURCENDT
- DO NLOC
- IF 'NLOC
- QUIT
- +2 IF $GET(NURCUTDT)
- DO IFTXFR
- IF 'NLOC
- QUIT
- +3 SET ^TMP($JOB,"NURCEN",NLOC,DFN)=""
- +4 QUIT
- NLOC ; GET NURSING LOCATION
- +1 DO INP^VADPT
- +2 IF 'VAIN(6)
- SET NLOC=0
- QUIT
- +3 FOR NLOC=0:0
- SET NLOC=$ORDER(^NURSF(211.4,"C",+VAIN(4),NLOC))
- IF $SELECT(NLOC'>0
- QUIT
- +4 QUIT
- IFTXFR ; FIND IF PATIENT TRANSFERRED TO DIFFERENT NURSING LOCATION BETWEEN
- +1 ; A CERTAIN CUTOFF DATE AND NURCENDT
- +2 SET NLOC(0)=NLOC
- +3 FOR NDATE=(9999999-NURCENDT):0
- SET NDATE=$ORDER(^DGPM("ATID2",DFN,NDATE))
- IF (NDATE<(9999999-NURCUTDT))!(NDATE'>0)
- QUIT
- SET VAINDT=NURCUTDT
- DO NLOC
- QUIT
- +4 IF 'NLOC
- SET NLOC=NLOC(0)
- +5 QUIT
