- 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 Jan 18, 2025@03:41:40 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