NURACE4 ;HIRMFO/RM-PATIENT CLASSIFICATION PSYCHIATRIC ;NOVEMBER 17, 1986
;;4.0;NURSING SERVICE;;Apr 25, 1997
EN1 ;ENTER IN CLASSIFICATION FACTORS
S ABORTSW=0,CHANGESW=0,NURS1SW=0,NURS5SW=0,NWFCTSW=0,PREV=""
I FACT["?" D EN1^NURACE3 S REENTSW=1 Q
F I=1:1:$L(FACT) S:(($A(FACT,I)<65)!($E(FACT,I)'?1A)!($A(FACT,I)>75)) ABORTSW=1 Q:ABORTSW=1 S PREV=$E(FACT,I) D EN2^NURACE8 Q:NURS1SW!NURS5SW!NWFCTSW S FACT($E(FACT,I))=0
I ABORTSW=1 W *7," *** BAD ENTRY - TRY AGAIN ***" S REENTSW=1 Q
S (FACT1,NXT)="" F I=0:0 S NXT=$O(FACT(NXT)) Q:NXT="" S FACT1=FACT1_NXT
I ((FACT="")&(FACTORS="")) W !,*7,"**** NO FACTORS ENTERED - CLASSIFICATION NOT UPDATED ***" H 3 S OUTSW=1 Q
I NURS1SW=1 W !,*7,"*** FACTORS A,B,C or D CANNOT BE USED TOGETHER ***" S REENTSW=1 Q
I NURS5SW=1 W !,*7,"*** FACTORS E,F,G or H CANNOT BE USED TOGETHER ***" S REENTSW=1 Q
I NWFCTSW=1 W !,*7,"*** FACTOR ",PREV," CANNOT BE USED WITH ",FCK," ***" S REENTSW=1 Q
I ((FACT="")!(FACT=FACTORS)) S NURSCKSW=1 G EN2
I ((FACT'["A")&(FACT'["B")&(FACT'["C")&(FACT'["D")) W !,*7,"*** YOU MUST PICK ONE OF THE FIRST FOUR FACTORS A,B,C or D ***" S REENTSW=1 Q
I ((FACT'["E")&(FACT'["F")&(FACT'["G")&(FACT'["H")) W !,*7,"*** YOU MUST PICK ONE OF THE FOUR FACTORS E,F,G or H ***" S REENTSW=1 Q
S FACTORS=FACT F I=1:1:$L(FACT) S:I=1 FACTX=$E(FACT,1) S:I'=1 FACTX=FACTX_","_$E(FACT,I)
S CHANGESW=1
EN2 ;DETERMINE NEW CLASSIFICATION
S (CAT(1),CAT(2),CAT(3),CAT(4))=0
F I="A","E" S:FACTORS[I CAT(1)=CAT(1)+1
F I="A","B","E","F","G" S:FACTORS[I CAT(2)=CAT(2)+1
F I="A","B","C","E","F","G","H" S:FACTORS[I CAT(3)=CAT(3)+1
F I="A","B","C","D","E","F","G","H" S:FACTORS[I CAT(4)=CAT(4)+1
I FACTORS["I" S CAT(4)=CAT(4)+1
E S CAT(1)=CAT(1)+1,CAT(2)=CAT(2)+1,CAT(3)=CAT(3)+1,CAT(4)=CAT(4)+1
I FACTORS["J" S CAT(3)=CAT(3)+1,CAT(4)=CAT(4)+1
E S CAT(1)=CAT(1)+1,CAT(2)=CAT(2)+1,CAT(3)=CAT(3)+1,CAT(4)=CAT(4)+1
I FACTORS["K" S CAT(4)=CAT(4)+1
E S CAT(1)=CAT(1)+1,CAT(2)=CAT(2)+1,CAT(3)=CAT(3)+1,CAT(4)=CAT(4)+1
S CAT(1)=CAT(1)+.5,CAT(2)=CAT(2)+.4,CAT(3)=CAT(3)+.3
I ((CAT(1)>CAT(2))&(CAT(1)>CAT(3))&(CAT(1)>CAT(4))) S CLASSX=1 G CHKCLASS
I (((CAT(2)>CAT(1))!(CAT(2)=CAT(1)))&(CAT(2)>CAT(3))&(CAT(2)>CAT(4))) S CLASSX=2 G CHKCLASS
I (((CAT(3)>CAT(1))!(CAT(3)=CAT(1)))&((CAT(3)>CAT(2))!(CAT(3)=CAT(2)))&(CAT(3)>CAT(4))) S CLASSX=3 G CHKCLASS
S CLASSX=4
CHKCLASS ;ENTER NEW CLASSIFICATION IF DESIRED
Q:NURSNSW=1
I $D(XCLAS) I ((NURSCKSW=1)&(CLASSX=XCLAS)) S CHANGESW=1
CHKCLAS1 ;
W !,"Enter Classification: " W:(CLASSX'="") CLASSX,"//" R X:DTIME S X=$E(X,1,2)
I (X="^")!('$T) D EN4^NURACE8 S OUTSW=1 Q
I X["?" W !,"ANSWER WITH A NUMBER BETWEEN 1 AND 4" G CHKCLAS1
I $L(X)=0 S:CHANGESW=1 CONFIGX="COMPUTER" Q
I (($L(X)>1)!(X?1A)!(X<1)!(X>4)) W *7," *** BAD ENTRY - TRY AGAIN ***" G CHKCLASS
I X=CLASSX S:CHANGESW=1 CONFIGX="COMPUTER" Q
S CHANGESW=1,CLASSX=X,CONFIGX="USER"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURACE4 2897 printed Nov 22, 2024@17:29 Page 2
NURACE4 ;HIRMFO/RM-PATIENT CLASSIFICATION PSYCHIATRIC ;NOVEMBER 17, 1986
+1 ;;4.0;NURSING SERVICE;;Apr 25, 1997
EN1 ;ENTER IN CLASSIFICATION FACTORS
+1 SET ABORTSW=0
SET CHANGESW=0
SET NURS1SW=0
SET NURS5SW=0
SET NWFCTSW=0
SET PREV=""
+2 IF FACT["?"
DO EN1^NURACE3
SET REENTSW=1
QUIT
+3 FOR I=1:1:$LENGTH(FACT)
if (($ASCII(FACT,I)<65)!($EXTRACT(FACT,I)'?1A)!($ASCII(FACT,I)>75))
SET ABORTSW=1
if ABORTSW=1
QUIT
SET PREV=$EXTRACT(FACT,I)
DO EN2^NURACE8
if NURS1SW!NURS5SW!NWFCTSW
QUIT
SET FACT($EXTRACT(FACT,I))=0
+4 IF ABORTSW=1
WRITE *7," *** BAD ENTRY - TRY AGAIN ***"
SET REENTSW=1
QUIT
+5 SET (FACT1,NXT)=""
FOR I=0:0
SET NXT=$ORDER(FACT(NXT))
if NXT=""
QUIT
SET FACT1=FACT1_NXT
+6 IF ((FACT="")&(FACTORS=""))
WRITE !,*7,"**** NO FACTORS ENTERED - CLASSIFICATION NOT UPDATED ***"
HANG 3
SET OUTSW=1
QUIT
+7 IF NURS1SW=1
WRITE !,*7,"*** FACTORS A,B,C or D CANNOT BE USED TOGETHER ***"
SET REENTSW=1
QUIT
+8 IF NURS5SW=1
WRITE !,*7,"*** FACTORS E,F,G or H CANNOT BE USED TOGETHER ***"
SET REENTSW=1
QUIT
+9 IF NWFCTSW=1
WRITE !,*7,"*** FACTOR ",PREV," CANNOT BE USED WITH ",FCK," ***"
SET REENTSW=1
QUIT
+10 IF ((FACT="")!(FACT=FACTORS))
SET NURSCKSW=1
GOTO EN2
+11 IF ((FACT'["A")&(FACT'["B")&(FACT'["C")&(FACT'["D"))
WRITE !,*7,"*** YOU MUST PICK ONE OF THE FIRST FOUR FACTORS A,B,C or D ***"
SET REENTSW=1
QUIT
+12 IF ((FACT'["E")&(FACT'["F")&(FACT'["G")&(FACT'["H"))
WRITE !,*7,"*** YOU MUST PICK ONE OF THE FOUR FACTORS E,F,G or H ***"
SET REENTSW=1
QUIT
+13 SET FACTORS=FACT
FOR I=1:1:$LENGTH(FACT)
if I=1
SET FACTX=$EXTRACT(FACT,1)
if I'=1
SET FACTX=FACTX_","_$EXTRACT(FACT,I)
+14 SET CHANGESW=1
EN2 ;DETERMINE NEW CLASSIFICATION
+1 SET (CAT(1),CAT(2),CAT(3),CAT(4))=0
+2 FOR I="A","E"
if FACTORS[I
SET CAT(1)=CAT(1)+1
+3 FOR I="A","B","E","F","G"
if FACTORS[I
SET CAT(2)=CAT(2)+1
+4 FOR I="A","B","C","E","F","G","H"
if FACTORS[I
SET CAT(3)=CAT(3)+1
+5 FOR I="A","B","C","D","E","F","G","H"
if FACTORS[I
SET CAT(4)=CAT(4)+1
+6 IF FACTORS["I"
SET CAT(4)=CAT(4)+1
+7 IF '$TEST
SET CAT(1)=CAT(1)+1
SET CAT(2)=CAT(2)+1
SET CAT(3)=CAT(3)+1
SET CAT(4)=CAT(4)+1
+8 IF FACTORS["J"
SET CAT(3)=CAT(3)+1
SET CAT(4)=CAT(4)+1
+9 IF '$TEST
SET CAT(1)=CAT(1)+1
SET CAT(2)=CAT(2)+1
SET CAT(3)=CAT(3)+1
SET CAT(4)=CAT(4)+1
+10 IF FACTORS["K"
SET CAT(4)=CAT(4)+1
+11 IF '$TEST
SET CAT(1)=CAT(1)+1
SET CAT(2)=CAT(2)+1
SET CAT(3)=CAT(3)+1
SET CAT(4)=CAT(4)+1
+12 SET CAT(1)=CAT(1)+.5
SET CAT(2)=CAT(2)+.4
SET CAT(3)=CAT(3)+.3
+13 IF ((CAT(1)>CAT(2))&(CAT(1)>CAT(3))&(CAT(1)>CAT(4)))
SET CLASSX=1
GOTO CHKCLASS
+14 IF (((CAT(2)>CAT(1))!(CAT(2)=CAT(1)))&(CAT(2)>CAT(3))&(CAT(2)>CAT(4)))
SET CLASSX=2
GOTO CHKCLASS
+15 IF (((CAT(3)>CAT(1))!(CAT(3)=CAT(1)))&((CAT(3)>CAT(2))!(CAT(3)=CAT(2)))&(CAT(3)>CAT(4)))
SET CLASSX=3
GOTO CHKCLASS
+16 SET CLASSX=4
CHKCLASS ;ENTER NEW CLASSIFICATION IF DESIRED
+1 if NURSNSW=1
QUIT
+2 IF $DATA(XCLAS)
IF ((NURSCKSW=1)&(CLASSX=XCLAS))
SET CHANGESW=1
CHKCLAS1 ;
+1 WRITE !,"Enter Classification: "
if (CLASSX'="")
WRITE CLASSX,"//"
READ X:DTIME
SET X=$EXTRACT(X,1,2)
+2 IF (X="^")!('$TEST)
DO EN4^NURACE8
SET OUTSW=1
QUIT
+3 IF X["?"
WRITE !,"ANSWER WITH A NUMBER BETWEEN 1 AND 4"
GOTO CHKCLAS1
+4 IF $LENGTH(X)=0
if CHANGESW=1
SET CONFIGX="COMPUTER"
QUIT
+5 IF (($LENGTH(X)>1)!(X?1A)!(X<1)!(X>4))
WRITE *7," *** BAD ENTRY - TRY AGAIN ***"
GOTO CHKCLASS
+6 IF X=CLASSX
if CHANGESW=1
SET CONFIGX="COMPUTER"
QUIT
+7 SET CHANGESW=1
SET CLASSX=X
SET CONFIGX="USER"
+8 QUIT
