source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCMCBK8.m@ 1446

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

initial load of FOIAVistA 6/30/08 version

File size: 5.1 KB
Line 
1SCMCBK8 ;bp/cmf - multiple patient assignments mail queue - RPCVersion = 1;;Aug 7, 1998
2 ;;5.3;Scheduling;**148,177,210**;AUG 13, 1993
3 Q
4 ;
5ACPTTP(DFN,SCTP,SCFIELDA,SCACT,SCERR,SCYESTM,SCMAINA) ;add/edit a patient to a position (pt TP assgn - #404.43
6 ; input:
7 ; DFN = pointer to PATIENT file (#2)
8 ; SCTP = pointer to TEAM POSTION file (#404.57)
9 ; SCFIELDA= array of extra field entries - scfielda('fld#')=value
10 ; SCACT = date to activate [default=DT]
11 ; SCERR = array NAME to store error messages.
12 ; [ex. ^TMP("ORXX",$J)]
13 ; SCYESTM = Should team assignment be made, if none active now?[1=YES]
14 ; SCMAINA= array of extra field entries for 404.42 (only if scyestm=1)
15 ;
16 ; Output:
17 ; Returned = ien of 404.43^new?^404.42 ien (new entries only)^new?^Message
18 ; SCERR() = Array of DIALOG file messages(errors) .
19 ; Foramt:
20 ; Subscript: Sequential # from 1 to n
21 ; Piece Description
22 ; 1 IEN of DIALOG file
23 ;
24 N SCESEQ,SCPARM,SCIEN,SC,HISTPTTP,SCFLD,SCTM,SCPTTMA,SCPTTPA,SCTMFLDA
25 N SCNEWTP,SCNEWTM,SCAPTDT,SCAPTTPO,SCAPTTPE,SCMESS
26 N SCLOCK,SCXLOCK,SCX
27 ;
28 ;check/setup variables
29 I '$$OKDATA^SCAPMC21 S SCMESS=$$S(9) G APTTPQ
30 ;
31 ;bp/cmf 210 new begin
32 ;lock process/dfn/pos
33 I '$D(^XTMP("SCMC POS ASGN")) D
34 . S ^XTMP("SCMC POS ASGN",0)=DT_U_DT_U_"POS ASGN PROCESS LOCK"
35 . Q
36 ;
37 S SCXLOCK=0
38 S SCLOCK="^XTMP(""SCMC POS ASGN"",DFN)"
39 I $D(@SCLOCK) S SCMESS=$$S(15) G APTTPQ
40 S @SCLOCK=""
41 S SCXLOCK=1
42 H 1
43 ;
44 ;stop if active assignment
45 S SCPTTPA=$$HISTPTTP^SCAPMCU2(DFN,SCTP,SCACT)
46 I SCPTTPA S SCMESS=$$S(10) G APTTPQ
47 ;bp/cmf 210 new end
48 ;
49 S SCTM=$P($G(^SCTM(404.57,SCTP,0)),U,2)
50 S SCAPTDT("BEGIN")=SCACT
51 S SCAPTDT("END")=3990101
52 S SCAPTDT("INCL")=0
53 ;
54 ;is patient alive?
55 I $$DP^SCMCBK6(DFN) S SCMESS=$$S(1) G APTTPQ
56 ;
57 S SCX=$$OKPREC5^SCMCLK(SCTP,SCACT)
58 I SCX<1 S SCMESS=$P(SCX,U,2) G APTTPQ
59 ;
60 ;is PC role assignable?
61 I $$T1(),'$$CHKPC^SCAPMC21(DFN) S SCMESS=$$S(12) G APTTPQ
62 ;
63 I '$$TPPT^SCAPMC(DFN,"SCAPTDT",,,,,0,"SCAPTTPO","SCAPTTPE") S SCMESS=$$S(13) G APTTPQ
64 S SCPTTPA=$O(SCAPTTPO("SCTP",SCTM,SCTP,0))
65 ;
66 ;to edit existing entry
67 I SCPTTPA D G APTTPQ
68 .S SC($J,404.43,(+SCPTTPA)_",",.03)=SCACT
69 .I $D(SCFIELDA) D
70 ..S SCFLD=0
71 ..F S SCFLD=$O(@SCFIELDA@(SCFLD)) Q:'SCFLD D
72 ...S SC($J,404.43,(+SCPTTPA)_",",SCFLD)=@SCFIELDA@(SCFLD)
73 ...Q
74 ..Q
75 .D FILE^DIE("","SC($J)",SCERR)
76 .Q
77 ;
78 ;needed: patient team assignment for date
79 S SCPTTMA=+$$HISTPTTM^SCAPMCU2(DFN,SCTM,SCACT)
80 ;
81 ; if flag is set to add patient to team & no pt tm assignment exists
82 I ('SCPTTMA)&($G(SCYESTM))&($D(SCFIELDA)) D
83 .S:$D(@SCFIELDA@(.05)) @SCMAINA@(.08)=$G(@SCMAINA@(.08),$S(@SCFIELDA@(.05):1,1:99))
84 .S:$D(@SCFIELDA@(.06)) @SCMAINA@(.11)=$G(@SCMAINA@(.11),@SCFIELDA@(.06))
85 .S:$D(@SCFIELDA@(.07)) @SCMAINA@(.12)=$G(@SCMAINA@(.12),@SCFIELDA@(.07))
86 .S:$D(@SCFIELDA@(.08)) @SCMAINA@(.13)=$G(@SCMAINA@(.13),@SCFIELDA@(.08))
87 .S:$D(@SCFIELDA@(.09)) @SCMAINA@(.14)=$G(@SCMAINA@(.14),@SCFIELDA@(.09))
88 .S SCPTTMA=+$$ACPTTM^SCAPMC(DFN,SCTM,.SCMAINA,SCACT,SCERR)
89 .Q
90 ;
91TM I 'SCPTTMA S SCMESS=$$S(14) G APTTPQ
92 ;
93 I $D(SCFIELDA) D
94 .S SCFLD=0
95 .F S SCFLD=$O(@SCFIELDA@(SCFLD)) Q:'SCFLD D
96 ..S SC($J,404.43,"+1,",SCFLD)=@SCFIELDA@(SCFLD)
97 ..Q
98 .Q
99 ;
100 S SC($J,404.43,"+1,",.01)=SCPTTMA
101 S SC($J,404.43,"+1,",.02)=SCTP
102 S SC($J,404.43,"+1,",.03)=SCACT
103 N SCTPERR
104 D UPDATE^DIE("","SC($J)","SCIEN","SCTPERR")
105 ;
106 I $D(SCTPERR) S SCMESS=$$S(11) K SCIEN
107 E D
108 .S SCPTTPA=+$G(SCIEN(1))
109 .S SCNEWTP=1
110 .D AFTERTP^SCMCDD1(SCPTTPA)
111 .Q
112 ;
113APTTPQ ;bp/cmf 210 new code begin
114 I SCXLOCK=1 K @SCLOCK
115 ;bp/cmf 210 new code end
116 Q +$G(SCPTTPA)_U_+$G(SCNEWTP)_U_+$G(SCPTTMA)_U_+$P($G(SCPTTMA),U,2)_U_$G(SCMESS)
117 ;
118T1() Q $S('$D(SCFIELDA):0,'$D(@SCFIELDA@(.05)):0,($G(@SCFIELDA@(.05))=1):1,($G(@SCFIELDA@(.05))=2):1,1:0)
119 ;
120S(SCX) Q $$S^SCMCBK6(SCX)
121 ;
122ACPTATP(DFNA,SCTP,SCFIELDA,SCACT,SCERR,SCYESTM,SCMAINA,SCNEWTP,SCNEWTM,SCOLDTP,SCBADTP) ;list of patients to a position (pt TP assgn - #404.43 and possibly #404.42
123 ; input: as per ACPTTP (above with the following change:)
124 ; DFNA = is the literal value of a patient array (e.g. "scpt"
125 ; there is at least one scpt(dfn)="" defined
126 ; SCNEWTP = Subset of DFNA that was NEWLY assigned to a Position
127 ; SCNEWTM = Subset of DFNA that was NEWLY assigned to a Team
128 ; SCOLDTP = Subset of DFNA that was already assigned to Position
129 ; SCBADTP = Subset of DFNA that was NOT assigned to Position
130 ; output: Count of Patients (New or Old) assigned to Position
131 ;
132 N DFN,SCCNT,SCX,SCNOMAIL,SCTOTCNT
133 S SCNOMAIL=1
134 S SCCNT=0
135 S SCTOTCNT=$$PASSCNT^SCMCBK5(DFNA)
136 I SCTOTCNT=0 G MAIL
137 S DFN=0
138 F S DFN=$O(@DFNA@(DFN)) Q:'DFN D
139 .S SCX=$$ACPTTP(.DFN,.SCTP,.SCFIELDA,.SCACT,.SCERR,.SCYESTM)
140 .;
141 .;newly assigned
142 .I $P(SCX,U,2)=1 D Q
143 ..S SCCNT=SCCNT+1
144 ..S @SCNEWTP@(DFN)=+SCX
145 ..S:$P(SCX,U,4) @SCNEWTM@(DFN)=$P(SCX,U,3)
146 ..Q
147 .;
148 .;already assigned
149 .;I $P(SCX,U,1)&('$P(SCX,U,2)) D
150 .I +SCX D Q
151 ..S SCCNT=SCCNT+1
152 ..S @SCOLDTP@(DFN)=+SCX
153 ..Q
154 .;
155 .;not assigned;;I 'SCX D
156 .S @SCBADTP@(DFN)=$P(SCX,U,5)
157 .Q
158 ;
159MAIL K SCNOMAIL
160 D MAILLST^SCMCBK9(SCTP,.SCADDFLD,DT,.SCNEWTP,.SCOLDTP,.SCBADTP,SCTOTCNT)
161 Q SCCNT
162 ;
Note: See TracBrowser for help on using the repository browser.