NURAAU1 ;HIRMFO/RM/MD-DRIVER FOR ACUITY COUNTS...(cont.) ;2/27/98 14:20
;;4.0;NURSING SERVICE;**1,7,9,14**;Apr 25, 1997
EN1 ; ENTRY TO CALCULATE PATIENT ACUITY FOR NURSING WARD NWARD.
I OUTSW G MID
S NURTYPE=0 F NWARD=NWARD(0):0 S NWARD=$O(^TMP($J,"NURCEN",NWARD)) Q:NWARD'>0 F DFN=DFN(0):0 S DFN=$O(^TMP($J,"NURCEN",NWARD,DFN)) Q:DFN'>0 W:'$D(ZTQUEUED) "." S $P(^DIC(213.9,1,"DATE"),U,3,4)=NWARD_U_DFN D AGAIN
S SHIFT="D" D HEMCOUNT^NURAAU3,RECOUNT^NURAAU3 S $P(^DIC(213.9,1,"DATE"),U,2)=1,$P(^("DATE"),U,3)=0,$P(^("DATE"),U,4)=0
MID Q:OUTSW(1) S NURTYPE=1,(NURCUTDT,NURCENDT)=RPTDATE_".2400" D ^NURSACEN ; Calculate hospital census at evening shift cutoff time (Midnight Acuity).
F NWARD=NWARD(1):0 S NWARD=$O(^TMP($J,"NURCEN",NWARD)) Q:NWARD'>0 F DFN=+DFN(1):0 S DFN=$O(^TMP($J,"NURCEN",NWARD,DFN)) Q:DFN'>0 W:'$D(ZTQUEUED) "." S $P(^DIC(213.9,1,"DATE"),U,7,8)=NWARD_U_DFN D AGAIN
S SHIFT="E" D HEMCOUNT^NURAAU3,RECOUNT^NURAAU3 S $P(^DIC(213.9,1,"DATE"),U,6)=1,$P(^("DATE"),U,7)=0,$P(^("DATE"),U,8)=0
Q
AGAIN ; CHECK PATIENT RECORD IS TO SEE IF VALID
K CLASDT,NCWARD
S BEDSECT=+$O(^NURSF(213.3,"B","DOMICILIARY",""))
I $D(^NURSF(211.4,"ABS",BEDSECT,NWARD)) S SHIFT=$S(NURTYPE=0:"D",1:"E"),NBEDSECT=$E("00"_BEDSECT,1+$L(BEDSECT),2+$L(BEDSECT)),NCWARD=NWARD D DOMRECNT^NURAAU2 Q
S CHGSW=0 D EN6^NURSCUTL S NURSCLAS("CL")=0 D EN2^NURSCUTL S NURSADM=$S(VAIN(1)="":"",1:$P(VAIN(7),U))
I NURSADM="" S NURSADM=$P($G(^NURSF(214,DFN,0)),U,5) I NURSADM="" S NMESS="NOT ADMITTED",CLSDATE="" S:'NURTYPE NERR=NMESS S:NURTYPE NERR(1)=NMESS G WRITE
B1 I NURSCLAS="" S NMESS="NOT CLASSIFIED",CLSDATE="" S:'NURTYPE NERR=NMESS S:NURTYPE NERR(1)=NMESS G WRITE
S CLASDT=9999999-$P(^NURSA(214.6,NURSCLAS,0),U) I NURTYPE,(((9999999-CLASDT)'<RPTDATE)&((9999999-CLASDT)'>(.24+RPTDATE))) G B2
I 'NURTYPE,(((9999999-CLASDT)'<RPTDATE)&((9999999-CLASDT)'>(.15+RPTDATE))) G B2
I NURSADM>$P(^NURSA(214.6,NURSCLAS,0),U) S NMESS="NOT CLASSIFIED",CLSDATE="" S:'NURTYPE NERR=NMESS S:NURTYPE NERR(1)=NMESS G WRITE
I (9999999-CLASDT)<RPTDATE S NMESS="CLASS. NOT CURRENT",CLSDATE=9999999-CLASDT S:'NURTYPE NERR=NMESS S:NURTYPE NERR(1)=NMESS G WRITE
S CHGSW=1,NURSLCS=9999999-CLASDT
B S CLASDT=$O(^NURSA(214.6,"AA",DFN,CLASDT)) G B0:CLASDT="",B:((9999999-CLASDT)>(.15+RPTDATE))
B0 I CLASDT'>0!((9999999-CLASDT)<RPTDATE) S:'NURTYPE NERR="NOT CLASS. BY 3 PM" S:NURTYPE NERR(1)="" S CLSDATE=NURSLCS G WRITE
S NURSCLAS=$O(^NURSA(214.6,"AA",DFN,CLASDT,0)) I '($P($G(^NURSA(214.6,+NURSCLAS,0)),U,8)=NWARD) S:'NURTYPE NERR="NO CLASS./NEW WARD" S:NURTYPE NERR(1)="" S CLSDATE=NURSLCS G WRITE
B2 S NURSCLAS=$O(^NURSA(214.6,"AA",DFN,CLASDT,0)) F CHKVAR=0:0 S CHKVAR=$O(^(NURSCLAS)) Q:CHKVAR'>0 S X=$D(^NURSA(214.6,CHKVAR,0)) S:X NURSCLAS=CHKVAR I 'X K ^NURSA(214.6,"AA",DFN,CLASDT,CHKVAR)
I NURSCLAS,'$D(^NURSA(214.6,NURSCLAS,0)) K ^NURSA(214.6,"AA",DFN,CLASDT,NURSCLAS) G B
I NURSCLAS="" S NMESS="BAD CLASS. XREF",CLSDATE=9999999-CLASDT S:'NURTYPE NERR=NMESS S:NURTYPE NERR(1)=NMESS G WRITE
ANYCLASS ; CHECK TO SEE PATIENT HAS BEEN CLASSIFIED THAT DAY
S DATECL=$G(^NURSA(214.6,NURSCLAS,0))
S CLSDATE=$P(DATECL,U)
S NCWARD=$P(DATECL,U,8) G:NCWARD="" A
I NCWARD'=NWARD S NMESS="NO CLASS./NEW WARD" S NURSCLAS("CL")=2,NURSCLAS("WARD")=NWARD,NURSCLAS("DATE")=RPTDATE D EN2^NURSCUTL S:NURTYPE NERR(1)=NMESS S:'NURSCLAS NERR=NMESS G:NURSCLAS B1 G:NURSCLAS="" WRITE
S CLASS=$P(DATECL,U,3),BEDSECT=$P(DATECL,U,9)
A I (CLASS="")!(BEDSECT="")!(NCWARD="") S NMESS="BAD DATA" S:'NURTYPE NERR=NMESS S:NURTYPE NERR(1)=NMESS G WRITE
NOCLASS ; ADD PATIENT CLASSIFICATION TO ACUITY COUNTS
I $L(BEDSECT)=1 S BEDSECT="0"_BEDSECT
S NCWARD=NWARD,SHIFT=$S(NURTYPE=0:"D",1:"E") F I=1:1:5 S NCLASS(I)=0
S NCLASS(CLASS)=1
I $P($G(^NURSF(211.4,NCWARD,1)),U)="A" D FINALLY^NURAAU0
Q
;
WRITE ; WRITE EXCEPTION LINE
D ^NURSAPCH,EXCP^NURAAU3
K NMESS,NERR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURAAU1 3870 printed Nov 22, 2024@17:28:52 Page 2
NURAAU1 ;HIRMFO/RM/MD-DRIVER FOR ACUITY COUNTS...(cont.) ;2/27/98 14:20
+1 ;;4.0;NURSING SERVICE;**1,7,9,14**;Apr 25, 1997
EN1 ; ENTRY TO CALCULATE PATIENT ACUITY FOR NURSING WARD NWARD.
+1 IF OUTSW
GOTO MID
+2 SET NURTYPE=0
FOR NWARD=NWARD(0):0
SET NWARD=$ORDER(^TMP($JOB,"NURCEN",NWARD))
if NWARD'>0
QUIT
FOR DFN=DFN(0):0
SET DFN=$ORDER(^TMP($JOB,"NURCEN",NWARD,DFN))
if DFN'>0
QUIT
if '$DATA(ZTQUEUED)
WRITE "."
SET $PIECE(^DIC(213.9,1,"DATE"),U,3,4)=NWARD_U_DFN
DO AGAIN
+3 SET SHIFT="D"
DO HEMCOUNT^NURAAU3
DO RECOUNT^NURAAU3
SET $PIECE(^DIC(213.9,1,"DATE"),U,2)=1
SET $PIECE(^("DATE"),U,3)=0
SET $PIECE(^("DATE"),U,4)=0
MID ; Calculate hospital census at evening shift cutoff time (Midnight Acuity).
if OUTSW(1)
QUIT
SET NURTYPE=1
SET (NURCUTDT,NURCENDT)=RPTDATE_".2400"
DO ^NURSACEN
+1 FOR NWARD=NWARD(1):0
SET NWARD=$ORDER(^TMP($JOB,"NURCEN",NWARD))
if NWARD'>0
QUIT
FOR DFN=+DFN(1):0
SET DFN=$ORDER(^TMP($JOB,"NURCEN",NWARD,DFN))
if DFN'>0
QUIT
if '$DATA(ZTQUEUED)
WRITE "."
SET $PIECE(^DIC(213.9,1,"DATE"),U,7,8)=NWARD_U_DFN
DO AGAIN
+2 SET SHIFT="E"
DO HEMCOUNT^NURAAU3
DO RECOUNT^NURAAU3
SET $PIECE(^DIC(213.9,1,"DATE"),U,6)=1
SET $PIECE(^("DATE"),U,7)=0
SET $PIECE(^("DATE"),U,8)=0
+3 QUIT
AGAIN ; CHECK PATIENT RECORD IS TO SEE IF VALID
+1 KILL CLASDT,NCWARD
+2 SET BEDSECT=+$ORDER(^NURSF(213.3,"B","DOMICILIARY",""))
+3 IF $DATA(^NURSF(211.4,"ABS",BEDSECT,NWARD))
SET SHIFT=$SELECT(NURTYPE=0:"D",1:"E")
SET NBEDSECT=$EXTRACT("00"_BEDSECT,1+$LENGTH(BEDSECT),2+$LENGTH(BEDSECT))
SET NCWARD=NWARD
DO DOMRECNT^NURAAU2
QUIT
+4 SET CHGSW=0
DO EN6^NURSCUTL
SET NURSCLAS("CL")=0
DO EN2^NURSCUTL
SET NURSADM=$SELECT(VAIN(1)="":"",1:$PIECE(VAIN(7),U))
+5 IF NURSADM=""
SET NURSADM=$PIECE($GET(^NURSF(214,DFN,0)),U,5)
IF NURSADM=""
SET NMESS="NOT ADMITTED"
SET CLSDATE=""
if 'NURTYPE
SET NERR=NMESS
if NURTYPE
SET NERR(1)=NMESS
GOTO WRITE
B1 IF NURSCLAS=""
SET NMESS="NOT CLASSIFIED"
SET CLSDATE=""
if 'NURTYPE
SET NERR=NMESS
if NURTYPE
SET NERR(1)=NMESS
GOTO WRITE
+1 SET CLASDT=9999999-$PIECE(^NURSA(214.6,NURSCLAS,0),U)
IF NURTYPE
IF (((9999999-CLASDT)'<RPTDATE)&((9999999-CLASDT)'>(.24+RPTDATE)))
GOTO B2
+2 IF 'NURTYPE
IF (((9999999-CLASDT)'<RPTDATE)&((9999999-CLASDT)'>(.15+RPTDATE)))
GOTO B2
+3 IF NURSADM>$PIECE(^NURSA(214.6,NURSCLAS,0),U)
SET NMESS="NOT CLASSIFIED"
SET CLSDATE=""
if 'NURTYPE
SET NERR=NMESS
if NURTYPE
SET NERR(1)=NMESS
GOTO WRITE
+4 IF (9999999-CLASDT)<RPTDATE
SET NMESS="CLASS. NOT CURRENT"
SET CLSDATE=9999999-CLASDT
if 'NURTYPE
SET NERR=NMESS
if NURTYPE
SET NERR(1)=NMESS
GOTO WRITE
+5 SET CHGSW=1
SET NURSLCS=9999999-CLASDT
B SET CLASDT=$ORDER(^NURSA(214.6,"AA",DFN,CLASDT))
if CLASDT=""
GOTO B0
if ((9999999-CLASDT)>(.15+RPTDATE))
GOTO B
B0 IF CLASDT'>0!((9999999-CLASDT)<RPTDATE)
if 'NURTYPE
SET NERR="NOT CLASS. BY 3 PM"
if NURTYPE
SET NERR(1)=""
SET CLSDATE=NURSLCS
GOTO WRITE
+1 SET NURSCLAS=$ORDER(^NURSA(214.6,"AA",DFN,CLASDT,0))
IF '($PIECE($GET(^NURSA(214.6,+NURSCLAS,0)),U,8)=NWARD)
if 'NURTYPE
SET NERR="NO CLASS./NEW WARD"
if NURTYPE
SET NERR(1)=""
SET CLSDATE=NURSLCS
GOTO WRITE
B2 SET NURSCLAS=$ORDER(^NURSA(214.6,"AA",DFN,CLASDT,0))
FOR CHKVAR=0:0
SET CHKVAR=$ORDER(^(NURSCLAS))
if CHKVAR'>0
QUIT
SET X=$DATA(^NURSA(214.6,CHKVAR,0))
if X
SET NURSCLAS=CHKVAR
IF 'X
KILL ^NURSA(214.6,"AA",DFN,CLASDT,CHKVAR)
+1 IF NURSCLAS
IF '$DATA(^NURSA(214.6,NURSCLAS,0))
KILL ^NURSA(214.6,"AA",DFN,CLASDT,NURSCLAS)
GOTO B
+2 IF NURSCLAS=""
SET NMESS="BAD CLASS. XREF"
SET CLSDATE=9999999-CLASDT
if 'NURTYPE
SET NERR=NMESS
if NURTYPE
SET NERR(1)=NMESS
GOTO WRITE
ANYCLASS ; CHECK TO SEE PATIENT HAS BEEN CLASSIFIED THAT DAY
+1 SET DATECL=$GET(^NURSA(214.6,NURSCLAS,0))
+2 SET CLSDATE=$PIECE(DATECL,U)
+3 SET NCWARD=$PIECE(DATECL,U,8)
if NCWARD=""
GOTO A
+4 IF NCWARD'=NWARD
SET NMESS="NO CLASS./NEW WARD"
SET NURSCLAS("CL")=2
SET NURSCLAS("WARD")=NWARD
SET NURSCLAS("DATE")=RPTDATE
DO EN2^NURSCUTL
if NURTYPE
SET NERR(1)=NMESS
if 'NURSCLAS
SET NERR=NMESS
if NURSCLAS
GOTO B1
if NURSCLAS=""
GOTO WRITE
+5 SET CLASS=$PIECE(DATECL,U,3)
SET BEDSECT=$PIECE(DATECL,U,9)
A IF (CLASS="")!(BEDSECT="")!(NCWARD="")
SET NMESS="BAD DATA"
if 'NURTYPE
SET NERR=NMESS
if NURTYPE
SET NERR(1)=NMESS
GOTO WRITE
NOCLASS ; ADD PATIENT CLASSIFICATION TO ACUITY COUNTS
+1 IF $LENGTH(BEDSECT)=1
SET BEDSECT="0"_BEDSECT
+2 SET NCWARD=NWARD
SET SHIFT=$SELECT(NURTYPE=0:"D",1:"E")
FOR I=1:1:5
SET NCLASS(I)=0
+3 SET NCLASS(CLASS)=1
+4 IF $PIECE($GET(^NURSF(211.4,NCWARD,1)),U)="A"
DO FINALLY^NURAAU0
+5 QUIT
+6 ;
WRITE ; WRITE EXCEPTION LINE
+1 DO ^NURSAPCH
DO EXCP^NURAAU3
+2 KILL NMESS,NERR
+3 QUIT
