source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMC21.m@ 1389

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

initial load of WorldVistAEHR

File size: 4.8 KB
RevLine 
[613]1SCAPMC21 ;ALB/REW - Team APIs:ACPTTP ; 5 Jul 1995
2 ;;5.3;Scheduling;**41,148,177**;AUG 13, 1993
3 ;;1.0
4ACPTTP(DFN,SCTP,SCFIELDA,SCACT,SCERR,SCYESTM,SCMAINA) ;add/edit a patient to a position (pt TP assgn - #404.43
5 ; input:
6 ; DFN = pointer to PATIENT file (#2)
7 ; SCTP = pointer to TEAM POSTION file (#404.57)
8 ; SCFIELDA= array of extra field entries - scfielda('fld#')=value
9 ; SCACT = date to activate [default=DT]
10 ; SCERR = array NAME to store error messages.
11 ; [ex. ^TMP("ORXX",$J)]
12 ; SCYESTM = Should team assignment be made, if none active now?[1=YES]
13 ; SCMAINA= array of extra field entries for 404.42 (only if scyestm=1)
14 ;
15 ; Output:
16 ; Returned = ien of 404.43^new?^404.42 ien (new entries only)^new?^Message
17 ; SCERR() = Array of DIALOG file messages(errors) .
18 ; Foramt:
19 ; Subscript: Sequential # from 1 to n
20 ; Piece Description
21 ; 1 IEN of DIALOG file
22 N SCESEQ,SCPARM,SCIEN,SC,HISTPTTP,SCFLD,SCTM,SCPTTMA,SCPTTPA
23 N SCTMFLDA,SCNEWTP,SCNEWTM,SCAPTDT,SCAPTTPO,SCAPTTPE,SCMESS,SCX
24 G:'$$OKDATA APTTPQ ;check/setup variables
25 S SCTM=$P($G(^SCTM(404.57,SCTP,0)),U,2)
26 ;S SCPTTPA=$$HISTPTTP^SCAPMCU2(DFN,SCTP,SCACT)
27 S SCAPTDT("BEGIN")=SCACT
28 S SCAPTDT("END")=3990101
29 S SCAPTDT("INCL")=0
30 IF $S('$D(SCFIELDA):0,'$D(@SCFIELDA@(.05)):0,($G(@SCFIELDA@(.05))=1):1,($G(@SCFIELDA@(.05))=2):1,1:0) IF '$$CHKPC(DFN) D G APTTPQ
31 .S SCMESS=4044300.001
32 ;bp/cmf 177 new begin
33 S SCX=$$OKPREC5^SCMCLK(SCTP,SCACT)
34 I SCX<1 S SCMESS=$P(SCX,U,2) G APTTPQ
35 ;bp/cmf 177 new end
36 G:'$$TPPT^SCAPMC(DFN,"SCAPTDT",,,,,0,"SCAPTTPO","SCAPTTPE") APTTPQ
37 S SCPTTPA=$O(SCAPTTPO("SCTP",SCTM,SCTP,0))
38 ;to edit existing entry
39 IF SCPTTPA D G APTTPQ
40 .S SC($J,404.43,(+SCPTTPA)_",",.03)=SCACT
41 .IF $D(SCFIELDA) D
42 ..S SCFLD=0
43 ..F S SCFLD=$O(@SCFIELDA@(SCFLD)) Q:'SCFLD D
44 ...S SC($J,404.43,(+SCPTTPA)_",",SCFLD)=@SCFIELDA@(SCFLD)
45 .D FILE^DIE("","SC($J)",SCERR)
46 ;needed: patient team assignment for date
47 S SCPTTMA=+$$HISTPTTM^SCAPMCU2(DFN,SCTM,SCACT)
48 ; if flag is set to add patient to team & no pt tm assignment exists
49 ;
50 IF ('SCPTTMA)&($G(SCYESTM))&($D(SCFIELDA)) D
51 .S:$D(@SCFIELDA@(.05)) @SCMAINA@(.08)=$G(@SCMAINA@(.08),$S(@SCFIELDA@(.05):1,1:99))
52 .S:$D(@SCFIELDA@(.06)) @SCMAINA@(.11)=$G(@SCMAINA@(.11),@SCFIELDA@(.06))
53 .S:$D(@SCFIELDA@(.07)) @SCMAINA@(.12)=$G(@SCMAINA@(.12),@SCFIELDA@(.07))
54 .S:$D(@SCFIELDA@(.08)) @SCMAINA@(.13)=$G(@SCMAINA@(.13),@SCFIELDA@(.08))
55 .S:$D(@SCFIELDA@(.09)) @SCMAINA@(.14)=$G(@SCMAINA@(.14),@SCFIELDA@(.09))
56 .S SCPTTMA=+$$ACPTTM^SCAPMC(DFN,SCTM,.SCMAINA,SCACT,SCERR)
57TM IF 'SCPTTMA G APTTPQ
58 ELSE D
59 .IF $D(SCFIELDA) D
60 ..S SCFLD=0
61 ..F S SCFLD=$O(@SCFIELDA@(SCFLD)) Q:'SCFLD D
62 ...S SC($J,404.43,"+1,",SCFLD)=@SCFIELDA@(SCFLD)
63 .S SC($J,404.43,"+1,",.01)=SCPTTMA
64 .S SC($J,404.43,"+1,",.02)=SCTP
65 .S SC($J,404.43,"+1,",.03)=SCACT
66 .D UPDATE^DIE("","SC($J)","SCIEN",SCERR)
67 .IF $D(@SCERR) K SCIEN
68 .ELSE D
69 ..S SCPTTPA=+$G(SCIEN(1))
70 ..S SCNEWTP=1
71 ..D AFTERTP^SCMCDD1(SCPTTPA)
72APTTPQ Q +$G(SCPTTPA)_U_+$G(SCNEWTP)_U_+$G(SCPTTMA)_U_+$P($G(SCPTTMA),U,2)_U_$G(SCMESS)
73 ;
74ACPTATP(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
75 ; input: as per ACPTTP (above with the following change:)
76 ; DFNA = is the literal value of a patient array (e.g. "scpt"
77 ; there is at least one scpt(dfn)="" defined
78 ; SCNEWTP = Subset of DFNA that was NEWLY assigned to a Position
79 ; SCNEWTM = Subset of DFNA that was NEWLY assigned to a Team
80 ; SCOLDTP = Subset of DFNA that was already assigned to Position
81 ; SCBADTP = Subset of DFNA that was NOT assigned to Position
82 ; output: Count of Patients (New or Old) assigned to Position
83 N DFN,SCCNT,SCX,SCNOMAIL
84 S SCNOMAIL=1
85 S SCCNT=0
86 S DFN=0 F S DFN=$O(@DFNA@(DFN)) Q:'DFN D
87 .S SCX=$$ACPTTP(.DFN,.SCTP,.SCFIELDA,.SCACT,.SCERR,.SCYESTM)
88 .; SCX = ien of 404.43^new?^404.42 ien (new entries only)^new?
89 .IF $P(SCX,U,2) D ;newly assigned
90 ..S SCCNT=SCCNT+1
91 ..S @SCNEWTP@(DFN)=+SCX ;scnewtp
92 ..S:$P(SCX,U,4) @SCNEWTM@(DFN)=$P(SCX,U,3) ;scnewtm
93 .IF $P(SCX,U,1)&('$P(SCX,U,2)) D ;old
94 ..S SCCNT=SCCNT+1
95 ..S @SCOLDTP@(DFN)=+SCX
96 .IF 'SCX D
97 ..S @SCBADTP@(DFN)=$P(SCX,U,5)
98 K SCNOMAIL
99 D MAILLST^SCMCTPM(SCTP,.SCADDFLD,DT,.SCNEWTP,.SCOLDTP,.SCBADTP)
100 Q SCCNT
101 ;
102OKDATA() ;setup/check variables
103 N SCOK
104 S SCOK=1
105 D INIT^SCAPMCU1(.SCOK)
106 IF '$D(^DPT(DFN,0))!('$D(^SCTM(404.57,SCTP,0))) D S SCOK=0
107 . S SCPARM("PATIENT")=DFN
108 . S SCPARM("POSITION")=SCTP
109 . D ERR^SCAPMCU1(SCESEQ,4045101,.SCPARM,"",.SCERR)
110 S:'$G(SCACT) SCACT=DT
111 S:'$D(SCMAINA) SCMAINA="SC40443A"
112 Q SCOK
113CHKPC(DFN) ;not stand-alone
114 N SCOK,SCX
115 S SCOK=1
116 G:@SCFIELDA@(.05)=0 QTCKPC ;ignore if no pc role
117 S SCX=$$PCRLPTTP^SCMCTPU2(DFN,SCTP,SCACT)
118 IF @SCFIELDA@(.05)=1 D
119 .S:'SCX SCOK=0
120 IF @SCFIELDA@(.05)=2 D
121 .S:'$P(SCX,U,2) SCOK=0
122QTCKPC Q SCOK
Note: See TracBrowser for help on using the repository browser.