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