NURACE9 ;HIRMFO/MD-PATIENT CLASSIFICATION MEDICAL (SCI) ;7/89
;;4.0;NURSING SERVICE;;Apr 25, 1997
EN1 ;VALIDATE SCI FACTORS
S (ABORTSW,CHANGESW,NURS1SW,NURS3SW,NURS5SW,NURS7SW,NURS9SW,NURS11SW,NURS13SW)=0
I FACT["?" D EN5^NURACE3 S REENTSW=1 Q
F I=1:1:$L(FACT) S:(($E(FACT,I)'?1A)!($A(FACT,I)<65)!($A(FACT,I)>76)) ABORTSW=1 Q:ABORTSW=1 S FACT($E(FACT,I))=0
I ABORTSW=1 W $C(7)," *** BAD ENTRY - TRY AGAIN ***" S REENTSW=1 Q
D ONECK
S FACT="",NXT="" F I=0:0 S NXT=$O(FACT(NXT)) Q:NXT="" S FACT=FACT_NXT
I ((FACT="")&(FACTORS="")) W !,$C(7),"**** NO FACTORS ENTERED - CLASSIFICATION NOT UPDATED ****" H 3 S OUTSW=1 Q
I NURS1SW=1 W !,$C(7),"*** A CANNOT BE USED WITH NUMBERS B,C,D,E,F,G,H or I ***" S REENTSW=1 Q
I NURS3SW=1 W !,$C(7),"*** B CANNOT BE USED WITH NUMBER C ***" S REENTSW=1 Q
I NURS5SW=1 W !,$C(7),"*** E CANNOT BE USED WITH NUMBER D ***" S REENTSW=1 Q
I NURS7SW=1 W !,$C(7),"*** F and G CANNOT BE USED TOGETHER ***" S REENTSW=1 Q
I NURS9SW=1 W !,$C(7),"*** H and I CANNOT BE USED TOGETHER ***" S REENTSW=1 Q
I NURS11SW=1 W !,$C(7),"*** J and K CANNOT BE USED TOGETHER ***" S REENTSW=1 Q
I NURS13SW=1 W !,$C(7),"*** A and L CANNOT BE USED TOGETHER ***" S REENTSW=1 Q
I ((FACT="")!(FACT=FACTORS)) S NURSCKSW=1 G EN2
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
G EN2
ONECK ;DETERMINE IF FACTORS CAN BE USED WITH EACH OTHER
I FACT["A" I ((FACT["B")!(FACT["C")!(FACT["D")!(FACT["E")!(FACT["F")!(FACT["G")!(FACT["H")!(FACT["I")) S NURS1SW=1
I FACT["B"&(FACT["C") S NURS3SW=1
I FACT["E" I FACT["D" S NURS5SW=1
I ((FACT["F")&(FACT["G")) S NURS7SW=1
I ((FACT["H")&(FACT["I")) S NURS9SW=1
I ((FACT["J")&(FACT["K")) S NURS11SW=1
I ((FACT["A")&(FACT["L")) S NURS13SW=1
Q
EN2 ;CALCULATE NEW SCI CLASSIFICATION
I FACTORS["A" S CLASSX=1 G CHKCLASS
I FACTORS["L" S CLASSX=5 G CHKCLASS
S (CAT(1),CAT(2),CAT(3),CAT(4))=0
F I="B","D","F","H" S:FACTORS[I CAT(2)=CAT(2)+1
F I="B","C","D","E","F","G","H","I","J" S:FACTORS[I CAT(3)=CAT(3)+1
F I="C","E","G","I","J","K" S:FACTORS[I CAT(4)=CAT(4)+1
S CAT(1)=CAT(1)+1,CAT(2)=CAT(2)+1,CAT(3)=CAT(3)+.5
I (((CAT(2)>CAT(3))!(CAT(2)=CAT(3)))&(CAT(2)>CAT(4))) S CLASSX=2 G CHKCLASS
I (((CAT(3)>CAT(2))!(CAT(3)=CAT(2)))&(CAT(3)>CAT(4))) S CLASSX=3 G CHKCLASS
S CLASSX=4
CHKCLASS ;ENTER IN CLASSIFICATION IF WANT TO CHANGE
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 5" G CHKCLAS1
I $L(X)=0 S:CHANGESW=1 CONFIGX="COMPUTER" Q
I (($L(X)>1)!(X?1A)!(X<1)!(X>5)) 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[HNURACE9 2890 printed Dec 13, 2024@02:19 Page 2
NURACE9 ;HIRMFO/MD-PATIENT CLASSIFICATION MEDICAL (SCI) ;7/89
+1 ;;4.0;NURSING SERVICE;;Apr 25, 1997
EN1 ;VALIDATE SCI FACTORS
+1 SET (ABORTSW,CHANGESW,NURS1SW,NURS3SW,NURS5SW,NURS7SW,NURS9SW,NURS11SW,NURS13SW)=0
+2 IF FACT["?"
DO EN5^NURACE3
SET REENTSW=1
QUIT
+3 FOR I=1:1:$LENGTH(FACT)
if (($EXTRACT(FACT,I)'?1A)!($ASCII(FACT,I)<65)!($ASCII(FACT,I)>76))
SET ABORTSW=1
if ABORTSW=1
QUIT
SET FACT($EXTRACT(FACT,I))=0
+4 IF ABORTSW=1
WRITE $CHAR(7)," *** BAD ENTRY - TRY AGAIN ***"
SET REENTSW=1
QUIT
+5 DO ONECK
+6 SET FACT=""
SET NXT=""
FOR I=0:0
SET NXT=$ORDER(FACT(NXT))
if NXT=""
QUIT
SET FACT=FACT_NXT
+7 IF ((FACT="")&(FACTORS=""))
WRITE !,$CHAR(7),"**** NO FACTORS ENTERED - CLASSIFICATION NOT UPDATED ****"
HANG 3
SET OUTSW=1
QUIT
+8 IF NURS1SW=1
WRITE !,$CHAR(7),"*** A CANNOT BE USED WITH NUMBERS B,C,D,E,F,G,H or I ***"
SET REENTSW=1
QUIT
+9 IF NURS3SW=1
WRITE !,$CHAR(7),"*** B CANNOT BE USED WITH NUMBER C ***"
SET REENTSW=1
QUIT
+10 IF NURS5SW=1
WRITE !,$CHAR(7),"*** E CANNOT BE USED WITH NUMBER D ***"
SET REENTSW=1
QUIT
+11 IF NURS7SW=1
WRITE !,$CHAR(7),"*** F and G CANNOT BE USED TOGETHER ***"
SET REENTSW=1
QUIT
+12 IF NURS9SW=1
WRITE !,$CHAR(7),"*** H and I CANNOT BE USED TOGETHER ***"
SET REENTSW=1
QUIT
+13 IF NURS11SW=1
WRITE !,$CHAR(7),"*** J and K CANNOT BE USED TOGETHER ***"
SET REENTSW=1
QUIT
+14 IF NURS13SW=1
WRITE !,$CHAR(7),"*** A and L CANNOT BE USED TOGETHER ***"
SET REENTSW=1
QUIT
+15 IF ((FACT="")!(FACT=FACTORS))
SET NURSCKSW=1
GOTO EN2
+16 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)
+17 SET CHANGESW=1
+18 GOTO EN2
ONECK ;DETERMINE IF FACTORS CAN BE USED WITH EACH OTHER
+1 IF FACT["A"
IF ((FACT["B")!(FACT["C")!(FACT["D")!(FACT["E")!(FACT["F")!(FACT["G")!(FACT["H")!(FACT["I"))
SET NURS1SW=1
+2 IF FACT["B"&(FACT["C")
SET NURS3SW=1
+3 IF FACT["E"
IF FACT["D"
SET NURS5SW=1
+4 IF ((FACT["F")&(FACT["G"))
SET NURS7SW=1
+5 IF ((FACT["H")&(FACT["I"))
SET NURS9SW=1
+6 IF ((FACT["J")&(FACT["K"))
SET NURS11SW=1
+7 IF ((FACT["A")&(FACT["L"))
SET NURS13SW=1
+8 QUIT
EN2 ;CALCULATE NEW SCI CLASSIFICATION
+1 IF FACTORS["A"
SET CLASSX=1
GOTO CHKCLASS
+2 IF FACTORS["L"
SET CLASSX=5
GOTO CHKCLASS
+3 SET (CAT(1),CAT(2),CAT(3),CAT(4))=0
+4 FOR I="B","D","F","H"
if FACTORS[I
SET CAT(2)=CAT(2)+1
+5 FOR I="B","C","D","E","F","G","H","I","J"
if FACTORS[I
SET CAT(3)=CAT(3)+1
+6 FOR I="C","E","G","I","J","K"
if FACTORS[I
SET CAT(4)=CAT(4)+1
+7 SET CAT(1)=CAT(1)+1
SET CAT(2)=CAT(2)+1
SET CAT(3)=CAT(3)+.5
+8 IF (((CAT(2)>CAT(3))!(CAT(2)=CAT(3)))&(CAT(2)>CAT(4)))
SET CLASSX=2
GOTO CHKCLASS
+9 IF (((CAT(3)>CAT(2))!(CAT(3)=CAT(2)))&(CAT(3)>CAT(4)))
SET CLASSX=3
GOTO CHKCLASS
+10 SET CLASSX=4
CHKCLASS ;ENTER IN CLASSIFICATION IF WANT TO CHANGE
+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 5"
GOTO CHKCLAS1
+4 IF $LENGTH(X)=0
if CHANGESW=1
SET CONFIGX="COMPUTER"
QUIT
+5 IF (($LENGTH(X)>1)!(X?1A)!(X<1)!(X>5))
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
