source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCTMM.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 6.3 KB
Line 
1SCMCTMM ;ALB/REW - Patient Team Changes MailMessages ; 26 Mar 1996
2 ;;5.3;Scheduling;**41,45,87,100,130,177**;AUG 13, 1993
3 ;1
4MAIL ;Do Patient Team Changes MailMan Message
5 ; - called by SCMC PT TEAM CHANGES MAIL MESSAGE protocol
6 G:$G(SCNOMAIL) END ;- flag can be set to stop message generation
7 N XMDUZ,XMY,XMSUB,XMTEXT,VA,VAERR,XMZ,Y,SCX,ZTQUEUED
8 N SCTMAR,SCSTAT,DFN,SCNODE,SCY,SCSPACE,SCPAD,SCPHONE,SCB,SCE,SCB2,SCE2,SCTMDT,SCTMXM,SCPTNM,SCLNCNT
9 S ZTQUEUED=1
10 S $P(SCSPACE," ",80)=""
11 ; SCTMAR - ARRAY OF TEAMS (before & after)
12 S:SCTMB4 SCTMAR(SCTMB4)=""
13 S:SCTMAF SCTMAR(SCTMAF)=""
14 IF 'SCTMAF D
15 .S SCSTAT="DELETED",SCB=$P(SCTMB4,U,2),SCE=$S($P(SCPTTMB4,U,9):$P(SCPTTMB4,U,9),1:DT)
16 IF 'SCTMB4 D
17 .S SCSTAT="NEW",SCB=$P(SCTMAF,U,2),SCE=$S($P(SCPTTMAF,U,9):$P(SCPTTMAF,U,9),1:DT)
18 IF SCTMB4&SCTMAF D
19 .S SCSTAT="CHANGED"
20 .S SCB=$P(SCTMB4,U,2),SCE=$S($P(SCPTTMB4,U,9):$P(SCPTTMB4,U,9),1:DT)
21 .S SCB2=$P(SCTMAF,U,2),SCE2=$S($P(SCPTTMAF,U,9):$P(SCPTTMAF,U,9),1:DT)
22 .S SCTMDT("BEGIN")=$S(SCB<SCB2:SCB,1:SCB2)
23 .S SCTMDT("END")=$S(SCE>SCE2:SCE,1:SCE2)
24 .S SCTMDT("INCL")=0
25 IF SCSTAT="NEW"!(SCSTAT="DELETED") D
26 .S SCTMDT("BEGIN")=SCB
27 .S SCTMDT("END")=SCE
28 .S SCTMDT("INCL")=0
29 S DFN=$S(SCSTAT="DELETED":+SCPTTMB4,1:+SCPTTMAF)
30 ;set xmy array for practitioners in positions receiving tmchg notices
31 G:'$$PCMMXMY^SCAPMC25(3,DFN,"SCTMAR","SCTMDT",0) END
32 D:'$G(DGQUIET) EN^DDIOL("Sending "_SCSTAT_" Patient-Team Assignment Message")
33 D PID^VADPT6
34 S SCPTNM=$P(^DPT(DFN,0),U,1)
35 S XMSUB=SCSTAT_" PATIENT-TEAM ASSIGNMENT for Patient ("_$E(SCPTNM,1)_$G(VA("BID"))_")",XMTEXT="^TMP($J,""SCTMXM"",",SCLNCNT=0
36 IF SCSTAT="NEW" D
37 .D SETLN("Current Patient Team Data:")
38 .D SETLN("==========================")
39 .F SCX=1:1:14 D
40 ..D SETLN($$TEXT(404.42,SCPTTMAF,SCX,SCSPACE,1))
41 IF SCSTAT="DELETED" D
42 .D SETLN("Previous Patient Team Data:")
43 .D SETLN("===========================")
44 .F SCX=1:1:14 S SCFLD=SCX*.01 D
45 ..D SETLN($$TEXT(404.42,SCPTTMB4,SCX,SCSPACE,1))
46 IF SCSTAT="CHANGED" D
47 .D SETLN("Fields: "_$E(SCSPACE,1,15)_"Previous Data: Current Patient Data:")
48 .D SETLN("=======================================================================")
49 .F SCX=1:1:14 S SCFLD=SCX*.01 D
50 ..N SCLAB2,SCY,SCZ
51 ..S SCY=$$TEXT(404.42,SCPTTMB4,SCX,SCSPACE,1)
52 ..S:'$L(SCY) SCLAB2=2
53 ..S SCZ=$$TEXT(404.42,SCPTTMAF,SCX,SCSPACE,+$G(SCLAB2))
54 ..D:$L(SCY)!($L(SCZ)) SETLN(SCY_$E(SCSPACE,1,(50-$L(SCY)))_SCZ)
55 S SCLNCNT=$$PCMAIL^SCMCMM(DFN,"^TMP($J,""SCTMXM"")",DT)
56 S XMDUZ=$G(DUZ,.5)
57 S XMY(XMDUZ)=""
58 D ^XMD
59END K ^TMP($J,"SCTMXM")
60 Q
61 ;
62SETLN(TEXT) ;
63 Q:$G(TEXT)=""
64 ; increments SCLNCNT, adds text to sctmxm(sclncnt)
65 S SCLNCNT=SCLNCNT+1
66 S ^TMP($J,"SCTMXM",SCLNCNT)=TEXT
67 Q
68 ;
69TEXT(SCFILE,SCNODE,SCPC,SCSPACE,SCLAB) ;returns fldname & external value
70 ;returns fldname & external value
71 ; Note- Only works for non wp fields of standard numbering conventions
72 ; SCFLILE =FILENUM
73 ; SCNODE = 0 NODE
74 ; SCPC = piece of node
75 ; SCSPACE = 80 SPACES
76 ; SCLAB = 1 if print field name
77 N SCX,SCINT,SCFLD
78 S SCX=""
79 S SCINT=$P(SCNODE,U,SCPC)
80 G:SCINT="" QTTXT
81 S SCFLD=SCPC*.01
82 ;;;
83 IF $G(SCLAB) D
84 .S SCX=$$DDNAME(SCFILE,SCFLD)_":"
85 .S:$G(SCLAB)=1 SCX=SCX_$E(SCSPACE,1,(23-$L(SCX)))
86 .S:$G(SCLAB)=2 SCX=SCX_$E(SCSPACE,1,(50-$L(SCX)))
87 S:SCINT]"" SCX=SCX_$$EXTERNAL^DILFD(SCFILE,SCFLD,"",SCINT)
88 ;adding SSN to the end of name for alpha 177
89 I $P(SCX,":",1)="PATIENT" S SCX=SCX_" ("_$G(VA("PID"))_")"
90QTTXT Q SCX
91 ;
92DDNAME(FILE,FIELD) ;return the fieldname
93 N SCX
94 D FIELD^DID(FILE,FIELD,"","LABEL","SCX")
95 Q $G(SCX("LABEL"))
96 ;
97MAILLST(SCTM,SCFIELDA,SCDATE,SCNEWTM,SCOLDTM,SCBADTM) ;
98 ; Input:
99 ; SCTM - Pointer to Team File (#404.51)
100 ; SCFIELDA - Field array with internal values
101 ; SCDATE - Effective Date
102 ; SCNEWTM - DFN array of newly assigned to team
103 ; SCOLDTM - DFN array of previously assigned to team
104 ; SCBADTM - DFN array of patients unassignable to team
105 ;
106 G:$G(SCNOMAIL) QTMULT ;- flag can be set to stop message generation
107 G:'$D(SCNEWTM) QTMULT
108 G:'$O(@SCNEWTM@(0)) QTMULT ;if no new assignments
109 N XMDUZ,XMY,XMSUB,XMTEXT,VA,VAERR,XMZ,Y,ZTQUEUED
110 N SCTMNM,DFN,SCOK,SCPTNM,SCFLD,SCNODE,SCNDX,SCSPACE,SCE,SCB,SCTMDT,SCDELTEM
111 S ZTQUEUED=1
112 S SCDELTEM=1 ;ok to delete tmp global
113 IF $D(SCFIELDA) D
114 .IF $D(SCFIELDA(.02)) S SCB=SCFIELDA(.02)
115 .IF $D(SCFIELDA(.09)) S SCE=SCFIELDA(.09)
116 S SCB=$G(SCB,DT)
117 S SCE=$G(SCE,DT)
118 S $P(SCSPACE," ",80)=""
119 S SCTMDT("BEGIN")=$S(SCB<SCDATE:SCB,1:SCDATE)
120 S SCTMDT("END")=$S(SCE>SCDATE:SCE,1:SCDATE)
121 S SCTMDT("INCL")=0
122 S SCTMNM=$P($G(^SCTM(404.51,+SCTM,0)),U,1)
123 S XMSUB="Multiple PATIENT-TEAM ASSIGNMENT for "_SCTMNM,XMTEXT="^TMP($J,""SCTMXM"",",SCLNCNT=0
124 D:'$G(DGQUIET) EN^DDIOL("Sending Multiple Patient-Team Assignment Message")
125 S SCOK=1
126 S SCTMNM=$P($G(^SCTM(404.51,+SCTM,0)),U,1)
127 D SETLN("Team: "_SCTMNM)
128 S Y=SCDATE X ^DD("DD")
129 D SETLN("Effective Date: "_Y)
130 D SETLN(" ")
131 IF $D(SCFIELDA) D
132 .F SCNDX=1:1:14 S SCFLD=SCNDX*.01 IF $D(SCFIELDA(SCFLD)) D
133 ..S $P(SCNODE,U,SCNDX)=SCFIELDA(SCFLD)
134 ..D SETLN($$TEXT(404.42,SCNODE,SCNDX,SCSPACE,1))
135 D SETLN(" ")
136 D SETLN("There has been a new team assignment for the following patients:")
137 S DFN=0
138 F S DFN=$O(@SCNEWTM@(DFN)) Q:'DFN D
139 .S:$$PCMMXMY^SCAPMC25(3,DFN,,"SCTMDT",0) SCOK=0
140 .D PID^VADPT6
141 .S SCPTNM=$P(^DPT(DFN,0),U,1)
142 .S ^TMP("SCTM MAIL LST",$J,SCTM,1,DFN)=(" "_SCPTNM_" ("_$G(VA("PID"))_")")
143 .S ^TMP("SCTM MAIL LST",$J,SCTM,1,"B",SCPTNM,DFN)=""
144 S SCPTNM=""
145 F S SCPTNM=$O(^TMP("SCTM MAIL LST",$J,SCTM,1,"B",SCPTNM)) Q:SCPTNM']"" D
146 .S DFN=0
147 .F S DFN=$O(^TMP("SCTM MAIL LST",$J,SCTM,1,"B",SCPTNM,DFN)) Q:'DFN D
148 ..S SCDETAIL=$G(^TMP("SCTM MAIL LST",$J,SCTM,1,DFN)) Q:SCDETAIL']"" D SETLN(SCDETAIL)
149BAD IF $S('$D(SCBADTM):0,1:$O(@SCBADTM@(0))) D
150 .D SETLN(" ")
151 .D SETLN("There has been NO new team assignment for the following patients:")
152 .S DFN=0
153 .F S DFN=$O(@SCBADTM@(DFN)) Q:'DFN D
154 ..S:$$PCMMXMY^SCAPMC25(3,DFN,,"SCTMDT",0) SCOK=0
155 ..S SCPTNM=$P(^DPT(DFN,0),U,1)
156 ..D PID^VADPT6
157 ..S ^TMP("SCTM MAIL LST",$J,SCTM,2,DFN)=(" "_SCPTNM_" ("_$G(VA("PID"))_")")
158 ..S ^TMP("SCTM MAIL LST",$J,SCTM,2,"B",SCPTNM,DFN)=""
159 .S SCPTNM=""
160 .F S SCPTNM=$O(^TMP("SCTM MAIL LST",$J,SCTM,2,"B",SCPTNM)) Q:SCPTNM']"" D
161 ..S DFN=0
162 ..F S DFN=$O(^TMP("SCTM MAIL LST",$J,SCTM,2,"B",SCPTNM,DFN)) Q:'DFN D
163 ...S SCDETAIL=$G(^TMP("SCTM MAIL LST",$J,SCTM,2,DFN)) Q:SCDETAIL']"" D SETLN(SCDETAIL)
164 S XMDUZ=$G(DUZ,.5)
165 D ^XMD
166QTMULT K:$G(SCDELTEM) ^TMP("SCTM MAIL LST",$J,SCTM)
167 K ^TMP($J,"SCTMXM")
168 Q
Note: See TracBrowser for help on using the repository browser.