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