source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCMCDD.m@ 1800

Last change on this file since 1800 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.8 KB
Line 
1SCMCDD ;ALB/REW - DD Calls used by PCMM ; 6 November 1995
2 ;;5.3;Scheduling;**41,51,177,204**;AUG 13, 1993
3 ;1
4NEWHIST(FILE,IEN,DATE,SCERR,STATUS) ; PCMM history files - new record's dt & status
5 ; Complete
6 ; input:
7 ; FILE = 404.52,404.53,404.58, or 404.59
8 ; IEN = if file=404.58 - pointer to 404.51
9 ; otherwise - pointer to 404.57
10 ; DATE = effective date
11 ; SCERR = [default = "SCERR"]
12 ; STATUS = [optional] 1=active/0=inactive - IF undefined don't check
13 ; output:
14 ; Returned: 1 if ok to add, 0 if not^message^external
15 ; Note: For 404.52: special case
16 ; @scerr = error message array
17 N SCDATES,SCX,SCOK,DIERR,SCLASTDT,Y,X
18 N SCLSEQ,SCN,SCESEQ,SCPARM,SCP,SCBEGIN,SCEND,SCINCL,SCDTS
19 S SCOK=1
20 ;verify date is after last date
21 S SCLASTDT=$$LASTDATE^SCAPMCU1(FILE,IEN)
22 IF SCLASTDT&(SCLASTDT'<DATE) D G QTNWHIST
23 .S Y=SCLASTDT D DD^%DT
24 .S SCOK="0^New Date is not after last historical date("_Y_")"_U_SCLASTDT
25 S SCX=$$DATES^SCAPMCU1(FILE,IEN,DATE)
26 IF SCX<0 D G QTNWHIST
27 .S SCOK=0_U_"Error in ACTHIST call"
28 .S SCPARM("NEW ENTRY")="Error in ACTHIST call"
29 .D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
30 IF DATE'>$P(SCX,U,2)!(DATE'>$P(SCX,U,3)) D G QTNWHIST
31 .S SCOK=0_U_"Date On or Before Last Entry"
32 .S SCPARM("EFFECTIVE DATE")=DATE
33 .D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
34 ;bp/cmf 204 new code begin
35 I $$BADNEWDT^SCMCDDA G QTNWHIST
36 ;bp/cmf 204 new code end
37 ;skip to end if status is not defined
38 IF '$D(STATUS)!($G(STATUS)="") G QTNWHIST
39 IF STATUS=+SCX D G QTNWHIST
40 .S SCOK=0_U_"Status Must Change from Prior Entry - Current Status is "_$S(STATUS:"Active",1:"Inactive")
41QTNWHIST Q SCOK
42 ;
43OKDEL(FILE,HISTIEN,SCERR) ;PCMM history files - delete record
44 ; input:
45 ; FILE = History File: 404.52,404.53,404.58, or 404.59
46 ; HISTIEN = Entry in FILE
47 ; SCERR = [default = "SCERR"]
48 ; output:
49 ; Returned: 1 if ok to delete, 0 if not^message
50 ; @scerr = error message array
51 N SCLASTDT,SCX,ROOT,SCNODE,SCOK,SCSTATUS
52 S SCOK=1
53 S ROOT="^SCTM("_FILE_","_HISTIEN_",0)"
54 S SCNODE=$G(@ROOT)
55 S SCLASTDT=$$LASTDATE^SCAPMCU1(FILE,$P(SCNODE,U,1)) ;1st pc=tm or pos
56 IF SCLASTDT'=$P(SCNODE,U,2) D G QTOKDEL
57 .S Y=SCLASTDT D DD^%DT
58 .S SCOK=0_U_"Date is not last historical date ("_Y_")"_U_SCLASTDT
59 ;if active check if ok to inactivate
60 S SCSTATUS=+$P(SCNODE,U,+($S((FILE=404.52)!(FILE=404.53):4,1:3)))
61 S:SCSTATUS SCOK=$$OKINACT(FILE,$P(SCNODE,U,1),SCLASTDT,.SCERR)
62QTOKDEL Q SCOK
63 ;
64OKINACT(FILE,IEN,DATE,SCERR) ;PCMM history files - inactivate record?
65 ; input:
66 ; ** Complete **
67 ; input:
68 ; FILE = History File: 404.52,404.53,404.58, or 404.59
69 ; IEN = IEN of non-History File:
70 ; Team Position (#404.57) for 404.52 & 404.59
71 ; Team (#404.51) for 404.58
72 ; DATE = Date to inactivate
73 ; SCERR = [default = "SCERR"]
74 ; output:
75 ; Returned: 1=ok on date/0 ow^1=ok in future/0 ow^message^techmessage
76 ; @scerr = error message array
77 N SCLASTDT,SCX,ROOT,SCNODE,SCSTAT,SCOK,SCI,SCTP,SCOK,SCTPLST,SCPTLST,SCCLIN
78 S SCOK=1
79 S SCLASTDT=$$LASTDATE^SCAPMCU1(FILE,IEN)
80 IF DATE<SCLASTDT D G QTOKIN
81 .S Y=SCLASTDT D DD^%DT
82 .S SCOK="0^^Date is before last historical date("_Y_")"_U_SCLASTDT
83 S SCDT("BEGIN")=DATE
84 S SCDT("END")=3990101 ;infinite future
85 S SCDT("INCL")=0 ;does not have to be continuous
86 S SCX=$$ACTHIST^SCAPMCU2(FILE,IEN,"SCDT",.SCERR)
87 IF SCX'>0 D G QTOKIN
88 .S:SCX<0 SCOK="0^^Error in active history call"
89 .IF 'SCX D
90 ..S Y=DATE D DD^%DT
91 ..S SCOK="0^^Entry not active for date("_Y_")"_U_DATE
92TEAMHIS IF FILE=404.58 D
93 .; -- check positions for team
94 .IF '$$TPTM^SCAPMC(IEN,"SCDT",,,"SCTPLST",.SCERR) S SCOK=0_U_U_"Error in Position List Call" Q
95 .F SCI=1:1 S SCTP=$P($G(SCTPLST(SCI)),U,1) Q:'SCTP D Q:'SCOK
96 ..; -- check if position is active
97 ..IF '$P(SCTPLST(SCI),U,6)!($P(SCTPLST(SCI),U,6)>DATE) D Q
98 ...S Y=$P(SCTPLST(SCI),U,2) D DD^%DT
99 ...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)
100 ..S SCX=$$OKINACT(404.59,SCTP,DATE,.SCERR)
101 ..S:$P(SCX,U,1,2)["1" SCOK=SCX
102 .; -- check for patients assigned to team - 999 - maybe able to remove
103 .IF '$$PTTM^SCAPMC(IEN,"SCDT","^TMP($J,""SCPTLST"")",.SCERR) S SCOK=0_U_U_"Error in Patient List Call" Q
104 .F SCI=1:1 S SCPT=$P($G(^TMP($J,"SCPTLST",SCI)),U,1) Q:'SCPT D Q:'SCOK
105 ..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
106 ..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
107POSHIS IF FILE=404.59 D
108 .; -- check for practitioners assigned to position
109 .IF '$$PRTP^SCAPMC(IEN,"SCDT","SCPRLST",.SCERR) S SCOK=0_U_U_"Error in Practitioner List Call" Q
110 .F SCI=1:1 S SCPR=$P($G(SCPRLST(SCI)),U,1) Q:'SCPR D Q:'SCOK
111 ..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
112 ..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
113 .;check if a clinic is assigned to position
114 .S SCCLIN=$P($G(^SCTM(404.57,IEN,0)),U,9) Q:'SCCLIN D
115 ..S SCOK="0^^Clinic ("_$P($G(^SC(SCCLIN,0)),U,1)_") is associated with position"_U_SCCLIN
116 .;check for patients assigned to position
117 .IF '$$PTTP^SCAPMC(IEN,"SCDT","^TMP($J,""SCPTLST"")",.SCERR) S SCOK="0^^Error in patient list call" Q
118 .F SCI=1:1 S SCPT=$P($G(^TMP($J,"SCPTLST",SCI)),U,1) Q:'SCPT D Q:'SCOK
119 ..IF $P(SCPTLST(SCI),U,4)>DATE S SCOK="1^0^Patient "_$P(SCPTLST(SCI),U,1)_" is active in the future" Q
120 ..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
121 ;IF FILE=404.52 or 404.53 - NO FURTHER CHECKS NEEDED
122QTOKIN Q SCOK
123 ;
124OKCHGDT(FILE,HISTIEN,DATE,SCERR) ;PCMM history files - ok to change date?
125 ; input:
126 ; FILE = History File: 404.52,404.53,404.58, or 404.59
127 ; HISTIEN - IEN of History File (404.52,404.58 or 404.59)
128 ; SCERR = [default = "SCERR"]
129 ; output:
130 ; Returned: 1 if ok to change date, 0 if not^message
131 ; @scerr = error message array
132 N SCX,ROOT,SCNODE,SCSTAT,SCOK
133 S SCOK=1
134 S ROOT="^SCTM("_FILE_","_HISTIEN_",0)"
135 S SCNODE=$G(@ROOT)
136 IF 'SCNODE S SCOK="0^Bad or Corrupt File Entry"_U_HISTIEN G QTOKCHK
137 S SCSTAT=$S(FILE=404.52:$P(SCNODE,U,4),1:$P(SCNODE,U,3))
138 ;check next & previous effective dates (must be of other status)
139 ; i.e. if active check next & previous for inactive
140 S SCX=$$DTAFTER^SCAPMCU2(FILE,$P(SCNODE,U,1),('SCSTAT),$P(SCNODE,U,2))
141 IF SCX&(DATE'<SCX) D G QTOKCHK
142 .S Y=+SCX D DD^%DT
143 .S SCOK=0_U_"Date Must be before "_Y_U_SCX
144 S SCX=$$DTBEFORE^SCAPMCU2(FILE,$P(SCNODE,U,1),('SCSTAT),$P(SCNODE,U,2))
145 IF DATE'>SCX D G QTOKCHK
146 .S Y=+SCX D DD^%DT
147 .S SCOK=0_U_"Date Must be after "_Y_U_SCX
148 ;bp/cmf 204 new code begin
149 I $$BADCHGDT^SCMCDDA G QTOKCHK
150 ;bp/cmf 204 new code end
151 ;
152QTOKCHK Q SCOK
Note: See TracBrowser for help on using the repository browser.