- NURACE2 ;HIRMFO/RM-PATIENT CLASSIFICATION MEDICAL/SURGICAL ;NOVEMBER 17, 1986
- ;;4.0;NURSING SERVICE;;Apr 25, 1997
- EN1 ;DETERMINE IF FACTORS ENTERED VALID
- S ABORTSW=0,CHANGESW=0,NURS1SW=0,NURS4SW=0,NURS6SW=0,NURS9SW=0
- I FACT["?" D EN2^NURACE3 S REENTSW=1 Q
- F I=1:1:$L(FACT) S:(($E(FACT,I)'?1N)!($E(FACT,I)'>0)!($E(FACT,I)'<10)) ABORTSW=1 Q:ABORTSW=1 S FACT($E(FACT,I))=0
- I ABORTSW=1 W *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 !,*7,"**** NO FACTORS ENTERED - CLASSIFICATION NOT UPDATED ****" H 3 S OUTSW=1 Q
- I NURS1SW=1 W !,*7,"*** #1 CANNOT BE USED WITH NUMBERS 2,3,4,5, or 6 ***" S REENTSW=1 Q
- I NURS4SW=1 W !,*7,"*** #4 CANNOT BE USED WITH NUMBERS 2 or 3 ***" S REENTSW=1 Q
- I NURS6SW=1 W !,*7,"*** #5 and #6 CANNOT BE USED TOGETHER ***" S REENTSW=1 Q
- I NURS9SW=1 W !,*7,"*** #8 and #9 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[1 I ((FACT[2)!(FACT[3)!(FACT[4)!(FACT[5)!(FACT[6)) S NURS1SW=1
- I FACT[4 I ((FACT[2)!(FACT[3)) S NURS4SW=1
- I ((FACT[5)&(FACT[6)) S NURS6SW=1
- I ((FACT[8)&(FACT[9)) S NURS9SW=1
- Q
- EN2 ;CALCULATE NEW CLASSIFICATION
- I FACTORS[9 S CLASSX=4 G CHKCLASS
- S (CAT(1),CAT(2),CAT(3),CAT(4))=0
- I FACTORS[1 S CAT(1)=CAT(1)+1
- F I=2,3,5,7 S:FACTORS[I CAT(2)=CAT(2)+1
- F I=2,3,4,5,6,7,8 S:FACTORS[I CAT(3)=CAT(3)+1
- F I=4,6,7,8 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(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 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 L -^NURSF(214,DFN) 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[HNURACE2 2576 printed Feb 18, 2025@23:45:19 Page 2
- NURACE2 ;HIRMFO/RM-PATIENT CLASSIFICATION MEDICAL/SURGICAL ;NOVEMBER 17, 1986
- +1 ;;4.0;NURSING SERVICE;;Apr 25, 1997
- EN1 ;DETERMINE IF FACTORS ENTERED VALID
- +1 SET ABORTSW=0
- SET CHANGESW=0
- SET NURS1SW=0
- SET NURS4SW=0
- SET NURS6SW=0
- SET NURS9SW=0
- +2 IF FACT["?"
- DO EN2^NURACE3
- SET REENTSW=1
- QUIT
- +3 FOR I=1:1:$LENGTH(FACT)
- if (($EXTRACT(FACT,I)'?1N)!($EXTRACT(FACT,I)'>0)!($EXTRACT(FACT,I)'<10))
- SET ABORTSW=1
- if ABORTSW=1
- QUIT
- SET FACT($EXTRACT(FACT,I))=0
- +4 IF ABORTSW=1
- WRITE *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 !,*7,"**** NO FACTORS ENTERED - CLASSIFICATION NOT UPDATED ****"
- HANG 3
- SET OUTSW=1
- QUIT
- +8 IF NURS1SW=1
- WRITE !,*7,"*** #1 CANNOT BE USED WITH NUMBERS 2,3,4,5, or 6 ***"
- SET REENTSW=1
- QUIT
- +9 IF NURS4SW=1
- WRITE !,*7,"*** #4 CANNOT BE USED WITH NUMBERS 2 or 3 ***"
- SET REENTSW=1
- QUIT
- +10 IF NURS6SW=1
- WRITE !,*7,"*** #5 and #6 CANNOT BE USED TOGETHER ***"
- SET REENTSW=1
- QUIT
- +11 IF NURS9SW=1
- WRITE !,*7,"*** #8 and #9 CANNOT BE USED TOGETHER ***"
- SET REENTSW=1
- QUIT
- +12 IF ((FACT="")!(FACT=FACTORS))
- SET NURSCKSW=1
- GOTO EN2
- +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
- +15 GOTO EN2
- ONECK ;DETERMINE IF FACTORS CAN BE USED WITH EACH OTHER
- +1 IF FACT[1
- IF ((FACT[2)!(FACT[3)!(FACT[4)!(FACT[5)!(FACT[6))
- SET NURS1SW=1
- +2 IF FACT[4
- IF ((FACT[2)!(FACT[3))
- SET NURS4SW=1
- +3 IF ((FACT[5)&(FACT[6))
- SET NURS6SW=1
- +4 IF ((FACT[8)&(FACT[9))
- SET NURS9SW=1
- +5 QUIT
- EN2 ;CALCULATE NEW CLASSIFICATION
- +1 IF FACTORS[9
- SET CLASSX=4
- GOTO CHKCLASS
- +2 SET (CAT(1),CAT(2),CAT(3),CAT(4))=0
- +3 IF FACTORS[1
- SET CAT(1)=CAT(1)+1
- +4 FOR I=2,3,5,7
- if FACTORS[I
- SET CAT(2)=CAT(2)+1
- +5 FOR I=2,3,4,5,6,7,8
- if FACTORS[I
- SET CAT(3)=CAT(3)+1
- +6 FOR I=4,6,7,8
- 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(1)>CAT(2))&(CAT(1)>CAT(3))&(CAT(1)>CAT(4)))
- SET CLASSX=1
- GOTO CHKCLASS
- +9 IF (((CAT(2)>CAT(1))!(CAT(2)=CAT(1)))&(CAT(2)>CAT(3))&(CAT(2)>CAT(4)))
- SET CLASSX=2
- GOTO CHKCLASS
- +10 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
- +11 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
- LOCK -^NURSF(214,DFN)
- 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