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

SCMCDD.m

Go to the documentation of this file. 
  1. SCMCDD ;ALB/REW - DD Calls used by PCMM ; 6 November 1995
  1.  ;;5.3;Scheduling;**41,51,177,204,1015**;AUG 13, 1993;Build 21
  1.  ;1
  1. NEWHIST(FILE,IEN,DATE,SCERR,STATUS) ; PCMM history files - new record's dt & status
  1.  ; Complete
  1.  ; input:
  1.  ;   FILE   = 404.52,404.53,404.58, or 404.59
  1.  ;   IEN    = if file=404.58 - pointer to 404.51
  1.  ;            otherwise      - pointer to 404.57
  1.  ;   DATE   = effective date
  1.  ;   SCERR  = [default = "SCERR"]
  1.  ;   STATUS = [optional] 1=active/0=inactive - IF undefined don't check
  1.  ; output:
  1.  ;   Returned: 1 if ok to add, 0 if not^message^external
  1.  ;  Note: For 404.52: special case
  1.  ;   @scerr = error message array
  1.  N SCDATES,SCX,SCOK,DIERR,SCLASTDT,Y,X
  1.  N SCLSEQ,SCN,SCESEQ,SCPARM,SCP,SCBEGIN,SCEND,SCINCL,SCDTS
  1.  S SCOK=1
  1.  ;verify date is after last date
  1.  S SCLASTDT=$$LASTDATE^SCAPMCU1(FILE,IEN)
  1.  IF SCLASTDT&(SCLASTDT'<DATE) D  G QTNWHIST
  1.  .S Y=SCLASTDT D DD^%DT
  1.  .S SCOK="0^New Date is not after last historical date("_Y_")"_U_SCLASTDT
  1.  S SCX=$$DATES^SCAPMCU1(FILE,IEN,DATE)
  1.  IF SCX<0 D  G QTNWHIST
  1.  .S SCOK=0_U_"Error in ACTHIST call"
  1.  .S SCPARM("NEW ENTRY")="Error in ACTHIST call"
  1.  .D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
  1.  IF DATE'>$P(SCX,U,2)!(DATE'>$P(SCX,U,3)) D  G QTNWHIST
  1.  .S SCOK=0_U_"Date On or Before Last Entry"
  1.  .S SCPARM("EFFECTIVE DATE")=DATE
  1.  .D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
  1.  ;bp/cmf 204 new code begin
  1.  I $$BADNEWDT^SCMCDDA G QTNWHIST
  1.  ;bp/cmf 204 new code end
  1.  ;skip to end if status is not defined
  1.  IF '$D(STATUS)!($G(STATUS)="") G QTNWHIST
  1.  IF STATUS=+SCX D  G QTNWHIST
  1.  .S SCOK=0_U_"Status Must Change from Prior Entry -  Current Status is "_$S(STATUS:"Active",1:"Inactive")
  1. QTNWHIST Q SCOK
  1.  ;
  1. OKDEL(FILE,HISTIEN,SCERR) ;PCMM history files - delete record
  1.  ; input:
  1.  ;   FILE   = History File: 404.52,404.53,404.58, or 404.59
  1.  ;   HISTIEN    = Entry in FILE
  1.  ;   SCERR  = [default = "SCERR"]
  1.  ; output:
  1.  ;   Returned: 1 if ok to delete, 0 if not^message
  1.  ;   @scerr = error message array
  1.  N SCLASTDT,SCX,ROOT,SCNODE,SCOK,SCSTATUS
  1.  S SCOK=1
  1.  S ROOT="^SCTM("_FILE_","_HISTIEN_",0)"
  1.  S SCNODE=$G(@ROOT)
  1.  S SCLASTDT=$$LASTDATE^SCAPMCU1(FILE,$P(SCNODE,U,1)) ;1st pc=tm or pos
  1.  IF SCLASTDT'=$P(SCNODE,U,2) D  G QTOKDEL
  1.  .S Y=SCLASTDT D DD^%DT
  1.  .S SCOK=0_U_"Date is not last historical date ("_Y_")"_U_SCLASTDT
  1.  ;if active check if ok to inactivate
  1.  S SCSTATUS=+$P(SCNODE,U,+($S((FILE=404.52)!(FILE=404.53):4,1:3)))
  1.  S:SCSTATUS SCOK=$$OKINACT(FILE,$P(SCNODE,U,1),SCLASTDT,.SCERR)
  1. QTOKDEL Q SCOK
  1.  ;
  1. OKINACT(FILE,IEN,DATE,SCERR) ;PCMM history files - inactivate record?
  1.  ; input:
  1.  ; ** Complete **
  1.  ; input:
  1.  ;   FILE   = History File: 404.52,404.53,404.58, or 404.59
  1.  ;   IEN    = IEN of non-History File:
  1.  ;                Team Position (#404.57) for 404.52 & 404.59
  1.  ;                Team (#404.51) for 404.58
  1.  ;   DATE   = Date to inactivate
  1.  ;   SCERR  = [default = "SCERR"]
  1.  ; output:
  1.  ;   Returned: 1=ok on date/0 ow^1=ok in future/0 ow^message^techmessage
  1.  ;   @scerr = error message array
  1.  N SCLASTDT,SCX,ROOT,SCNODE,SCSTAT,SCOK,SCI,SCTP,SCOK,SCTPLST,SCPTLST,SCCLIN
  1.  S SCOK=1
  1.  S SCLASTDT=$$LASTDATE^SCAPMCU1(FILE,IEN)
  1.  IF DATE<SCLASTDT D  G QTOKIN
  1.  .S Y=SCLASTDT D DD^%DT
  1.  .S SCOK="0^^Date is before last historical date("_Y_")"_U_SCLASTDT
  1.  S SCDT("BEGIN")=DATE
  1.  S SCDT("END")=3990101 ;infinite future
  1.  S SCDT("INCL")=0 ;does not have to be continuous
  1.  S SCX=$$ACTHIST^SCAPMCU2(FILE,IEN,"SCDT",.SCERR)
  1.  IF SCX'>0 D  G QTOKIN
  1.  .S:SCX<0 SCOK="0^^Error in active history call"
  1.  .IF 'SCX D
  1.  ..S Y=DATE D DD^%DT
  1.  ..S SCOK="0^^Entry not active for date("_Y_")"_U_DATE
  1. TEAMHIS IF FILE=404.58 D
  1.  .; -- check positions for team
  1.  .IF '$$TPTM^SCAPMC(IEN,"SCDT",,,"SCTPLST",.SCERR) S SCOK=0_U_U_"Error in Position List Call" Q
  1.  .F SCI=1:1 S SCTP=$P($G(SCTPLST(SCI)),U,1) Q:'SCTP  D  Q:'SCOK
  1.  ..; -- check if position is active
  1.  ..IF '$P(SCTPLST(SCI),U,6)!($P(SCTPLST(SCI),U,6)>DATE) D  Q
  1.  ...S Y=$P(SCTPLST(SCI),U,2) D DD^%DT
  1.  ...S SCOK="0^^Active Team Position^"_$P($G(^SCTM(404.57,SCTP,0)),U,1)_" as of "_Y_U_SCTP_U_$P(SCTPLST(SCI),U,1)
  1.  ..S SCX=$$OKINACT(404.59,SCTP,DATE,.SCERR)
  1.  ..S:$P(SCX,U,1,2)["1" SCOK=SCX
  1.  .; -- check for patients assigned to team - 999 - maybe able to remove
  1.  .IF '$$PTTM^SCAPMC(IEN,"SCDT","^TMP($J,""SCPTLST"")",.SCERR) S SCOK=0_U_U_"Error in Patient List Call" Q
  1.  .F SCI=1:1 S SCPT=$P($G(^TMP($J,"SCPTLST",SCI)),U,1) Q:'SCPT  D  Q:'SCOK
  1.  ..IF $P(^TMP($J,"SCPTLST",SCI),U,4)>DATE S SCOK="1^0^Patient "_$P(^TMP($J,"SCPTLST",SCI),U,2)_" is active in the future" Q
  1.  ..IF $P(^TMP($J,"SCPTLST",SCI),U,5)<DATE S SCOK=0_U_U_"Patient ("_$P(^TMP($J,"SCPTLST",SCI),U,2)_") is active"_U_$P(^TMP($J,"SCPTLST",SCI),U,1)_U_$P(^TMP($J,"SCPTLST",SCI),U,2) Q
  1. POSHIS IF FILE=404.59 D
  1.  .; -- check for practitioners assigned to position
  1.  .IF '$$PRTP^SCAPMC(IEN,"SCDT","SCPRLST",.SCERR) S SCOK=0_U_U_"Error in Practitioner List Call" Q
  1.  .F SCI=1:1 S SCPR=$P($G(SCPRLST(SCI)),U,1) Q:'SCPR  D  Q:'SCOK
  1.  ..IF $P(SCPRLST(SCI),U,7)>DATE S SCOK="1^0^Team Member "_$P(SCPRLST(SCI),U,2)_" is active in the future in position "_U_$P(SCPRLST(SCI),U,1)_U_IEN Q
  1.  ..IF $P(SCPRLST(SCI),U,8)<DATE S SCOK="0^^Team Member "_$P(SCPRLST(SCI),U,2)_" is active in position "_U_$P(SCPRLST(SCI),U,1)_U_IEN Q
  1.  .;check if a clinic is assigned to position
  1.  .S SCCLIN=$P($G(^SCTM(404.57,IEN,0)),U,9) Q:'SCCLIN  D
  1.  ..S SCOK="0^^Clinic ("_$P($G(^SC(SCCLIN,0)),U,1)_") is associated with position"_U_SCCLIN
  1.  .;check for patients assigned to position
  1.  .IF '$$PTTP^SCAPMC(IEN,"SCDT","^TMP($J,""SCPTLST"")",.SCERR) S SCOK="0^^Error in patient list call" Q
  1.  .F SCI=1:1 S SCPT=$P($G(^TMP($J,"SCPTLST",SCI)),U,1) Q:'SCPT  D  Q:'SCOK
  1.  ..IF $P(SCPTLST(SCI),U,4)>DATE S SCOK="1^0^Patient "_$P(SCPTLST(SCI),U,1)_" is active in the future" Q
  1.  ..IF $P(^TMP($J,"SCPTLST",SCI),U,5)<DATE S SCOK=0_U_U_"Patient "_$P(^TMP($J,"SCPTLST",SCI),U,2)_" is active"_U_$P(^TMP($J,"SCPTLST",SCI),U,1) Q
  1.  ;IF FILE=404.52 or 404.53 - NO FURTHER CHECKS NEEDED
  1. QTOKIN Q SCOK
  1.  ;
  1. OKCHGDT(FILE,HISTIEN,DATE,SCERR) ;PCMM history files - ok to change date?
  1.  ; input:
  1.  ;   FILE   = History File: 404.52,404.53,404.58, or 404.59
  1.  ;   HISTIEN - IEN of History File (404.52,404.58 or 404.59)
  1.  ;   SCERR  = [default = "SCERR"]
  1.  ; output:
  1.  ;   Returned: 1 if ok to change date, 0 if not^message
  1.  ;   @scerr = error message array
  1.  N SCX,ROOT,SCNODE,SCSTAT,SCOK
  1.  S SCOK=1
  1.  S ROOT="^SCTM("_FILE_","_HISTIEN_",0)"
  1.  S SCNODE=$G(@ROOT)
  1.  IF 'SCNODE S SCOK="0^Bad or Corrupt File Entry"_U_HISTIEN G QTOKCHK
  1.  S SCSTAT=$S(FILE=404.52:$P(SCNODE,U,4),1:$P(SCNODE,U,3))
  1.  ;check next & previous effective dates (must be of other status)
  1.  ; i.e. if active check next & previous for inactive
  1.  S SCX=$$DTAFTER^SCAPMCU2(FILE,$P(SCNODE,U,1),('SCSTAT),$P(SCNODE,U,2))
  1.  IF SCX&(DATE'<SCX) D  G QTOKCHK
  1.  .S Y=+SCX D DD^%DT
  1.  .S SCOK=0_U_"Date Must be before "_Y_U_SCX
  1.  S SCX=$$DTBEFORE^SCAPMCU2(FILE,$P(SCNODE,U,1),('SCSTAT),$P(SCNODE,U,2))
  1.  IF DATE'>SCX D  G QTOKCHK
  1.  .S Y=+SCX D DD^%DT
  1.  .S SCOK=0_U_"Date Must be after "_Y_U_SCX
  1.  ;bp/cmf 204 new code begin
  1.  I $$BADCHGDT^SCMCDDA G QTOKCHK
  1.  ;bp/cmf 204 new code end
  1.  ;
  1. QTOKCHK Q SCOK