source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCAPMCU1.m@ 899

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

initial load of FOIAVistA 6/30/08 version

File size: 7.5 KB
Line 
1SCAPMCU1 ;ALB/REW - TEAM API UTILITIES ; 7/12/99 9:33am
2 ;;5.3;Scheduling;**41,45,48,177**;AUG 13, 1993
3 ;;1.0
4INIT(SCOK) ; setup date array & error arrays if none passed in
5 ; VARIABLES SET:
6 ; SCOK - SET TO 0 IF ERROR
7 ;
8 ; Makes sure the following are defined:
9 ; scbegin,scend,scincl,@scdates('begin'),@scdates@('end'),@scdates@('incl') - defaults are today & inclusive
10 ;
11 ; Note: you should NEW the above just before making this call
12 ; ---
13 S (SCN,SCESEQ,SCLSEQ)=0
14 IF '$L($G(SCERR)) K ^TMP("SCERR",$J) S SCERR="^TMP(""SCERR"",$J)"
15 IF '$L($G(SCLIST)) S SCLIST="^TMP(""SC TMP LIST"",$J)" K ^TMP("SC TMP LIST",$J)
16 IF (SCERR="SCERR")!(SCERR="SCLIST")!((SCERR'?1A1.7AN)&(SCERR'?1"^"1A.20E)) D S SCOK=0
17 . S SCPARM("ERROR ARRAY")=$G(SCERR,"Undefined")
18 . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
19 IF SCLIST="SCERR"!(SCLIST="SCLIST")!((SCLIST'?1A1.7AN.1"(".60E)&(SCLIST'?1"^"1A1.7AN.1"(".60E)) S SCOK=0 D S SCOK=0
20 . S SCPARM("OUTPUT ARRAY")=$G(SCLIST,"Undefined")
21 . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
22 S:'$D(SCDATES)!($G(SCDATES)="") SCDATES="SCDTS"
23 S SCBEGIN=$G(@SCDATES@("BEGIN"),DT),SCBEGIN=$S(SCBEGIN:SCBEGIN,1:DT)
24 S SCEND=$G(@SCDATES@("END"),DT),SCEND=$S(SCEND:SCEND,1:DT)
25 S SCINCL=$G(@SCDATES@("INCL"),1)
26 S (SCN,SCESEQ,SCLSEQ)=0
27 S:'$D(@SCDATES@("BEGIN")) @SCDATES@("BEGIN")=SCBEGIN
28 S:'$D(@SCDATES@("END")) @SCDATES@("END")=SCEND
29 S:'$D(@SCDATES@("INCL")) @SCDATES@("INCL")=SCINCL
30 Q
31 ;
32 ; bp/cmf 177 - added SCFUTURE input param, used at PCPOSCNT+17
33 ;;bp/cmf 177; orig entry call; PCPOSCNT(SCTP,SCDATE,SCPCONLY);this is a more efficient count of PC patients assigned to position
34PCPOSCNT(SCTP,SCDATE,SCPCONLY,SCFUTURE) ;this is a more efficient count of PC patients assigned to position
35 ; Input: SCTP - ien to 404.57
36 ; SCDATE - date of concern, default=DT
37 ; SCPCONLY - 1= must be pc, 0=all assignments 1=DEFAULT
38 ; SCFUTURE - 1= include future, 0=current 0=DEFAULT ;;bp/cmf 177
39 ;returns count of patient assignments or -1 if error
40 N SCPTPA,SCCNT,SCHSTIEN,SCNODE
41 Q:'$G(SCTP) -1
42 S SCDATE=$G(SCDATE,DT)
43 S:'$L($G(SCPCONLY)) SCPCONLY=1
44 S:'$L($G(SCFUTURE)) SCFUTURE=0 ;;bp/cmf 177 add
45 S (SCPTPA,SCCNT)=0
46 F S SCPTPA=$O(^SCPT(404.43,"APTPA",SCTP,SCPTPA)) Q:'SCPTPA D
47 .S SCHSTIEN=0
48 .F S SCHSTIEN=$O(^SCPT(404.43,"APTPA",SCTP,SCPTPA,SCHSTIEN)) Q:'SCHSTIEN D
49 ..S SCNODE=$G(^SCPT(404.43,SCHSTIEN,0))
50 ..Q:$P(SCNODE,U,4)&($P(SCNODE,U,4)<SCDATE)
51 ..;;bp/cmf 177;orig code;;Q:$P(SCNODE,U,3)>SCDATE
52 ..Q:('SCFUTURE)&($P(SCNODE,U,3)>SCDATE) ;;bp/cmf 177 mod-use scfuture
53 ..Q:SCPCONLY&('$P(SCNODE,U,5)) ;pc role is not 1 or 2
54 ..S SCCNT=SCCNT+1
55 Q SCCNT
56 ;
57TEAMCNT(SCTM,DATE) ;this is a more efficient version of the count
58 N DFN,SCCNT,SCNODE,HISTIEN
59 Q:'$G(SCTM) 0
60 S DATE=$G(DATE,DT)
61 S (DFN,SCCNT)=0
62 F S DFN=$O(^SCPT(404.42,"ATMPT",SCTM,DFN)) Q:'DFN D
63 .S HISTIEN=0
64 .F S HISTIEN=$O(^SCPT(404.42,"ATMPT",SCTM,DFN,HISTIEN)) Q:'HISTIEN D
65 ..S SCNODE=$G(^SCPT(404.42,HISTIEN,0))
66 ..Q:$P(SCNODE,U,9)&($P(SCNODE,U,9)<DATE)
67 ..Q:$P(SCNODE,U,2)>DATE
68 ..S SCCNT=SCCNT+1
69 Q SCCNT
70 ;
71TEAMCNT2(SCTM,DATE) ;this is the count of patients assigned to the team on a date
72 ; Input: SCTM - ien to 404.51
73 ; DATE - date of concern, default=DT
74 N SCX,SCDATES,SCTEAMS,SCERR,X
75 S SCDATES("BEGIN")=$G(DATE,DT)
76 S SCDATES("END")=SCDATES("BEGIN")
77 S SCX=$$PTTM^SCAPMC(SCTM,"SCDATES","^TMP(""SCTEAMS"",$J,""CNT"")","SCERRX")
78 IF 'SCX S X=-SCX
79 ELSE D
80 .S DFN=0
81 .F X=0:1 S DFN=$O(^TMP("SCTEAMS",$J,"CNT","SCPTA",DFN)) Q:'DFN
82 K ^TMP("SCTEAMS",$J,"CNT")
83 Q X
84ACTHISTB(FILE,IEN) ;boolean active function
85 ;MOVED TO SCAPMCU2
86 Q $$ACTHISTB^SCAPMCU2(.FILE,.IEN)
87ACTHIST(FILE,IEN,SCDATES,SCERR) ;is entry active for a time period?
88 ;MOVED TO SCAPMCU2
89 Q $$ACTHIST^SCAPMCU2(.FILE,.IEN,.SCDATES,.SCERR)
90 ;
91LASTDATE(FILE,IEN) ;gets last date for team or position from 404.52,404.58,404.59 - uses DATES function below
92 ; Input Parameters:
93 ; File = either 404.52 or 404.58 or 404.59
94 ; IEN = pointer to team(404.51) or team position(404.57)
95 ; Returned:
96 ; -1 if error,o/w latest date defined 0=no historical dates
97 N SCX
98 S SCX=$$DATES(.FILE,.IEN,3990101) ; gets dates as of 1/1/2999
99 Q $S($P(SCX,U,1)<0:-1,$P(SCX,U,3):$P(SCX,U,3),1:+$P(SCX,U,2))
100 ;
101DATES(FILE,IEN,DATE) ;used to return latest activation & inactivation date
102 ; Input Parameters:
103 ; File = either 404.52, 404.53, 404.58, or 404.59
104 ; IEN = pointer to team(404.51) or team position(404.57)
105 ; DATE = default=DT
106 ; Returned:
107 ; status^actdate^inactdate^scien^first actdate? [1=yes/null=no]
108ST N ROOT,EFFDT,STATUS,ACTDT,INACTDT,X,FUTURE,PREVDT,SCTODAY,PREVST,SCSTAT,SCIEN,SCLAST
109 S:'$G(DATE) DATE=DT
110 S STATUS=-1,SCTODAY=0
111 S SCSTAT=1
112 ;bp/cmf - 177 change begin
113 G:('$G(FILE))!("^404.52^404.53^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTDATES
114 ;orig;G:('$G(FILE))!("^404.52^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTDATES
115 ;bp/cmf - 177 change begin
116 S ROOT="^SCTM("_FILE_",""AIDT"",IEN,SCSTAT"
117 S EFFDT=-DATE
118 S X=ROOT_")"
119 ;if there is an active x-ref
120 IF $D(@X) D
121 .;if today is an activation date
122 .IF $D(@X@(EFFDT)) S ACTDT=-EFFDT
123 .;if today is not an activation date get previous one
124 .ELSE D
125 ..S ACTDT=-$O(@X@(EFFDT))
126 .;if no activation in past get one in future
127 .S:'$G(ACTDT) ACTDT=-$O(@X@(EFFDT),-1),FUTURE=1
128 .S SCSTAT=0
129 .S INACTDT=$O(@X@(-(ACTDT-.000001)),-1),INACTDT=$S(INACTDT:-INACTDT,1:INACTDT)
130 .S STATUS=$$DTCHK^SCAPU1(DATE,DATE,0,ACTDT,INACTDT)
131 .S SCSTAT=STATUS
132 .S X=ROOT_","_$S(SCSTAT:-ACTDT,1:-INACTDT)_")"
133 .S SCIEN=$O(@X@(0))
134 ELSE D
135 .S STATUS=0
136QTDATES Q STATUS_U_$G(ACTDT)_U_$G(INACTDT)_U_$G(SCIEN)_U_$G(FUTURE)
137 ;
138ERR(SEQ,ERNUM,PARMS,OUTPUT,SCER) ;-- process errors
139 ;if no dialog entry 4040000 will be processed
140 S ERNUM=$G(ERNUM,4040000)
141 S:'$$GET1^DIQ(.84,$G(ERNUM)_",",.01) ERNUM=4040000
142 IF SCER]"" D
143 . S SEQ=$G(SEQ,0)+1
144 . S SCER(SEQ)=ERNUM
145 . ;S @SCER@(0)=$G(@SCER@(0))+1 ;bp/djb 7/12/99
146 . S SCER(0)=$G(SCER(0))+1
147 . ;D BLD^DIALOG(.ERNUM,.PARMS,.OUTPUT,.SCER) ;bp/djb 7/12/99
148 . D BLD^DIALOG(.ERNUM,.PARMS,.OUTPUT,"SCER")
149 Q
150 ;
151OKTMPOS(TEAM,POSITION,DATE) ;validate legitimate position in a team for a dt
152 ; used in screen for pc practitioner position of patient team assngt
153 ;
154 ; TEAM - ien of team file
155 ; POSITION - ien of team position file
156 ; DATE - date of interest
157 ; return 1 if ok, 0 ow
158 ;
159CHK ;
160 N SCTP,SCOK,SCPOS0
161 S SCOK=0
162 S:'$L($G(SCERR)) SCERR="^TMP(""SCERR"",$J)"
163 IF '$D(^SCTM(404.51,+$G(TEAM),0)) D G QTOKTP
164 . S SCPARM("TEAM")=$G(TEAM,"Undefined")
165 . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
166 IF '$D(^SCTM(404.57,+$G(POSITION),0)) D G QTOKTP
167 . S SCPARM("POSITION")=$G(POSITION,"Undefined")
168 . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
169 IF '$G(DATE) D G QTOKTP
170 . S SCPARM("DATE")=$G(DATE,"Undefined")
171 . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
172 S SCPOS0=$G(^SCTM(404.57,POSITION,0))
173 ;if position not linked to team
174 G QTOKTP:$P(SCPOS0,U,2)'=TEAM
175 ;if not active position
176 G QTOKTP:'$$DATES(404.59,POSITION,DATE)
177 S SCOK=1
178QTOKTP Q SCOK
179RSNDICS(EVCODE) ; -- called by input transform and screen logic for type of reason
180 ; Input: EVCODE = event code (e.g. ZM1)
181 ; Used to check for fields that point to Scheduling Reason File
182 ; Piece = Piece number of zero node of
183 Q $P(^SD(403.43,$P(^(0),U,2),0),U,1)=EVCODE
184 ;
185OKPREC(TEAM) ; - called by screen logic for preceptor position file (#.1) of team position (#404.57) file
186 ; Input; TEAM = Pointer to team file (#404.51) for team position with preceptor
187 ; requires position being assigned to be a possible preceptor position
188 ; AND that position is from the same team as the supervised position
189 Q ($P(^SCTM(404.57,Y,0),U,12))&($P(^SCTM(404.57,Y,0),U,2)=TEAM)
Note: See TracBrowser for help on using the repository browser.