- 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
- 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
