- NURACE0 ;HIRMFO/RM-PATIENT CLASSIFICATION DRIVER ;4/15/88
- ;;4.0;NURSING SERVICE;**3**;Apr 25, 1997
- EN1 ; ENTRY FROM ROUTINES NURACEW1 or NURACEW
- Q:'$D(^DIC(213.9,1,"OFF")) Q:$P(^DIC(213.9,1,"OFF"),"^",1)=1
- S CLASSREV=0 G SELT1
- EN2 ; ENTRY FROM OPTION NURAPC-REVIND OR ROUTINE NURACEW
- Q:'$D(^DIC(213.9,1,"OFF")) Q:$P(^DIC(213.9,1,"OFF"),"^",1)=1
- S CLASSREV=1
- SELT1 ; SET USER NAME
- S IOP=ION D QUIT,^%ZIS W @IOF S U="^" K IOP
- S NURSUSER=$P(^VA(200,DUZ,0),"^",1)
- SELTLOP ;ENTER STAFF DATA
- S NURSNSW=0,NURSCKSW=0,NOREVSW=0,NURSRTSW=0,NASK=1
- I $D(NURSTABL) G:TABLSW=1 KILL S X="`"_+NURSTABL(TCNT),TABLSW=1,NASK=0
- S DIC(0)="EMZQ",NACT=1 D EN5^NURSCUTL G KILL:DFN'>0 D ^NURSAPCH
- I NURSX'="LEAVE"&(NURSX'="AWOL")&(NURSX'="OTH. FAC.") G AROUND
- STAT W !!," THIS PATIENT IS ",$S(NURSX="LEAVE":"ON "_NURSX,NURSX="AWOL":NURSX,NURSX="OTH. FAC.":"IN ANOTHER FACILITY",1:""),", DO YOU STILL WISH TO CLASSIFY"
- S %=2 D YN^DICN
- G KILL:%=-1,SELTLOP:%=2,AROUND:%=1
- W !!," ANSWER YES OR NO " G STAT
- AROUND D 1^VADPT S NURSNAM=VADM(1),SSN=VA("PID")
- S NURSRMBD=VAIN(5)
- S NAX=^NURSF(214,DFN,0)
- S NURSWARD=$S($D(NAX):$P(NAX,U,3),1:"")
- S NURSBS=$S($D(NAX):$P(NAX,U,4),1:"")
- D EN6^NURSCUTL S PADMDT=$P(VAIN(7),U),PADMDT=$S(PADMDT'="":$E(PADMDT,4,5)_"/"_$E(PADMDT,6,7)_"/"_$E(PADMDT,2,3),1:"")
- STARTIT ;CONTINUE CLASSIFICATION
- I NURSBS=""!(NURSWARD="") W $C(7),!!," BAD LOCATION/BED SECTION DATA-CANNOT CLASSIFY " G KILL
- S NURSBSF=$S($D(^NURSF(213.3,NURSBS,0)):$P(^(0),U,1),1:"")
- I NURSBS=8!(NURSBS=6)!(NURSBS=10) W !!,$C(7),"CANNOT CLASSIFY ",NURSBSF," PATIENTS " G KILL
- S NURSCLAS("CL")=1 D EN2^NURSCUTL
- A I NURSCLAS'>0 S (CLASSX,CONFIGX,USERX,FACTX,COMMENTX,USENO,FACTORS,DATEX)="" G STARTREV
- S NCX=$S($D(^NURSA(214.6,NURSCLAS,0)):^(0),1:""),NURSBS1=$P(NCX,"^",9)
- I NURSBS1="" W $C(7),"****BAD PREVIOUS CLASSIFICATION DATA CANNOT PROCESS THIS PATIENT****" Q
- I NURSBS'=NURSBS1 S (CLASSX,CONFIGX,USERX,FACTX,COMMENTX,USENO,FACTORS,DATEX)="",CLASSREV=0 G STARTREV
- S DATEX=$P(NCX,"^",1),CLASSX=$P(NCX,"^",3),CONFIGX=$P(NCX,"^",5)
- S:CONFIGX="C" CONFIGX="COMPUTER" S:CONFIGX="U" CONFIGX="USER"
- S FACTX="",FACTORS=$P(NCX,"^",4),USENO=$P(NCX,"^",6),COMMENTX=$P(NCX,"^",7),USERX=$P(^VA(200,USENO,0),"^",1)
- I FACTORS'="N/A" F I=1:1:$L(FACTORS) S:I=1 FACTX=$E(FACTORS,1) S:I'=1 FACTX=FACTX_","_$E(FACTORS,I)
- E S FACTX="N/A"
- STARTREV ; SET VARIABLES IF REVIEWING PATIENT RECORD
- D EN1^NURACE7
- G SELTLOP
- CHKJOB ;
- ; if acuity job did not run print warning, but do not stop user from
- ; classifying patients
- I $S('$D(^DIC(213.9,1,"DATE")):1,$P(^("DATE"),"^")'=DT:1,'$P(^("DATE"),"^",2):1,1:0) W !! D EN3^NURACE8
- Q
- KILL ;KILL CLASSREV VARIABLE
- K CLASSREV
- QUIT ;KILL LOCAL VARIABLES
- K %DT,ABORTSW,CAT,CHANGESW,NURSBS1,CK,CLASSX,COMMENTX,CONFIGX,DA,DATEX,DIC,DFN,NURS8SW,NURSCLAS,CHKVAR,FACT,FACTORS,FACTX,FCK,NURS5SW,NURS4SW,I,J,NOREVSW,REENTSW,NURSRVDT,NURSRTSW,NURSREV,NEWREV,NACT,NAX,NCX,NRX,NURSX,NURS11SW,TX,VAROOT
- K NS1,NURSA,NURSTRAN,NURSOLDC,NASK,FACT1 D KVAR^VADPT K VA
- K NURS9SW,NURSADM,NURSCKSW,NURSTCLS,NURMDSW,NWFCTSW,NXT,NURS1SW,OUTSW,PADMDT,NURSNAM,SSN,PREV,REVDATE,REVIEWER,REVNO,SAVEX,NURS7SW,NURS6SW,NURS10SW,NURS3SW,NURS13SW,NURSUSER,USENO,USERX,NURSBS,XCLAS,NURSWARD,NURSRMBD,NURSBSF,%,NPWARD
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURACE0 3270 printed Feb 18, 2025@23:45:18 Page 2
- NURACE0 ;HIRMFO/RM-PATIENT CLASSIFICATION DRIVER ;4/15/88
- +1 ;;4.0;NURSING SERVICE;**3**;Apr 25, 1997
- EN1 ; ENTRY FROM ROUTINES NURACEW1 or NURACEW
- +1 if '$DATA(^DIC(213.9,1,"OFF"))
- QUIT
- if $PIECE(^DIC(213.9,1,"OFF"),"^",1)=1
- QUIT
- +2 SET CLASSREV=0
- GOTO SELT1
- EN2 ; ENTRY FROM OPTION NURAPC-REVIND OR ROUTINE NURACEW
- +1 if '$DATA(^DIC(213.9,1,"OFF"))
- QUIT
- if $PIECE(^DIC(213.9,1,"OFF"),"^",1)=1
- QUIT
- +2 SET CLASSREV=1
- SELT1 ; SET USER NAME
- +1 SET IOP=ION
- DO QUIT
- DO ^%ZIS
- WRITE @IOF
- SET U="^"
- KILL IOP
- +2 SET NURSUSER=$PIECE(^VA(200,DUZ,0),"^",1)
- SELTLOP ;ENTER STAFF DATA
- +1 SET NURSNSW=0
- SET NURSCKSW=0
- SET NOREVSW=0
- SET NURSRTSW=0
- SET NASK=1
- +2 IF $DATA(NURSTABL)
- if TABLSW=1
- GOTO KILL
- SET X="`"_+NURSTABL(TCNT)
- SET TABLSW=1
- SET NASK=0
- +3 SET DIC(0)="EMZQ"
- SET NACT=1
- DO EN5^NURSCUTL
- if DFN'>0
- GOTO KILL
- DO ^NURSAPCH
- +4 IF NURSX'="LEAVE"&(NURSX'="AWOL")&(NURSX'="OTH. FAC.")
- GOTO AROUND
- STAT WRITE !!," THIS PATIENT IS ",$SELECT(NURSX="LEAVE":"ON "_NURSX,NURSX="AWOL":NURSX,NURSX="OTH. FAC.":"IN ANOTHER FACILITY",1:""),", DO YOU STILL WISH TO CLASSIFY"
- +1 SET %=2
- DO YN^DICN
- +2 if %=-1
- GOTO KILL
- if %=2
- GOTO SELTLOP
- if %=1
- GOTO AROUND
- +3 WRITE !!," ANSWER YES OR NO "
- GOTO STAT
- AROUND DO 1^VADPT
- SET NURSNAM=VADM(1)
- SET SSN=VA("PID")
- +1 SET NURSRMBD=VAIN(5)
- +2 SET NAX=^NURSF(214,DFN,0)
- +3 SET NURSWARD=$SELECT($DATA(NAX):$PIECE(NAX,U,3),1:"")
- +4 SET NURSBS=$SELECT($DATA(NAX):$PIECE(NAX,U,4),1:"")
- +5 DO EN6^NURSCUTL
- SET PADMDT=$PIECE(VAIN(7),U)
- SET PADMDT=$SELECT(PADMDT'="":$EXTRACT(PADMDT,4,5)_"/"_$EXTRACT(PADMDT,6,7)_"/"_$EXTRACT(PADMDT,2,3),1:"")
- STARTIT ;CONTINUE CLASSIFICATION
- +1 IF NURSBS=""!(NURSWARD="")
- WRITE $CHAR(7),!!," BAD LOCATION/BED SECTION DATA-CANNOT CLASSIFY "
- GOTO KILL
- +2 SET NURSBSF=$SELECT($DATA(^NURSF(213.3,NURSBS,0)):$PIECE(^(0),U,1),1:"")
- +3 IF NURSBS=8!(NURSBS=6)!(NURSBS=10)
- WRITE !!,$CHAR(7),"CANNOT CLASSIFY ",NURSBSF," PATIENTS "
- GOTO KILL
- +4 SET NURSCLAS("CL")=1
- DO EN2^NURSCUTL
- A IF NURSCLAS'>0
- SET (CLASSX,CONFIGX,USERX,FACTX,COMMENTX,USENO,FACTORS,DATEX)=""
- GOTO STARTREV
- +1 SET NCX=$SELECT($DATA(^NURSA(214.6,NURSCLAS,0)):^(0),1:"")
- SET NURSBS1=$PIECE(NCX,"^",9)
- +2 IF NURSBS1=""
- WRITE $CHAR(7),"****BAD PREVIOUS CLASSIFICATION DATA CANNOT PROCESS THIS PATIENT****"
- QUIT
- +3 IF NURSBS'=NURSBS1
- SET (CLASSX,CONFIGX,USERX,FACTX,COMMENTX,USENO,FACTORS,DATEX)=""
- SET CLASSREV=0
- GOTO STARTREV
- +4 SET DATEX=$PIECE(NCX,"^",1)
- SET CLASSX=$PIECE(NCX,"^",3)
- SET CONFIGX=$PIECE(NCX,"^",5)
- +5 if CONFIGX="C"
- SET CONFIGX="COMPUTER"
- if CONFIGX="U"
- SET CONFIGX="USER"
- +6 SET FACTX=""
- SET FACTORS=$PIECE(NCX,"^",4)
- SET USENO=$PIECE(NCX,"^",6)
- SET COMMENTX=$PIECE(NCX,"^",7)
- SET USERX=$PIECE(^VA(200,USENO,0),"^",1)
- +7 IF FACTORS'="N/A"
- FOR I=1:1:$LENGTH(FACTORS)
- if I=1
- SET FACTX=$EXTRACT(FACTORS,1)
- if I'=1
- SET FACTX=FACTX_","_$EXTRACT(FACTORS,I)
- +8 IF '$TEST
- SET FACTX="N/A"
- STARTREV ; SET VARIABLES IF REVIEWING PATIENT RECORD
- +1 DO EN1^NURACE7
- +2 GOTO SELTLOP
- CHKJOB ;
- +1 ; if acuity job did not run print warning, but do not stop user from
- +2 ; classifying patients
- +3 IF $SELECT('$DATA(^DIC(213.9,1,"DATE")):1,$PIECE(^("DATE"),"^")'=DT:1,'$PIECE(^("DATE"),"^",2):1,1:0)
- WRITE !!
- DO EN3^NURACE8
- +4 QUIT
- KILL ;KILL CLASSREV VARIABLE
- +1 KILL CLASSREV
- QUIT ;KILL LOCAL VARIABLES
- +1 KILL %DT,ABORTSW,CAT,CHANGESW,NURSBS1,CK,CLASSX,COMMENTX,CONFIGX,DA,DATEX,DIC,DFN,NURS8SW,NURSCLAS,CHKVAR,FACT,FACTORS,FACTX,FCK,NURS5SW,NURS4SW,I,J,NOREVSW,REENTSW,NURSRVDT,NURSRTSW,NURSREV,NEWREV,NACT,NAX,NCX,NRX,NURSX,NURS11SW,TX,VAROOT
- +2 KILL NS1,NURSA,NURSTRAN,NURSOLDC,NASK,FACT1
- DO KVAR^VADPT
- KILL VA
- +3 KILL NURS9SW,NURSADM,NURSCKSW,NURSTCLS,NURMDSW,NWFCTSW,NXT,NURS1SW,OUTSW,PADMDT,NURSNAM,SSN,PREV,REVDATE,REVIEWER,REVNO,SAVEX,NURS7SW,NURS6SW,NURS10SW,NURS3SW,NURS13SW,NURSUSER,USENO,USERX,NURSBS,XCLAS,NURSWARD,NURSRMBD,NURSBSF,%,NPWARD
- +4 QUIT