NURSACEN.m

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 ---NURSACEN   2033     printed  Apr 09, 2024@21:24:27                                                                                                                                                                                                    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