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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURSACEN 2033 printed Oct 16, 2024@18:22:05 Page 2
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
