source: FOIAVistA/trunk/r/NURSING_SERVICE-NUR/NURSUT0.m@ 1397

Last change on this file since 1397 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 5.5 KB
Line 
1NURSUT0 ;HIRMFO/MD,RM,FT-NURS STAFF FILE EDIT UTILITY ; 1/17/03 2:54pm
2 ;;4.0;NURSING SERVICE;**1,16,18,33,34,38**;Apr 25, 1997
3 ;
4 ; Reference to File #452.3 is supported by IA #1400
5 ; Reference to ^PRSPC is supported by IA #1402
6 ; File #200 is covered by supported reference #10060
7 ;
8EN1(NURSEMP,NURSDT) ; DETERMINE IF EMPLOYEE HAS ANY ACTIVE ASSIGNMENTS
9 ;VARIBLES NURSDT=TODAY, AND NURSEMP=EMPLOYEE POINTER TO FILE 200
10 ;ARE PASSED INTO THE ROUTINE AND VARIBLE NURSTAT IS RETURNED=1 IF AN
11 ;ACTIVE POSITION EXISTS AND NURSTAT=0 IF NO ACTIVE POSITIONS EXIST.
12 ;ACTIVE POSITIONS HAVE A START DATE '>TODAY AND NO VACANCY DATE OR A
13 ;VACANCY DATE '<TODAY
14 S NURSTAT=0,NURSDT=$P(NURSDT,".") D
15 .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
16 .K NURSDT,NURSEMP,NURI
17 .Q
18 Q $S(NURSTAT=1:1,1:0)
19EN2 ; FIND PRIMARY SERVICE POSITION
20 Q:'$D(^NURSF(210,DA,0)) S ID=+^(0) Q:ID'>0 S (NOD1,NOD2,NPSPOS,NPSPOS(0),NPSPOS(1))=""
21 I '($P(^NURSF(210,DA,0),U,2)="R") D EN3 G SVPOS
22 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
23 . S NURS("AE",(9999999-+$G(^NURSF(211.8,NURSX,1,NURSZ,0))),NURSX,NURSZ)=""
24 . Q
25 I $O(NURS("AE",0)) S NURSX=$O(NURS("AE",0)),NOD1=$O(NURS("AE",NURSX,0)),NOD2=$O(NURS("AE",NURSX,NOD1,0))
26SVPOS 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))
27 S SC44DA=+$G(^NURSF(211.8,NOD1,0)),NUR2114D=$O(^NURSF(211.4,"B",SC44DA,0))
28 S NPNT(1)=+$P(^NURSF(211.3,NPNT,0),U,7),NURFLAG=1
29 ; GET PRODUCT LINE/FACILITY OF PRIMARY POSITION
30 S NPSPOS(2)=$S(NPNT(1):$$GET1^DIQ(212.7,NPNT(1),.01,"I"),1:"")
31 S (NPSPOS(3),NPSPOS(4))="" I NOD1 D
32 . S NPSPOS(3)=$$EN11^NURSUT3(NOD1)
33 . S NPSPOS(4)=$$EN13^NURSUT3(NOD1)
34 K NURS,NURFLAG,NPI,NPNT,NPI1,ID Q
35 Q
36EN3 ; SELECT FIRST ACTIVE PRIMARY ASSIGNMENT
37 S (NOD1,NOD2)="",NURFLAG=0,ID=$S($P($G(^NURSF(210,+DA,0)),U):$P(^(0),U),1:"") Q:ID=""
38 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
39 K NUI,ID
40 Q
41CHECK ;
42 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
43 Q
44EN4 ;SET LOGIC FOR DE XREF OF 211.82 SUBFILE
45 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
46 Q
47EN5 ;KILL LOGIC FOR DE XREF 0F 211.82 SUBFILE
48 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
49 Q
50EN6 ; SELECT MULTIPLE REPORT COPIES
51 W !?5,"How many copies of this report are required: 1// " R NCOPY:DTIME
52 I NCOPY=U!('$T) S NURQUIT=1 Q
53 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
54 Q
55EN7 ; NURS DEVICE HANDLING/QUEUEING LOGIC
56 K ZTSK S %ZIS="Q" S:$G(NURS132) %ZIS("B")=""
57 D ^%ZIS K %ZIS K:POP IO("Q") I POP S (NUROUT,NURQUIT)=1 Q
58 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
59 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
60 I '$D(ZTDESC) S ZTDESC=$S($D(ZTRTN):ZTRTN,1:"Unknown NURSING option")
61 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)=""
62 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
63 Q
64EN8 ; INPUT TRANSFORM FOR 2.1 & 2.5 SUBFIELDS OF FIELD 22.5
65 ;OF FILE 210
66 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)
67 S %DT(0)=+($E("-",NURS*10=21)_$P(NURS(0),U,$E(56,NURS*10=21+1)))
68 S NURS(1)=$S(NURS=2.5&%DT(0)=0:1,1:0)
69 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
70 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
71 I NURS(1) S $P(^NURSF(210,DA(1),20,DA,0),U,5)=X
72 K %DT,NURS
73 Q
74EN9 ; FIND TOUR OF DUTY FROM STAFF FILE
75 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))
76 K NOD1,NOD2
77 Q
78EN11(D0) ; PRINT EMPLOYEE MI REVIEW GROUPS
79 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)))
80 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)) !
81 Q
82EN12(DA) ; PRINT EMPLOYEE SALARY
83 N X,Y,DM,D0,DE,DC,DG,DI,DIC,DIEL,DIFLD,DK,DQ,DP,DH,DL,DIE,DR
84 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))
85 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
86 Q XXX
87EN13(DA) ; LATEST PROMOTION DATE
88 N X,Y,DM,D0,DE,DC,DG,DI,DIC,DIEL,DIFLD,DK,DQ,DP,DH,DL,DIE,DR
89 S SDA=DA,Z=$O(^NURSF(210,DA,9,"AA",0)),Y=(9999999-Z) D:+Y>0 D^DIQ S XXX=Y
90 Q XXX
Note: See TracBrowser for help on using the repository browser.