NURSAPE0 ;HIRMFO/RM/JH-POSITION CONTROL/EXPERIENCE UTILITY ;5/1/96
;;4.0;NURSING SERVICE;;Apr 25, 1997
EN1 ; ENTRY FROM NURSUT1 AND APE XREF IN 211.82,.03
Q:'$D(NUR("PE")) S NUR("PE",0)=$S($D(^NURSF(211.8,DA(1),1,DA,0)):^(0),1:""),NUR("PE",200)=$P(NUR("PE",0),U,2),NUR("PE",210)=$O(^NURSF(210,"B",+NUR("PE",200),"")) G Q1:NUR("PE",210)'>0
S NUR("PE",211.8)=$S($D(^NURSF(211.8,DA(1),0)):^(0),1:"") G Q1:+NUR("PE",211.8)'>0
S NUR("PE",211.4)=$O(^NURSF(211.4,"B",+NUR("PE",211.8),"")) G Q1:NUR("PE",211.4)'>0
S NUR("PE",211.4,1)=$S($D(^NURSF(211.4,NUR("PE",211.4),1)):$P(^(1),U,3),1:"") G Q1:NUR("PE",211.4)="" S NUR("PE",211.5)=$S($D(^NURSF(211.5,+NUR("PE",211.4,1),0)):$P(^(0),U),1:"") G Q1:NUR("PE",211.5)=""
S NUR("PE",44)=$S($D(^SC(+NUR("PE",211.8),0)):$P($P(^(0),U),"NUR ",$P(^(0),U)?1"NUR ".E+1),1:""),NUR("PE","DA")=DA(1)_";"_DA
S:'$D(^NURSF(210,NUR("PE",210),20,0)) ^(0)="^210.13IA^^" S NUR("PE",210.13)=$O(^NURSF(210,NUR("PE",210),20,"APE",DA(1)_";"_DA,"")) I NUR("PE",210.13)'>0 D ADEXP G Q1:NUR("PE",210.13)'>0
S NUR("PE",210.13,0)=$S($D(^NURSF(210,NUR("PE",210),20,NUR("PE",210.13),0)):^(0),1:"")
D UPSP:+NUR("PE")=.03,UPSD:+NUR("PE")=.01,UPED:+NUR("PE")=3
Q1 K NUR("PE")
Q
ADEXP ; ADD EXPERIENCE ENTRY
I $P(NUR("PE",0),U,6)'<DT!'$P(NUR("PE",0),U,6) S NUR("PE",210.13)=0 Q
N DA,X
S DA(1)=NUR("PE",210),NUR("PE",210.13,"Z")=$P(^NURSF(210,DA(1),20,0),U,3,4) F DA=$P(NUR("PE",210.13,"Z"),U)+1:1 L +^NURSF(210,DA(1),20,DA):0 Q:$T&'$D(^(DA,0))
S NUR("PE",210.13,0)=NUR("PE",211.5)_U_$P(NUR("PE",0),U,3)_U_NUR("PE","DA")_U_NUR("PE",44)_U_$P(NUR("PE",0),U)_U_$P(NUR("PE",0),U,6)
S ^NURSF(210,DA(1),20,DA,0)=NUR("PE",210.13,0),NUR("PE","P")=1
F NUR("PE","X")=.01,1,4,3,2.1,2.5 S X=$P(NUR("PE",210.13,0),U,NUR("PE","P")),NUR("PE","P")=NUR("PE","P")+1 F NUR("PE","Y")=0:0 S NUR("PE","Y")=$O(^DD(210.13,NUR("PE","X"),1,NUR("PE","Y"))) Q:NUR("PE","Y")'>0 X:$D(^(NUR("PE","Y"),1)) ^(1)
S $P(^NURSF(210,DA(1),20,0),U,3,4)=$S(DA>$P(NUR("PE",210.13,"Z"),U):DA,1:$P(NUR("PE",210.13,"Z"),U))_U_($P(NUR("PE",210.13,"Z"),U,2)+1),NUR("PE",210.13)=DA
L -^NURSF(210,DA(1),20,DA) Q
UPSP ; UPDATE SERVICE POSITION IN 210.13
Q:$P(NUR("PE",210.13,0),U,2)=$P(NUR("PE",0),U,3)&$P(NUR("PE"),U,2)
N DA,X
S X=$S($P(NUR("PE"),U,2):$P(NUR("PE",0),U,3),1:""),DA(1)=NUR("PE",210),DA=NUR("PE",210.13),$P(^NURSF(210,DA(1),20,DA,0),U,2)=X
S NUR("PE","X")=1 D IX1
Q
UPSD ; UPDATE START DATE IN 210.13
Q:$P(NUR("PE",210.13,0),U,5)=$P(NUR("PE",0),U)&$P(NUR("PE"),U,2)
N DA,X
S DA(1)=NUR("PE",210),DA=NUR("PE",210.13)
I '$P(NUR("PE"),U,2) D KL Q
S X=$P(NUR("PE",0),U),$P(^NURSF(210,DA(1),20,DA,0),U,5)=X
S NUR("PE","X")=2.1 D IX1
Q
UPED ; UPDATE END DATE IN 210.13
Q:$P(NUR("PE",210.13,0),U,6)=$P(NUR("PE",0),U,6)&$P(NUR("PE"),U,2)
N DA,X
S DA(1)=NUR("PE",210),DA=NUR("PE",210.13),X=$S($P(NUR("PE"),U,2):$P(NUR("PE",0),U,6),1:""),$P(^NURSF(210,DA(1),20,DA,0),U,6)=X
I X'<DT!(X="") S $P(NUR("PE"),U,2)=0 D KL Q
S NUR("PE","X")=2.5 D IX1
Q
IX1 ; XREF FIELD NUR("PE","X") IN 210.13
F NUR("PE","Y")=0:0 S NUR("PE","Y")=$O(^DD(210.13,NUR("PE","X"),1,NUR("PE","Y"))) Q:NUR("PE","Y")'>0 X:$D(^(NUR("PE","Y"),2-$P(NUR("PE"),U,2))) ^(2-$P(NUR("PE"),U,2))
Q
KL ; KILL 210.13 NODE OFF
S NUR("PE",210.13,"Z")=$S($D(^NURSF(210,DA(1),20,0)):$P(^(0),U,3,4),1:"")
S NUR("PE","P")=1 F NUR("PE","X")=.01,1,4,3,2.1,2.5 S X=$P(NUR("PE",210.13,0),U,NUR("PE","P")),NUR("PE","P")=NUR("PE","P")+1 D IX1
K ^NURSF(210,DA(1),20,DA,0) S $P(^NURSF(210,DA(1),20,0),U,3,4)=$O(^NURSF(210,DA(1),20,DA),-1)_U_($P(NUR("PE",210.13,"Z"),U,2)-1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURSAPE0 3573 printed Dec 13, 2024@02:21:36 Page 2
NURSAPE0 ;HIRMFO/RM/JH-POSITION CONTROL/EXPERIENCE UTILITY ;5/1/96
+1 ;;4.0;NURSING SERVICE;;Apr 25, 1997
EN1 ; ENTRY FROM NURSUT1 AND APE XREF IN 211.82,.03
+1 if '$DATA(NUR("PE"))
QUIT
SET NUR("PE",0)=$SELECT($DATA(^NURSF(211.8,DA(1),1,DA,0)):^(0),1:"")
SET NUR("PE",200)=$PIECE(NUR("PE",0),U,2)
SET NUR("PE",210)=$ORDER(^NURSF(210,"B",+NUR("PE",200),""))
if NUR("PE",210)'>0
GOTO Q1
+2 SET NUR("PE",211.8)=$SELECT($DATA(^NURSF(211.8,DA(1),0)):^(0),1:"")
if +NUR("PE",211.8)'>0
GOTO Q1
+3 SET NUR("PE",211.4)=$ORDER(^NURSF(211.4,"B",+NUR("PE",211.8),""))
if NUR("PE",211.4)'>0
GOTO Q1
+4 SET NUR("PE",211.4,1)=$SELECT($DATA(^NURSF(211.4,NUR("PE",211.4),1)):$PIECE(^(1),U,3),1:"")
if NUR("PE",211.4)=""
GOTO Q1
SET NUR("PE",211.5)=$SELECT($DATA(^NURSF(211.5,+NUR("PE",211.4,1),0)):$PIECE(^(0),U),1:"")
if NUR("PE",211.5)=""
GOTO Q1
+5 SET NUR("PE",44)=$SELECT($DATA(^SC(+NUR("PE",211.8),0)):$PIECE($PIECE(^(0),U),"NUR ",$PIECE(^(0),U)?1"NUR ".E+1),1:"")
SET NUR("PE","DA")=DA(1)_";"_DA
+6 if '$DATA(^NURSF(210,NUR("PE",210),20,0))
SET ^(0)="^210.13IA^^"
SET NUR("PE",210.13)=$ORDER(^NURSF(210,NUR("PE",210),20,"APE",DA(1)_";"_DA,""))
IF NUR("PE",210.13)'>0
DO ADEXP
if NUR("PE",210.13)'>0
GOTO Q1
+7 SET NUR("PE",210.13,0)=$SELECT($DATA(^NURSF(210,NUR("PE",210),20,NUR("PE",210.13),0)):^(0),1:"")
+8 if +NUR("PE")=.03
DO UPSP
if +NUR("PE")=.01
DO UPSD
if +NUR("PE")=3
DO UPED
Q1 KILL NUR("PE")
+1 QUIT
ADEXP ; ADD EXPERIENCE ENTRY
+1 IF $PIECE(NUR("PE",0),U,6)'<DT!'$PIECE(NUR("PE",0),U,6)
SET NUR("PE",210.13)=0
QUIT
+2 NEW DA,X
+3 SET DA(1)=NUR("PE",210)
SET NUR("PE",210.13,"Z")=$PIECE(^NURSF(210,DA(1),20,0),U,3,4)
FOR DA=$PIECE(NUR("PE",210.13,"Z"),U)+1:1
LOCK +^NURSF(210,DA(1),20,DA):0
if $TEST&'$DATA(^(DA,0))
QUIT
+4 SET NUR("PE",210.13,0)=NUR("PE",211.5)_U_$PIECE(NUR("PE",0),U,3)_U_NUR("PE","DA")_U_NUR("PE",44)_U_$PIECE(NUR("PE",0),U)_U_$PIECE(NUR("PE",0),U,6)
+5 SET ^NURSF(210,DA(1),20,DA,0)=NUR("PE",210.13,0)
SET NUR("PE","P")=1
+6 FOR NUR("PE","X")=.01,1,4,3,2.1,2.5
SET X=$PIECE(NUR("PE",210.13,0),U,NUR("PE","P"))
SET NUR("PE","P")=NUR("PE","P")+1
FOR NUR("PE","Y")=0:0
SET NUR("PE","Y")=$ORDER(^DD(210.13,NUR("PE","X"),1,NUR("PE","Y")))
if NUR("PE","Y")'>0
QUIT
if $DATA(^(NUR("PE","Y"),1))
XECUTE ^(1)
+7 SET $PIECE(^NURSF(210,DA(1),20,0),U,3,4)=$SELECT(DA>$PIECE(NUR("PE",210.13,"Z"),U):DA,1:$PIECE(NUR("PE",210.13,"Z"),U))_U_($PIECE(NUR("PE",210.13,"Z"),U,2)+1)
SET NUR("PE",210.13)=DA
+8 LOCK -^NURSF(210,DA(1),20,DA)
QUIT
UPSP ; UPDATE SERVICE POSITION IN 210.13
+1 if $PIECE(NUR("PE",210.13,0),U,2)=$PIECE(NUR("PE",0),U,3)&$PIECE(NUR("PE"),U,2)
QUIT
+2 NEW DA,X
+3 SET X=$SELECT($PIECE(NUR("PE"),U,2):$PIECE(NUR("PE",0),U,3),1:"")
SET DA(1)=NUR("PE",210)
SET DA=NUR("PE",210.13)
SET $PIECE(^NURSF(210,DA(1),20,DA,0),U,2)=X
+4 SET NUR("PE","X")=1
DO IX1
+5 QUIT
UPSD ; UPDATE START DATE IN 210.13
+1 if $PIECE(NUR("PE",210.13,0),U,5)=$PIECE(NUR("PE",0),U)&$PIECE(NUR("PE"),U,2)
QUIT
+2 NEW DA,X
+3 SET DA(1)=NUR("PE",210)
SET DA=NUR("PE",210.13)
+4 IF '$PIECE(NUR("PE"),U,2)
DO KL
QUIT
+5 SET X=$PIECE(NUR("PE",0),U)
SET $PIECE(^NURSF(210,DA(1),20,DA,0),U,5)=X
+6 SET NUR("PE","X")=2.1
DO IX1
+7 QUIT
UPED ; UPDATE END DATE IN 210.13
+1 if $PIECE(NUR("PE",210.13,0),U,6)=$PIECE(NUR("PE",0),U,6)&$PIECE(NUR("PE"),U,2)
QUIT
+2 NEW DA,X
+3 SET DA(1)=NUR("PE",210)
SET DA=NUR("PE",210.13)
SET X=$SELECT($PIECE(NUR("PE"),U,2):$PIECE(NUR("PE",0),U,6),1:"")
SET $PIECE(^NURSF(210,DA(1),20,DA,0),U,6)=X
+4 IF X'<DT!(X="")
SET $PIECE(NUR("PE"),U,2)=0
DO KL
QUIT
+5 SET NUR("PE","X")=2.5
DO IX1
+6 QUIT
IX1 ; XREF FIELD NUR("PE","X") IN 210.13
+1 FOR NUR("PE","Y")=0:0
SET NUR("PE","Y")=$ORDER(^DD(210.13,NUR("PE","X"),1,NUR("PE","Y")))
if NUR("PE","Y")'>0
QUIT
if $DATA(^(NUR("PE","Y"),2-$PIECE(NUR("PE"),U,2)))
XECUTE ^(2-$PIECE(NUR("PE"),U,2))
+2 QUIT
KL ; KILL 210.13 NODE OFF
+1 SET NUR("PE",210.13,"Z")=$SELECT($DATA(^NURSF(210,DA(1),20,0)):$PIECE(^(0),U,3,4),1:"")
+2 SET NUR("PE","P")=1
FOR NUR("PE","X")=.01,1,4,3,2.1,2.5
SET X=$PIECE(NUR("PE",210.13,0),U,NUR("PE","P"))
SET NUR("PE","P")=NUR("PE","P")+1
DO IX1
+3 KILL ^NURSF(210,DA(1),20,DA,0)
SET $PIECE(^NURSF(210,DA(1),20,0),U,3,4)=$ORDER(^NURSF(210,DA(1),20,DA),-1)_U_($PIECE(NUR("PE",210.13,"Z"),U,2)-1)
+4 QUIT
