NURSUT0 ;HIRMFO/MD,RM,FT-NURS STAFF FILE EDIT UTILITY ; 1/17/03 2:54pm
;;4.0;NURSING SERVICE;**1,16,18,33,34,38**;Apr 25, 1997
;
; Reference to File #452.3 is supported by IA #1400
; Reference to ^PRSPC is supported by IA #1402
; File #200 is covered by supported reference #10060
;
EN1(NURSEMP,NURSDT) ; DETERMINE IF EMPLOYEE HAS ANY ACTIVE ASSIGNMENTS
;VARIBLES NURSDT=TODAY, AND NURSEMP=EMPLOYEE POINTER TO FILE 200
;ARE PASSED INTO THE ROUTINE AND VARIBLE NURSTAT IS RETURNED=1 IF AN
;ACTIVE POSITION EXISTS AND NURSTAT=0 IF NO ACTIVE POSITIONS EXIST.
;ACTIVE POSITIONS HAVE A START DATE '>TODAY AND NO VACANCY DATE OR A
;VACANCY DATE '<TODAY
S NURSTAT=0,NURSDT=$P(NURSDT,".") D
.F NI(1)=0:0 S NI(1)=$O(^NURSF(211.8,"C",+NURSEMP,NI(1))) Q:NI(1)'>0 F NI=0:0 S NI=$O(^NURSF(211.8,"C",+NURSEMP,NI(1),NI)) Q:NI'>0 I +^NURSF(211.8,NI(1),1,NI,0)'>NURSDT&(('+$P(^(0),U,6))!(+$P(^(0),U,6)'<NURSDT)) S NURSTAT=1
.K NURSDT,NURSEMP,NURI
.Q
Q $S(NURSTAT=1:1,1:0)
EN2 ; FIND PRIMARY SERVICE POSITION
Q:'$D(^NURSF(210,DA,0)) S ID=+^(0) Q:ID'>0 S (NOD1,NOD2,NPSPOS,NPSPOS(0),NPSPOS(1))=""
I '($P(^NURSF(210,DA,0),U,2)="R") D EN3 G SVPOS
I $D(^NURSF(211.8,"AE",ID)) F NURSX=0:0 S NURSX=$O(^NURSF(211.8,"AE",ID,1,NURSX)) Q:NURSX'>0 F NURSZ=0:0 S NURSZ=$O(^NURSF(211.8,"AE",ID,1,NURSX,NURSZ)) Q:NURSZ'>0 I +$G(^NURSF(211.8,NURSX,1,NURSZ,0)) D
. S NURS("AE",(9999999-+$G(^NURSF(211.8,NURSX,1,NURSZ,0))),NURSX,NURSZ)=""
. Q
I $O(NURS("AE",0)) S NURSX=$O(NURS("AE",0)),NOD1=$O(NURS("AE",NURSX,0)),NOD2=$O(NURS("AE",NURSX,NOD1,0))
SVPOS Q:'$D(^NURSF(211.8,+NOD1,1,+NOD2,0)) S NPNT=$P(^NURSF(211.8,NOD1,1,NOD2,0),U,3) S NPSPOS=$S('$D(^NURSF(211.3,NPNT,0)):"",1:$P(^(0),U)),NPSPOS(0)=NPNT,NPSPOS(1)=$S('$D(^NURSF(211.3,NPNT,0)):"",1:$P(^(0),U,5))
S SC44DA=+$G(^NURSF(211.8,NOD1,0)),NUR2114D=$O(^NURSF(211.4,"B",SC44DA,0))
S NPNT(1)=+$P(^NURSF(211.3,NPNT,0),U,7),NURFLAG=1
; GET PRODUCT LINE/FACILITY OF PRIMARY POSITION
S NPSPOS(2)=$S(NPNT(1):$$GET1^DIQ(212.7,NPNT(1),.01,"I"),1:"")
S (NPSPOS(3),NPSPOS(4))="" I NOD1 D
. S NPSPOS(3)=$$EN11^NURSUT3(NOD1)
. S NPSPOS(4)=$$EN13^NURSUT3(NOD1)
K NURS,NURFLAG,NPI,NPNT,NPI1,ID Q
Q
EN3 ; SELECT FIRST ACTIVE PRIMARY ASSIGNMENT
S (NOD1,NOD2)="",NURFLAG=0,ID=$S($P($G(^NURSF(210,+DA,0)),U):$P(^(0),U),1:"") Q:ID=""
F NUI(1)=0:0 S NUI(1)=$O(^NURSF(211.8,"AE",ID,1,NUI(1))) Q:NUI(1)'>0!(NURFLAG=1) F NUI=0:0 S NUI=$O(^NURSF(211.8,"AE",ID,1,NUI(1),NUI)) Q:NUI'>0!(NURFLAG=1) D CHECK
K NUI,ID
Q
CHECK ;
I +$P(^NURSF(211.8,NUI(1),1,NUI,0),U)'>DT&(('+$P(^(0),U,6))!($P(^(0),U,6)'<DT)) S NOD1=NUI(1),NOD2=NUI,NOD2(1)=$P(^(0),U) S NURFLAG=1
Q
EN4 ;SET LOGIC FOR DE XREF OF 211.82 SUBFILE
S:+$P(NUR,U,3) ^NURSF(211.8,"AD",X,$P(NUR,U,3),DA(1),DA)="" S:+$P(NUR,U,9) ^NURSF(211.8,"AE",X,$P(NUR,U,9),DA(1),DA)="" K NUR
Q
EN5 ;KILL LOGIC FOR DE XREF 0F 211.82 SUBFILE
K:+$P(NUR,U,3) ^NURSF(211.8,"AD",X,$P(NUR,U,3),DA(1),DA) K:+$P(NUR,U,9) ^NURSF(211.8,"AE",X,$P(NUR,U,9),DA(1),DA) K NUR
Q
EN6 ; SELECT MULTIPLE REPORT COPIES
W !?5,"How many copies of this report are required: 1// " R NCOPY:DTIME
I NCOPY=U!('$T) S NURQUIT=1 Q
S:NCOPY="" NCOPY=1 I NCOPY'=+NCOPY!(NCOPY<1)!(NCOPY>20) W !,$C(7),?5,"ANSWER WITH A NUMBER BETWEEN 1 AND 20",!! G EN6
Q
EN7 ; NURS DEVICE HANDLING/QUEUEING LOGIC
K ZTSK S %ZIS="Q" S:$G(NURS132) %ZIS("B")=""
D ^%ZIS K %ZIS K:POP IO("Q") I POP S (NUROUT,NURQUIT)=1 Q
I IO'=IO(0),$E(IOST)="P",'$D(IO("Q")),'$D(IO("S")),IOST'["P-MESSAGE-HFS" S XQH="NURS-PRINTER QUEUE" W $C(7) D EN^XQH K XQH G EN7
I $G(NURS132),IOM<132 D ^%ZISC W !,$C(7)," ** THIS REPORT MUST BE SENT TO A 132 COLUMN DEVICE **",! K IO("Q"),IO("C") G EN7
I '$D(ZTDESC) S ZTDESC=$S($D(ZTRTN):ZTRTN,1:"Unknown NURSING option")
F X="A*","B*","C*","D*","E*","F*","G*","H*","I*","J*","K*","L*","M*","N*","O*","P*","Q*","R*","S*","T*","U*","V*","W*","Y*","Z*" S ZTSAVE(X)=""
S NURQUEUE=0 I $D(IO("Q")) K IO("Q"),IO("C") S NURQUEUE=1,ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL D ^%ZTLOAD S NURQUEUE=0 S:'$D(ZTSK) POP=1
Q
EN8 ; INPUT TRANSFORM FOR 2.1 & 2.5 SUBFIELDS OF FIELD 22.5
;OF FILE 210
S NURS(0)=$S($D(^NURSF(210,DA(1),20,DA,0)):^(0),1:""),NURS("HELP")="DATE MUST BE "_$P("GREATER THAN DATE STARTED OR A VALID DATE ^LESS THAN DATE ENDED OR A VALID DATE ",U,NURS*10=21+1)
S %DT(0)=+($E("-",NURS*10=21)_$P(NURS(0),U,$E(56,NURS*10=21+1)))
S NURS(1)=$S(NURS=2.5&%DT(0)=0:1,1:0)
K:%DT(0)=0 %DT(0) S %DT="E" D ^%DT S X=Y I Y<1 W !?5,NURS("HELP") K X,NURS Q
S %DT(0)="-"_DT,%DT="E" D ^%DT S X=Y I Y<1 W !?5,"DATE MUST BE A CURRENT OR PAST DATE" K X,NURS Q
I NURS(1) S $P(^NURSF(210,DA(1),20,DA,0),U,5)=X
K %DT,NURS
Q
EN9 ; FIND TOUR OF DUTY FROM STAFF FILE
D EN3^NURSUT0 S NUR=$S('$D(^NURSF(211.8,+NOD1,1,+NOD2,0)):"",1:$P(^(0),U,10)),NUR(1)=$S('$D(^NURSF(211.6,+NUR,0)):"",1:$P(^(0),U))
K NOD1,NOD2
Q
EN11(D0) ; PRINT EMPLOYEE MI REVIEW GROUPS
S VA200DA=+$G(^NURSF(210,D0,0)),SSN=$P($G(^VA(200,+VA200DA,1)),U,9),PDA=$S(SSN="":0,1:$O(^PRSPC("SSN",SSN,0)))
I PDA>0 W !,?$S($G(EDIT)=1:0,1:9),"MI REVIEW GROUP: " F D1=0:0 S D1=$O(^PRSPC(PDA,5,D1)) Q:D1'>0 I $G(^PRSPC(PDA,5,D1,0))'="" S PRSE=+$G(^(0)) W ?$S($G(EDIT)=1:18,1:26),$P($G(^PRSE(452.3,+PRSE,0)),U) W:$O(^PRSPC(PDA,5,D1)) !
Q
EN12(DA) ; PRINT EMPLOYEE SALARY
N X,Y,DM,D0,DE,DC,DG,DI,DIC,DIEL,DIFLD,DK,DQ,DP,DH,DL,DIE,DR
S SDA=DA,(PDA,XXX)=0,DA200=+$G(^NURSF(210,DA,0)),SSN=$P($G(^VA(200,+DA200,1)),U,9) S:$G(SSN)'="" PDA=$O(^PRSPC("SSN",SSN,0))
I PDA>0 S XXX=$P($G(^PRSPC(PDA,0)),U,29),Y=$P($G(^(0)),U,28) D:+Y>0 D^DIQ S $P(XXX,U,2)=Y S DA=SDA K PDA,SSN,DA200
Q XXX
EN13(DA) ; LATEST PROMOTION DATE
N X,Y,DM,D0,DE,DC,DG,DI,DIC,DIEL,DIFLD,DK,DQ,DP,DH,DL,DIE,DR
S SDA=DA,Z=$O(^NURSF(210,DA,9,"AA",0)),Y=(9999999-Z) D:+Y>0 D^DIQ S XXX=Y
Q XXX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURSUT0 5760 printed Oct 16, 2024@18:23:06 Page 2
NURSUT0 ;HIRMFO/MD,RM,FT-NURS STAFF FILE EDIT UTILITY ; 1/17/03 2:54pm
+1 ;;4.0;NURSING SERVICE;**1,16,18,33,34,38**;Apr 25, 1997
+2 ;
+3 ; Reference to File #452.3 is supported by IA #1400
+4 ; Reference to ^PRSPC is supported by IA #1402
+5 ; File #200 is covered by supported reference #10060
+6 ;
EN1(NURSEMP,NURSDT) ; DETERMINE IF EMPLOYEE HAS ANY ACTIVE ASSIGNMENTS
+1 ;VARIBLES NURSDT=TODAY, AND NURSEMP=EMPLOYEE POINTER TO FILE 200
+2 ;ARE PASSED INTO THE ROUTINE AND VARIBLE NURSTAT IS RETURNED=1 IF AN
+3 ;ACTIVE POSITION EXISTS AND NURSTAT=0 IF NO ACTIVE POSITIONS EXIST.
+4 ;ACTIVE POSITIONS HAVE A START DATE '>TODAY AND NO VACANCY DATE OR A
+5 ;VACANCY DATE '<TODAY
+6 SET NURSTAT=0
SET NURSDT=$PIECE(NURSDT,".")
Begin DoDot:1
+7 FOR NI(1)=0:0
SET NI(1)=$ORDER(^NURSF(211.8,"C",+NURSEMP,NI(1)))
if NI(1)'>0
QUIT
FOR NI=0:0
SET NI=$ORDER(^NURSF(211.8,"C",+NURSEMP,NI(1),NI))
if NI'>0
QUIT
IF +^NURSF(211.8,NI(1),1,NI,0)'>NURSDT&(('+$PIECE(^(0),U,6))!(+$PIECE(^(0),U,6)'<NURSDT))
SET NURSTAT=1
+8 KILL NURSDT,NURSEMP,NURI
+9 QUIT
End DoDot:1
+10 QUIT $SELECT(NURSTAT=1:1,1:0)
EN2 ; FIND PRIMARY SERVICE POSITION
+1 if '$DATA(^NURSF(210,DA,0))
QUIT
SET ID=+^(0)
if ID'>0
QUIT
SET (NOD1,NOD2,NPSPOS,NPSPOS(0),NPSPOS(1))=""
+2 IF '($PIECE(^NURSF(210,DA,0),U,2)="R")
DO EN3
GOTO SVPOS
+3 IF $DATA(^NURSF(211.8,"AE",ID))
FOR NURSX=0:0
SET NURSX=$ORDER(^NURSF(211.8,"AE",ID,1,NURSX))
if NURSX'>0
QUIT
FOR NURSZ=0:0
SET NURSZ=$ORDER(^NURSF(211.8,"AE",ID,1,NURSX,NURSZ))
if NURSZ'>0
QUIT
IF +$GET(^NURSF(211.8,NURSX,1,NURSZ,0))
Begin DoDot:1
+4 SET NURS("AE",(9999999-+$GET(^NURSF(211.8,NURSX,1,NURSZ,0))),NURSX,NURSZ)=""
+5 QUIT
End DoDot:1
+6 IF $ORDER(NURS("AE",0))
SET NURSX=$ORDER(NURS("AE",0))
SET NOD1=$ORDER(NURS("AE",NURSX,0))
SET NOD2=$ORDER(NURS("AE",NURSX,NOD1,0))
SVPOS if '$DATA(^NURSF(211.8,+NOD1,1,+NOD2,0))
QUIT
SET NPNT=$PIECE(^NURSF(211.8,NOD1,1,NOD2,0),U,3)
SET NPSPOS=$SELECT('$DATA(^NURSF(211.3,NPNT,0)):"",1:$PIECE(^(0),U))
SET NPSPOS(0)=NPNT
SET NPSPOS(1)=$SELECT('$DATA(^NURSF(211.3,NPNT,0)):"",1:$PIECE(^(0),U,5))
+1 SET SC44DA=+$GET(^NURSF(211.8,NOD1,0))
SET NUR2114D=$ORDER(^NURSF(211.4,"B",SC44DA,0))
+2 SET NPNT(1)=+$PIECE(^NURSF(211.3,NPNT,0),U,7)
SET NURFLAG=1
+3 ; GET PRODUCT LINE/FACILITY OF PRIMARY POSITION
+4 SET NPSPOS(2)=$SELECT(NPNT(1):$$GET1^DIQ(212.7,NPNT(1),.01,"I"),1:"")
+5 SET (NPSPOS(3),NPSPOS(4))=""
IF NOD1
Begin DoDot:1
+6 SET NPSPOS(3)=$$EN11^NURSUT3(NOD1)
+7 SET NPSPOS(4)=$$EN13^NURSUT3(NOD1)
End DoDot:1
+8 KILL NURS,NURFLAG,NPI,NPNT,NPI1,ID
QUIT
+9 QUIT
EN3 ; SELECT FIRST ACTIVE PRIMARY ASSIGNMENT
+1 SET (NOD1,NOD2)=""
SET NURFLAG=0
SET ID=$SELECT($PIECE($GET(^NURSF(210,+DA,0)),U):$PIECE(^(0),U),1:"")
if ID=""
QUIT
+2 FOR NUI(1)=0:0
SET NUI(1)=$ORDER(^NURSF(211.8,"AE",ID,1,NUI(1)))
if NUI(1)'>0!(NURFLAG=1)
QUIT
FOR NUI=0:0
SET NUI=$ORDER(^NURSF(211.8,"AE",ID,1,NUI(1),NUI))
if NUI'>0!(NURFLAG=1)
QUIT
DO CHECK
+3 KILL NUI,ID
+4 QUIT
CHECK ;
+1 IF +$PIECE(^NURSF(211.8,NUI(1),1,NUI,0),U)'>DT&(('+$PIECE(^(0),U,6))!($PIECE(^(0),U,6)'<DT))
SET NOD1=NUI(1)
SET NOD2=NUI
SET NOD2(1)=$PIECE(^(0),U)
SET NURFLAG=1
+2 QUIT
EN4 ;SET LOGIC FOR DE XREF OF 211.82 SUBFILE
+1 if +$PIECE(NUR,U,3)
SET ^NURSF(211.8,"AD",X,$PIECE(NUR,U,3),DA(1),DA)=""
if +$PIECE(NUR,U,9)
SET ^NURSF(211.8,"AE",X,$PIECE(NUR,U,9),DA(1),DA)=""
KILL NUR
+2 QUIT
EN5 ;KILL LOGIC FOR DE XREF 0F 211.82 SUBFILE
+1 if +$PIECE(NUR,U,3)
KILL ^NURSF(211.8,"AD",X,$PIECE(NUR,U,3),DA(1),DA)
if +$PIECE(NUR,U,9)
KILL ^NURSF(211.8,"AE",X,$PIECE(NUR,U,9),DA(1),DA)
KILL NUR
+2 QUIT
EN6 ; SELECT MULTIPLE REPORT COPIES
+1 WRITE !?5,"How many copies of this report are required: 1// "
READ NCOPY:DTIME
+2 IF NCOPY=U!('$TEST)
SET NURQUIT=1
QUIT
+3 if NCOPY=""
SET NCOPY=1
IF NCOPY'=+NCOPY!(NCOPY<1)!(NCOPY>20)
WRITE !,$CHAR(7),?5,"ANSWER WITH A NUMBER BETWEEN 1 AND 20",!!
GOTO EN6
+4 QUIT
EN7 ; NURS DEVICE HANDLING/QUEUEING LOGIC
+1 KILL ZTSK
SET %ZIS="Q"
if $GET(NURS132)
SET %ZIS("B")=""
+2 DO ^%ZIS
KILL %ZIS
if POP
KILL IO("Q")
IF POP
SET (NUROUT,NURQUIT)=1
QUIT
+3 IF IO'=IO(0)
IF $EXTRACT(IOST)="P"
IF '$DATA(IO("Q"))
IF '$DATA(IO("S"))
IF IOST'["P-MESSAGE-HFS"
SET XQH="NURS-PRINTER QUEUE"
WRITE $CHAR(7)
DO EN^XQH
KILL XQH
GOTO EN7
+4 IF $GET(NURS132)
IF IOM<132
DO ^%ZISC
WRITE !,$CHAR(7)," ** THIS REPORT MUST BE SENT TO A 132 COLUMN DEVICE **",!
KILL IO("Q"),IO("C")
GOTO EN7
+5 IF '$DATA(ZTDESC)
SET ZTDESC=$SELECT($DATA(ZTRTN):ZTRTN,1:"Unknown NURSING option")
+6 FOR X="A*","B*","C*","D*","E*","F*","G*","H*","I*","J*","K*","L*","M*","N*","O*","P*","Q*","R*","S*","T*","U*","V*","W*","Y*","Z*"
SET ZTSAVE(X)=""
+7 SET NURQUEUE=0
IF $DATA(IO("Q"))
KILL IO("Q"),IO("C")
SET NURQUEUE=1
SET ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL
DO ^%ZTLOAD
SET NURQUEUE=0
if '$DATA(ZTSK)
SET POP=1
+8 QUIT
EN8 ; INPUT TRANSFORM FOR 2.1 & 2.5 SUBFIELDS OF FIELD 22.5
+1 ;OF FILE 210
+2 SET NURS(0)=$SELECT($DATA(^NURSF(210,DA(1),20,DA,0)):^(0),1:"")
SET NURS("HELP")="DATE MUST BE "_$PIECE("GREATER THAN DATE STARTED OR A VALID DATE ^LESS THAN DATE ENDED OR A VALID DATE ",U,NURS*10=21+1)
+3 SET %DT(0)=+($EXTRACT("-",NURS*10=21)_$PIECE(NURS(0),U,$EXTRACT(56,NURS*10=21+1)))
+4 SET NURS(1)=$SELECT(NURS=2.5&%DT(0)=0:1,1:0)
+5 if %DT(0)=0
KILL %DT(0)
SET %DT="E"
DO ^%DT
SET X=Y
IF Y<1
WRITE !?5,NURS("HELP")
KILL X,NURS
QUIT
+6 SET %DT(0)="-"_DT
SET %DT="E"
DO ^%DT
SET X=Y
IF Y<1
WRITE !?5,"DATE MUST BE A CURRENT OR PAST DATE"
KILL X,NURS
QUIT
+7 IF NURS(1)
SET $PIECE(^NURSF(210,DA(1),20,DA,0),U,5)=X
+8 KILL %DT,NURS
+9 QUIT
EN9 ; FIND TOUR OF DUTY FROM STAFF FILE
+1 DO EN3^NURSUT0
SET NUR=$SELECT('$DATA(^NURSF(211.8,+NOD1,1,+NOD2,0)):"",1:$PIECE(^(0),U,10))
SET NUR(1)=$SELECT('$DATA(^NURSF(211.6,+NUR,0)):"",1:$PIECE(^(0),U))
+2 KILL NOD1,NOD2
+3 QUIT
EN11(D0) ; PRINT EMPLOYEE MI REVIEW GROUPS
+1 SET VA200DA=+$GET(^NURSF(210,D0,0))
SET SSN=$PIECE($GET(^VA(200,+VA200DA,1)),U,9)
SET PDA=$SELECT(SSN="":0,1:$ORDER(^PRSPC("SSN",SSN,0)))
+2 IF PDA>0
WRITE !,?$SELECT($GET(EDIT)=1:0,1:9),"MI REVIEW GROUP: "
FOR D1=0:0
SET D1=$ORDER(^PRSPC(PDA,5,D1))
if D1'>0
QUIT
IF $GET(^PRSPC(PDA,5,D1,0))'=""
SET PRSE=+$GET(^(0))
WRITE ?$SELECT($GET(EDIT)=1:18,1:26),$PIECE($GET(^PRSE(452.3,+PRSE,0)),U)
if $ORDER(^PRSPC(PDA,5,D1))
WRITE !
+3 QUIT
EN12(DA) ; PRINT EMPLOYEE SALARY
+1 NEW X,Y,DM,D0,DE,DC,DG,DI,DIC,DIEL,DIFLD,DK,DQ,DP,DH,DL,DIE,DR
+2 SET SDA=DA
SET (PDA,XXX)=0
SET DA200=+$GET(^NURSF(210,DA,0))
SET SSN=$PIECE($GET(^VA(200,+DA200,1)),U,9)
if $GET(SSN)'=""
SET PDA=$ORDER(^PRSPC("SSN",SSN,0))
+3 IF PDA>0
SET XXX=$PIECE($GET(^PRSPC(PDA,0)),U,29)
SET Y=$PIECE($GET(^(0)),U,28)
if +Y>0
DO D^DIQ
SET $PIECE(XXX,U,2)=Y
SET DA=SDA
KILL PDA,SSN,DA200
+4 QUIT XXX
EN13(DA) ; LATEST PROMOTION DATE
+1 NEW X,Y,DM,D0,DE,DC,DG,DI,DIC,DIEL,DIFLD,DK,DQ,DP,DH,DL,DIE,DR
+2 SET SDA=DA
SET Z=$ORDER(^NURSF(210,DA,9,"AA",0))
SET Y=(9999999-Z)
if +Y>0
DO D^DIQ
SET XXX=Y
+3 QUIT XXX
