- NURACE7 ;HIRMFO/MD-RM-PATIENT CLASSIFICATION DRIVER-cont. ;6/6/96
- ;;4.0;NURSING SERVICE;**7**;Apr 25, 1997
- EN1 ; SET LOCAL VARIABLES WITH PATIENT DATA
- I NURSBS=11 S CONFIGX="USER",(FACTX,FACTORS)="N/A",COMMENTX=""
- G:CLASSREV=0 PRINTIT
- I NURSCLAS'>0 W !,$C(7)," NO PREVIOUS CLASSIFICATION--CANNOT REVIEW " Q
- S NURSOLDC=NURSCLAS
- S NURSREV=$O(^NURSA(214.7,"AA",DFN,NURSCLAS,"")) G:NURSREV="" A2
- S NURSREV=$O(^NURSA(214.7,"AA",DFN,NURSCLAS,NURSREV,"")) G:(NURSREV="")!(NURSREV=0) A2
- A1 S NRX=^NURSA(214.7,NURSREV,0),REVDATE=$P(NRX,"^",1),REVNO=$P(NRX,"^",6),REVIEWER=$S(REVNO="":"",'$D(^VA(200,REVNO,0)):"",1:$P(^(0),"^",1)) G PRINTIT
- A2 S (REVNO,REVIEWER,REVDATE)=""
- PRINTIT ;GO TO CLASSIFY PATIENT
- S OUTSW=0 D EN1^NURACE1 I OUTSW L -^NURSF(214,DFN) Q
- G FINAL21:NOREVSW,FINAL2:NURSRTSW
- I CONFIGX="COMPUTER" S COMMENTX="" G FINAL2
- I NURSBS=11 S COMMENTX="",CONFIGX="USER" G FINAL2
- COMADD ;ENTER COMMENTS IF NECESSARY
- W !!,"Enter Comments: " W:(COMMENTX'="") COMMENTX,!,"//" R X:DTIME S:X=""&$T X=COMMENTX
- I (X="^")!('$T) D EN4^NURACE8 L -^NURSF(214,DFN) S OUTSW=1 Q
- I $L(X)>50!(X["?") W !,$C(7),"ANSWER MUST BE 1 TO 50 CHARACTERS IN LENGTH:" G COMADD
- F I=1:1:$L(X) Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
- I X="" W !,$C(7),"*** WHEN CHANGING THE CLASSIFICATION, COMMENTS MUST BE FILLED IN ***" G COMADD
- I X=COMMENTX G FINAL2
- I X="@" W $C(7)," *** COMMENTS CANNOT BE DELETED ***" G COMADD
- I X'?1A.ANP!(X["^") W !,"ANSWER MUST BE 1 TO 50 CHARACTERS IN LENGTH" G COMADD
- S CHANGESW=1,COMMENTX=X
- FINAL2 ;ADD PATIENT CLASSIFICATION TO DATABASE
- W !!
- L -^NURSF(214,DFN) S CONFIGX=$E(CONFIGX,1)
- S X="N",%DT="T" D ^%DT S DATEX=Y S:$E(DATEX,8)'="." DATEX=$E(DATEX,1,7)_".00001"
- CHK I $$DUPCLAS^NURSCUTL(DATEX,DFN) S DATEX=(DATEX+.000001) G CHK
- S DA=$P(^NURSA(214.6,0),U,3)
- LOCK S DA=DA+1 L +^NURSA(214.6,DA,0):0 I '$T!$D(^NURSA(214.6,DA)) L -^NURSA(214.6,DA,0) G LOCK
- S ^NURSA(214.6,DA,0)=DATEX_"^"_DFN_"^"_CLASSX_"^"_FACTORS_"^"_CONFIGX_"^"_DUZ_"^"_COMMENTX_"^"_NURSWARD_"^"_NURSBS_"^^"_NURSRMBD S X=^NURSA(214.6,DA,0)
- S ^NURSA(214.6,"AA",$P(X,"^",2),9999999-$P(X,"^",1),DA)=""
- S ^NURSA(214.6,"B",$E($P(X,"^",1),1,30),DA)=""
- S ^NURSA(214.6,"C",$E($P(X,"^",2),1,30),DA)=""
- S ^NURSA(214.6,"E",$E($P(X,"^",8),1,30),DA)=""
- S $P(^NURSA(214.6,0),U,3,4)=DA_"^"_($P(^NURSA(214.6,0),"^",4)+1) L -^NURSA(214.6,DA,0)
- S NEWREV=DA
- FINAL21 ;
- I CLASSREV=1 D ADDREV
- Q
- ADDREV ; ADD REVIEWED CLASSIFICATION DATA
- S NOREVSW=$S('NOREVSW:"Y",1:"N")
- S DA=$P(^NURSA(214.7,0),"^",3)
- LOCK1 S DA=DA+1 L +^NURSA(214.7,DA,0):0 I '$T!$D(^NURSA(214.7,DA)) L -^NURSA(214.7,DA,0) G LOCK1
- S X="N",%DT="T" D ^%DT S NURSRVDT=Y S:'$D(NEWREV) NEWREV=""
- S ^NURSA(214.7,DA,0)=NURSRVDT_"^"_DFN_"^"_NURSOLDC_"^"_NOREVSW_"^"_NEWREV_"^"_DUZ S X=^NURSA(214.7,DA,0)
- S ^NURSA(214.7,"AA",$P(X,"^",2),$P(X,"^",3),9999999-$P(X,"^",1),DA)=""
- S ^NURSA(214.7,"B",$E($P(X,"^",1),1,30),DA)=""
- S ^NURSA(214.7,"C",$E($P(X,"^",2),1,30),DA)=""
- S ^NURSA(214.7,0)=$P(^NURSA(214.7,0),"^",1,2)_"^"_DA_"^"_($P(^NURSA(214.7,0),"^",4)+1) L -^NURSA(214.7,DA,0)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURACE7 3073 printed Feb 18, 2025@23:45:24 Page 2
- NURACE7 ;HIRMFO/MD-RM-PATIENT CLASSIFICATION DRIVER-cont. ;6/6/96
- +1 ;;4.0;NURSING SERVICE;**7**;Apr 25, 1997
- EN1 ; SET LOCAL VARIABLES WITH PATIENT DATA
- +1 IF NURSBS=11
- SET CONFIGX="USER"
- SET (FACTX,FACTORS)="N/A"
- SET COMMENTX=""
- +2 if CLASSREV=0
- GOTO PRINTIT
- +3 IF NURSCLAS'>0
- WRITE !,$CHAR(7)," NO PREVIOUS CLASSIFICATION--CANNOT REVIEW "
- QUIT
- +4 SET NURSOLDC=NURSCLAS
- +5 SET NURSREV=$ORDER(^NURSA(214.7,"AA",DFN,NURSCLAS,""))
- if NURSREV=""
- GOTO A2
- +6 SET NURSREV=$ORDER(^NURSA(214.7,"AA",DFN,NURSCLAS,NURSREV,""))
- if (NURSREV="")!(NURSREV=0)
- GOTO A2
- A1 SET NRX=^NURSA(214.7,NURSREV,0)
- SET REVDATE=$PIECE(NRX,"^",1)
- SET REVNO=$PIECE(NRX,"^",6)
- SET REVIEWER=$SELECT(REVNO="":"",'$DATA(^VA(200,REVNO,0)):"",1:$PIECE(^(0),"^",1))
- GOTO PRINTIT
- A2 SET (REVNO,REVIEWER,REVDATE)=""
- PRINTIT ;GO TO CLASSIFY PATIENT
- +1 SET OUTSW=0
- DO EN1^NURACE1
- IF OUTSW
- LOCK -^NURSF(214,DFN)
- QUIT
- +2 if NOREVSW
- GOTO FINAL21
- if NURSRTSW
- GOTO FINAL2
- +3 IF CONFIGX="COMPUTER"
- SET COMMENTX=""
- GOTO FINAL2
- +4 IF NURSBS=11
- SET COMMENTX=""
- SET CONFIGX="USER"
- GOTO FINAL2
- COMADD ;ENTER COMMENTS IF NECESSARY
- +1 WRITE !!,"Enter Comments: "
- if (COMMENTX'="")
- WRITE COMMENTX,!,"//"
- READ X:DTIME
- if X=""&$TEST
- SET X=COMMENTX
- +2 IF (X="^")!('$TEST)
- DO EN4^NURACE8
- LOCK -^NURSF(214,DFN)
- SET OUTSW=1
- QUIT
- +3 IF $LENGTH(X)>50!(X["?")
- WRITE !,$CHAR(7),"ANSWER MUST BE 1 TO 50 CHARACTERS IN LENGTH:"
- GOTO COMADD
- +4 FOR I=1:1:$LENGTH(X)
- if $EXTRACT(X,1)'=" "
- QUIT
- SET X=$EXTRACT(X,2,$LENGTH(X))
- +5 IF X=""
- WRITE !,$CHAR(7),"*** WHEN CHANGING THE CLASSIFICATION, COMMENTS MUST BE FILLED IN ***"
- GOTO COMADD
- +6 IF X=COMMENTX
- GOTO FINAL2
- +7 IF X="@"
- WRITE $CHAR(7)," *** COMMENTS CANNOT BE DELETED ***"
- GOTO COMADD
- +8 IF X'?1A.ANP!(X["^")
- WRITE !,"ANSWER MUST BE 1 TO 50 CHARACTERS IN LENGTH"
- GOTO COMADD
- +9 SET CHANGESW=1
- SET COMMENTX=X
- FINAL2 ;ADD PATIENT CLASSIFICATION TO DATABASE
- +1 WRITE !!
- +2 LOCK -^NURSF(214,DFN)
- SET CONFIGX=$EXTRACT(CONFIGX,1)
- +3 SET X="N"
- SET %DT="T"
- DO ^%DT
- SET DATEX=Y
- if $EXTRACT(DATEX,8)'="."
- SET DATEX=$EXTRACT(DATEX,1,7)_".00001"
- CHK IF $$DUPCLAS^NURSCUTL(DATEX,DFN)
- SET DATEX=(DATEX+.000001)
- GOTO CHK
- +1 SET DA=$PIECE(^NURSA(214.6,0),U,3)
- LOCK SET DA=DA+1
- LOCK +^NURSA(214.6,DA,0):0
- IF '$TEST!$DATA(^NURSA(214.6,DA))
- LOCK -^NURSA(214.6,DA,0)
- GOTO LOCK
- +1 SET ^NURSA(214.6,DA,0)=DATEX_"^"_DFN_"^"_CLASSX_"^"_FACTORS_"^"_CONFIGX_"^"_DUZ_"^"_COMMENTX_"^"_NURSWARD_"^"_NURSBS_"^^"_NURSRMBD
- SET X=^NURSA(214.6,DA,0)
- +2 SET ^NURSA(214.6,"AA",$PIECE(X,"^",2),9999999-$PIECE(X,"^",1),DA)=""
- +3 SET ^NURSA(214.6,"B",$EXTRACT($PIECE(X,"^",1),1,30),DA)=""
- +4 SET ^NURSA(214.6,"C",$EXTRACT($PIECE(X,"^",2),1,30),DA)=""
- +5 SET ^NURSA(214.6,"E",$EXTRACT($PIECE(X,"^",8),1,30),DA)=""
- +6 SET $PIECE(^NURSA(214.6,0),U,3,4)=DA_"^"_($PIECE(^NURSA(214.6,0),"^",4)+1)
- LOCK -^NURSA(214.6,DA,0)
- +7 SET NEWREV=DA
- FINAL21 ;
- +1 IF CLASSREV=1
- DO ADDREV
- +2 QUIT
- ADDREV ; ADD REVIEWED CLASSIFICATION DATA
- +1 SET NOREVSW=$SELECT('NOREVSW:"Y",1:"N")
- +2 SET DA=$PIECE(^NURSA(214.7,0),"^",3)
- LOCK1 SET DA=DA+1
- LOCK +^NURSA(214.7,DA,0):0
- IF '$TEST!$DATA(^NURSA(214.7,DA))
- LOCK -^NURSA(214.7,DA,0)
- GOTO LOCK1
- +1 SET X="N"
- SET %DT="T"
- DO ^%DT
- SET NURSRVDT=Y
- if '$DATA(NEWREV)
- SET NEWREV=""
- +2 SET ^NURSA(214.7,DA,0)=NURSRVDT_"^"_DFN_"^"_NURSOLDC_"^"_NOREVSW_"^"_NEWREV_"^"_DUZ
- SET X=^NURSA(214.7,DA,0)
- +3 SET ^NURSA(214.7,"AA",$PIECE(X,"^",2),$PIECE(X,"^",3),9999999-$PIECE(X,"^",1),DA)=""
- +4 SET ^NURSA(214.7,"B",$EXTRACT($PIECE(X,"^",1),1,30),DA)=""
- +5 SET ^NURSA(214.7,"C",$EXTRACT($PIECE(X,"^",2),1,30),DA)=""
- +6 SET ^NURSA(214.7,0)=$PIECE(^NURSA(214.7,0),"^",1,2)_"^"_DA_"^"_($PIECE(^NURSA(214.7,0),"^",4)+1)
- LOCK -^NURSA(214.7,DA,0)
- +7 QUIT