Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SCMCHLP

SCMCHLP.m

Go to the documentation of this file.
  1. SCMCHLP ;ALB/JDS PCMM WORKLOAD MESSAGE ; 28 Feb 2003 7:54 AM ; Compiled July 8, 2008 16:29:48
  1. ;;5.3;Scheduling;**272,297,534**;AUG 13, 1993;Build 8
  1. ;this version reverts BUILD & SUM to pre 297 - swo/largo 3.31.2006
  1. ;Ftee message
  1. EVN(DATE,ASSDT) ;create evn segment
  1. I '$G(DATE) D NOW^%DTC S DATE=$E(%,1,12)
  1. S MSG=$$EN^VAFHLEVN("B02",DATE,,"^","^")
  1. S $P(MSG,"^",7)=$$HLDATE^HLFNC(ASSDT,"TS")
  1. S @XMITARRY@(1,1,2)=MSG
  1. Q
  1. STF(PH) ;staff segment
  1. N I,ZERO
  1. ;ph pointer to position assignment file
  1. ;S ZERO=$G(^SCTM(404.52,+$G(PH),0)) Q:'$P(ZERO,U,3)
  1. ;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)
  1. N A S A("FILE")=200,A("FIELD")=.01,A("IENS")=DOC
  1. S MSG="STF^^"_DOC_"~~~USVHA~LR~"_INST_"|"_SSN_"~~~USSA~SS"_"^"_$$HLNAME^XLFNAME(.A,"","~")
  1. S $P(MSG,U,13)=$$HLDATE^HLFNC($P($G(PZERO),U,5),"TS")
  1. S $P(MSG,U,14)=$$HLDATE^HLFNC($P($G(ZERO),U,6),"TS")
  1. S @XMITARRY@(1,1,3)=MSG
  1. Q
  1. ORG(PH) ;ORG SEGMENT
  1. ;PH pointer to position assignment filePC
  1. S @XMITARRY@(1,1,4)="ORG^1^"_INST_"~"_INSTNM_"^^^^^^"_PC
  1. Q
  1. MSH(PH) ;
  1. N I,ZERO,PZERO,VARDOC
  1. S DOC=0
  1. S SCMSGCNT=$G(SCMSGCNT)+1
  1. ;ph pointer to position assignment file
  1. S ZERO=$G(^SCTM(404.52,+$G(PH),0)) Q:'$P(ZERO,U,3)
  1. 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)
  1. MSH1 ;Know DOC nad INSTI
  1. S INSTNM=$$GET1^DIQ(4,(+INSTI)_",",.01),INST=$$GET1^DIQ(4,(+INSTI)_",",99)
  1. ;S MAX=+$P($G(^SCTM(404.57,+ZERO,0)),U,8)
  1. S SSN=$$GET1^DIQ(200,(+DOC)_",",9)
  1. S (MAX,FTEE)=0 D SUM(DOC,INSTI)
  1. S PC=U
  1. S (PZERO,ZERO)=$$GET^XUA4A72(+DOC)
  1. I ZERO'>0 N I,FTOK S I="" D
  1. .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>0
  1. I ZERO'>0,'$G(FTOK) S DOC=0 Q
  1. S PC=$P(ZERO,U,7)_"~"_$P(ZERO,U,2)
  1. S HL("SAF")=INST Q
  1. D CREATE^HLTF(.ID)
  1. ;D HL
  1. D MSH^HLFNC2(.HL,ID_"-"_SCMSGCNT,.MSG)
  1. D NOW^%DTC S $P(MSG,"^",7)=$$HLDATE^HLFNC(%,"TS")
  1. S @XMITARRY@(1,1,1)=MSG
  1. Q
  1. ZFT S @XMITARRY@(1,1,5)="ZFT^1^"_FTEE_"^"_MAX
  1. Q
  1. HL S HL("ACAT")="NE"
  1. S HL("APAT")="AL"
  1. S HL("ECH")="~|\&"
  1. S HL("ETN")="B02"
  1. S HL("FS")="^"
  1. S HL("MTN")="PMU"
  1. S HL("Q")=""""""
  1. S HL("SAF")=$G(^DD("SITE",1))
  1. S HL("SAN")="PCMM"
  1. S HL("VER")=2.4
  1. S HL("PID")="P"
  1. Q
  1. BUILD(VAPTR,HL,XMITARRY,HLIEN) ;Build array given pointer.
  1. ;check which file and build based on that
  1. ;If team file check if active and PC send message with new max panel
  1. ;if possition assignment history check status
  1. ;if active send FTEE
  1. ;if inactive check if PC and send zero in FTEE
  1. ;if from Team position file check if pc and send zero in FTEE.
  1. N %,DOC,EVNDATE,FTEE,ID,INSTI,INSTNM,MAX,MSG,PC,SCFUT,SSN,TP,TEAM,Z1
  1. S EVNDATE=$G(^SCPT(404.48,+$G(HLIEN),0)) I 'EVNDATE D NOW^%DTC S EVNDATE=%
  1. N HL D HL
  1. S ZERO=$G(@(U_$P(VAPTR,";",2)_(+VAPTR)_",0)")) I '$L(ZERO) D Q 1 ;Record has vanished
  1. .N IEN S IEN=$O(^SCPT(404.471,"AWRK",VAPTR,""),-1) Q:'IEN ;not transmitted
  1. .S TP=$P($G(^SCPT(404.48,+$G(HLIEN),0)),U,4) Q:'TP
  1. .S ACTIVE=$$DATES^SCAPMCU1(404.52,+TP)
  1. .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
  1. .S DOC=$P($G(^SCPT(404.471,+IEN,0)),U,8) Q:'DOC
  1. .S INSTI=$P($G(^SCTM(404.51,+$P($G(^SCTM(404.57,+TP,0)),U,2),0)),U,7)
  1. .D MSH1,EVN(EVNDATE,$P(ACTIVE,U,2)),STF(),ORG(),ZFT
  1. I VAPTR[404.57 D Q 1 ;Team Position
  1. .S ACTIVE=$$DATES^SCAPMCU1(404.52,+VAPTR)
  1. .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
  1. I VAPTR[404.52 D Q 1 ;Position Assignment History
  1. .I $P(ZERO,U,2)>DT S SCFUT=1 Q ;future date wait till then
  1. .I $P(ZERO,U,2) S EVNDATE=$E($P(ZERO,U,2),1,7)_$E(EVNDATE,8,99)
  1. .D MSH(+VAPTR) Q:'DOC D EVN(EVNDATE,$P(ZERO,U,2)),STF(+VAPTR),ORG(+VAPTR)
  1. .D ZFT
  1. I VAPTR[404.59 D Q 1 ;Team Position History
  1. .I $P(ZERO,U,2)>DT S SCFUT=1 Q ;Future do it then
  1. .I $P(ZERO,U,2) S EVNDATE=$E($P(ZERO,U,2),1,7)_$E(EVNDATE,8,99)
  1. .;check if active assignment on inactive team
  1. .S ACTIVE=$$DATES^SCAPMCU1(404.52,$P(ZERO,U,1))
  1. .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))
  1. .D ZFT
  1. Q 1
  1. PROV(VAPTR) ;Get internal provider given varible pointer
  1. N ZERO,ACTIVE
  1. S ZERO=$G(@(U_$P(VAPTR,";",2)_(+VAPTR)_",0)"))
  1. I VAPTR[404.57 D Q $$PH($P(ACTIVE,U,4)) ;Team Position
  1. .S ACTIVE=$$DATES^SCAPMCU1(404.52,+VAPTR) Q:'ACTIVE
  1. I VAPTR[404.52 Q $$PH(+VAPTR)
  1. I VAPTR[404.59 D I ACTIVE Q $$PH(+VAPTR) ;Team Position History
  1. .;check if active assignment on inactive team
  1. .S ACTIVE=$$DATES^SCAPMCU1(404.52,$P(ZERO,U,1))
  1. Q 0
  1. PH(PH) ;Return provider from position history
  1. Q $P($G(^SCTM(404.52,+$G(PH),0)),U,3)
  1. SUM(PR,INST) ; get all the positions for this provider
  1. N I,INS,ZERO,SCA,TEAM
  1. S I=""
  1. F S I=$O(^SCTM(404.52,"C",PR,I),-1) Q:'I D
  1. .S ZERO=$G(^SCTM(404.52,I,0)) Q:$D(SCA(+ZERO)) S SCA(+ZERO)=""
  1. .S INS=$P($G(^SCTM(404.51,+$P($G(^SCTM(404.57,+ZERO,0)),U,2),0)),U,7)
  1. .Q:(INS'=INST)
  1. .S ACTIVE=$$DATES^SCAPMCU1(404.52,+ZERO,DT+.5) Q:'ACTIVE
  1. .S (Z1,ZERO)=$G(^SCTM(404.52,+$P(ACTIVE,U,4),0)) Q:$P(Z1,U,3)'=PR
  1. .S ACTIVE=$$DATES^SCAPMCU1(404.59,+Z1,DT+.5) Q:'ACTIVE
  1. .S Z1=$G(^SCTM(404.57,+Z1,0))
  1. .Q:'$P(Z1,U,4) ;Cannot be primary
  1. .S TEAM=$G(^SCTM(404.51,+$P(Z1,U,2),0))
  1. .Q:'$P(TEAM,U,5)
  1. .S FTEE=FTEE+$P(ZERO,U,9)
  1. .S MAX=MAX+$P(Z1,U,8)