source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCMCHLP.m@ 1742

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

initial load of FOIAVistA 6/30/08 version
File size: 5.3 KB
Line 
1SCMCHLP ;ALB/JDS PCMM WORKLOAD MESSAGE ; 28 Feb 2003 7:54 AM
2 ;;5.3;Scheduling;**272,297**;AUG 13, 1993
3 ;this version reverts BUILD & SUM to pre 297 - swo/largo 3.31.2006
4 ;Ftee message
5EVN(DATE,ASSDT) ;create evn segment
6 I '$G(DATE) D NOW^%DTC S DATE=$E(%,1,12)
7 S MSG=$$EN^VAFHLEVN("B02",DATE,,"^","^")
8 S $P(MSG,"^",7)=$$HLDATE^HLFNC(ASSDT,"TS")
9 S @XMITARRY@(1,1,2)=MSG
10 Q
11STF(PH) ;staff segment
12 N I,ZERO
13 ;ph pointer to position assignment file
14 ;S ZERO=$G(^SCTM(404.52,+$G(PH),0)) Q:'$P(ZERO,U,3)
15 ;S DOC=$P(ZERO,U,3),INST=$P($G(^SCTM(404.51,+$P($G(^SCTM(404.57,+ZERO,0)),U,2),0)),U,7),SSN=$$GET1^DIQ(200,(+DOC)_",",9),INSTNM=$$GET1^DIQ(4,(+INST)_",",.01),INST=$$GET1^DIQ(4,(+INST)_",",99)
16 N A S A("FILE")=200,A("FIELD")=.01,A("IENS")=DOC
17 S MSG="STF^^"_DOC_"~~~USVHA~LR~"_INST_"|"_SSN_"~~~USSA~SS"_"^"_$$HLNAME^XLFNAME(.A,"","~")
18 S $P(MSG,U,13)=$$HLDATE^HLFNC($P($G(PZERO),U,5),"TS")
19 S $P(MSG,U,14)=$$HLDATE^HLFNC($P($G(ZERO),U,6),"TS")
20 S @XMITARRY@(1,1,3)=MSG
21 Q
22ORG(PH) ;ORG SEGMENT
23 ;PH pointer to position assignment filePC
24 S @XMITARRY@(1,1,4)="ORG^1^"_INST_"~"_INSTNM_"^^^^^^"_PC
25 Q
26MSH(PH) ;
27 N I,ZERO,PZERO,VARDOC
28 S DOC=0
29 S SCMSGCNT=$G(SCMSGCNT)+1
30 ;ph pointer to position assignment file
31 S ZERO=$G(^SCTM(404.52,+$G(PH),0)) Q:'$P(ZERO,U,3)
32 S (VARDOC,DOC)=$P(ZERO,U,3),FTEE=+$P(ZERO,U,9),INSTI=$P($G(^SCTM(404.51,+$P($G(^SCTM(404.57,+ZERO,0)),U,2),0)),U,7)
33MSH1 ;Know DOC nad INSTI
34 S INSTNM=$$GET1^DIQ(4,(+INSTI)_",",.01),INST=$$GET1^DIQ(4,(+INSTI)_",",99)
35 ;S MAX=+$P($G(^SCTM(404.57,+ZERO,0)),U,8)
36 S SSN=$$GET1^DIQ(200,(+DOC)_",",9)
37 S (MAX,FTEE)=0 D SUM(DOC,INSTI)
38 S PC=U
39 S (PZERO,ZERO)=$$GET^XUA4A72(+DOC)
40 I 'ZERO N I,FTOK S I="" D
41 .F S I=$O(^SCTM(404.52,"C",+DOC,I),-1) Q:I="" S:'$G(FTOK) FTOK=$P($G(^SCTM(404.52,+I,0)),U,9) S (PZERO,ZERO)=$$GET^XUA4A72(+DOC,+$P($G(^SCTM(404.52,I,0)),U,8)) Q:ZERO
42 I 'ZERO,'$G(FTOK) S DOC=0 Q
43 S PC=$P(ZERO,U,7)_"~"_$P(ZERO,U,2)
44 S HL("SAF")=INST Q
45 D CREATE^HLTF(.ID)
46 ;D HL
47 D MSH^HLFNC2(.HL,ID_"-"_SCMSGCNT,.MSG)
48 D NOW^%DTC S $P(MSG,"^",7)=$$HLDATE^HLFNC(%,"TS")
49 S @XMITARRY@(1,1,1)=MSG
50 Q
51ZFT S @XMITARRY@(1,1,5)="ZFT^1^"_FTEE_"^"_MAX
52 Q
53HL S HL("ACAT")="NE"
54 S HL("APAT")="AL"
55 S HL("ECH")="~|\&"
56 S HL("ETN")="B02"
57 S HL("FS")="^"
58 S HL("MTN")="PMU"
59 S HL("Q")=""""""
60 S HL("SAF")=$G(^DD("SITE",1))
61 S HL("SAN")="PCMM"
62 S HL("VER")=2.4
63 S HL("PID")="P"
64 Q
65BUILD(VAPTR,HL,XMITARRY,HLIEN) ;Build array given pointer.
66 ;check which file and build based on that
67 ;If team file check if active and PC send message with new max panel
68 ;if possition assignment history check status
69 ;if active send FTEE
70 ;if inactive check if PC and send zero in FTEE
71 ;if from Team position file check if pc and send zero in FTEE.
72 N %,DOC,EVNDATE,FTEE,ID,INSTI,INSTNM,MAX,MSG,PC,SCFUT,SSN,TP,TEAM,Z1
73 S EVNDATE=$G(^SCPT(404.48,+$G(HLIEN),0)) I 'EVNDATE D NOW^%DTC S EVNDATE=%
74 N HL D HL
75 S ZERO=$G(@(U_$P(VAPTR,";",2)_(+VAPTR)_",0)")) I '$L(ZERO) D Q 1 ;Record has vanished
76 .N IEN S IEN=$O(^SCPT(404.471,"AWRK",VAPTR,""),-1) Q:'IEN ;not transmitted
77 .S TP=$P($G(^SCPT(404.48,+$G(HLIEN),0)),U,4) Q:'TP
78 .S ACTIVE=$$DATES^SCAPMCU1(404.52,+TP)
79 .I ((ACTIVE)!(VAPTR'[404.52)) D MSH(+$P(ACTIVE,U,4)) Q:'DOC D EVN(EVNDATE,$P(ACTIVE,U,2)),STF($P(ACTIVE,U,4)),ORG($P(ACTIVE,U,4)),ZFT Q
80 .S DOC=$P($G(^SCPT(404.471,+IEN,0)),U,8) Q:'DOC
81 .S INSTI=$P($G(^SCTM(404.51,+$P($G(^SCTM(404.57,+TP,0)),U,2),0)),U,7)
82 .D MSH1,EVN(EVNDATE,$P(ACTIVE,U,2)),STF(),ORG(),ZFT
83 I VAPTR[404.57 D Q 1 ;Team Position
84 .S ACTIVE=$$DATES^SCAPMCU1(404.52,+VAPTR)
85 .D MSH(+$P(ACTIVE,U,4)) Q:'DOC D EVN(EVNDATE,$P(ACTIVE,U,2)),STF($P(ACTIVE,U,4)),ORG($P(ACTIVE,U,4)),ZFT
86 I VAPTR[404.52 D Q 1 ;Position Assignment History
87 .I $P(ZERO,U,2)>DT S SCFUT=1 Q ;future date wait till then
88 .I $P(ZERO,U,2) S EVNDATE=$E($P(ZERO,U,2),1,7)_$E(EVNDATE,8,99)
89 .D MSH(+VAPTR) Q:'DOC D EVN(EVNDATE,$P(ZERO,U,2)),STF(+VAPTR),ORG(+VAPTR)
90 .D ZFT
91 I VAPTR[404.59 D Q 1 ;Team Position History
92 .I $P(ZERO,U,2)>DT S SCFUT=1 Q ;Future do it then
93 .I $P(ZERO,U,2) S EVNDATE=$E($P(ZERO,U,2),1,7)_$E(EVNDATE,8,99)
94 .;check if active assignment on inactive team
95 .S ACTIVE=$$DATES^SCAPMCU1(404.52,$P(ZERO,U,1))
96 .D MSH(+$P(ACTIVE,U,4)) Q:'DOC D EVN(EVNDATE,$P(ACTIVE,U,2)),STF(+$P(ACTIVE,U,4)),ORG(+$P(ACTIVE,U,4))
97 .D ZFT
98 Q 1
99PROV(VAPTR) ;Get internal provider given varible pointer
100 N ZERO,ACTIVE
101 S ZERO=$G(@(U_$P(VAPTR,";",2)_(+VAPTR)_",0)"))
102 I VAPTR[404.57 D Q $$PH($P(ACTIVE,U,4)) ;Team Position
103 .S ACTIVE=$$DATES^SCAPMCU1(404.52,+VAPTR) Q:'ACTIVE
104 I VAPTR[404.52 Q $$PH(+VAPTR)
105 I VAPTR[404.59 D I ACTIVE Q $$PH(+VAPTR) ;Team Position History
106 .;check if active assignment on inactive team
107 .S ACTIVE=$$DATES^SCAPMCU1(404.52,$P(ZERO,U,1))
108 Q 0
109PH(PH) ;Return provider from position history
110 Q $P($G(^SCTM(404.52,+$G(PH),0)),U,3)
111SUM(PR,INST) ; get all the positions for this provider
112 N I,INS,ZERO,SCA,TEAM
113 S I=""
114 F S I=$O(^SCTM(404.52,"C",PR,I),-1) Q:'I D
115 .S ZERO=$G(^SCTM(404.52,I,0)) Q:$D(SCA(+ZERO)) S SCA(+ZERO)=""
116 .S INS=$P($G(^SCTM(404.51,+$P($G(^SCTM(404.57,+ZERO,0)),U,2),0)),U,7)
117 .Q:(INS'=INST)
118 .S ACTIVE=$$DATES^SCAPMCU1(404.52,+ZERO,DT+.5) Q:'ACTIVE
119 .S (Z1,ZERO)=$G(^SCTM(404.52,+$P(ACTIVE,U,4),0)) Q:$P(Z1,U,3)'=PR
120 .S ACTIVE=$$DATES^SCAPMCU1(404.59,+Z1,DT+.5) Q:'ACTIVE
121 .S Z1=$G(^SCTM(404.57,+Z1,0))
122 .Q:'$P(Z1,U,4) ;Cannot be primary
123 .S TEAM=$G(^SCTM(404.51,+$P(Z1,U,2),0))
124 .Q:'$P(TEAM,U,5)
125 .S FTEE=FTEE+$P(ZERO,U,9)
126 .S MAX=MAX+$P(Z1,U,8)
Note: See TracBrowser for help on using the repository browser.