source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCTPM.m@ 1379

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

initial load of FOIAVistA 6/30/08 version

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