source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMRTPM.m@ 794

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

initial load of FOIAVistA 6/30/08 version

File size: 3.7 KB
Line 
1SCMRTPM ;ALB/REW/PDR/cmf - Patient Position Changes MailMessages ; nov 1998
2 ;;5.3;Scheduling;**148,157**;AUG 13, 1993
3 ;
4 ;
5MAILLST(SCTP,SCFIELDA,SCDATE,SCBADTP,SCFTP) ;
6 ; Input:
7 ; SCTP - Pointer to Team Position File (#404.57)
8 ; SCFIELDA - Field array with internal values
9 ; SCDATE - Effective Date
10 ; SCBADTP - DFN array of patients unassignable to position
11 ; SCFTP - Pointer to 404.57 ('from' team ien)
12 ;
13 G:$G(SCNOMAIL) QTMULT ;- flag can be set to stop message generation
14 G:'$D(SCBADTP) QTMULT
15 G:'$O(@SCBADTP@(0)) QTMULT ;if no BAD REassignments
16 N XMDUZ,XMY,XMSUB,XMTEXT,VA,VAERR,XMZ,Y,SCTPDT,ZTQUEUED
17 N DFN,SCOK,SCPTNM,SCFLD,SCNODE,SCNDX,SCSPACE,SCE,SCB
18 N SCTPNM,SCTMNM,SCFTPNM,SCFTMNM,SCDELTEM,SCDETAIL
19 S ZTQUEUED=1
20 S DELTEM=1 ;ok to delete tmp global
21 S $P(SCSPACE," ",80)=""
22 S XMSUB="Multiple PATIENT-POSITION REASSIGNMENT FAILURES for "_$$POSNAME(+SCTP)
23 S XMTEXT="^TMP($J,""SCTPXM"","
24 S SCLNCNT=0
25 S SCOK=1
26 D SETLN("Team: "_$$TMNAME(+SCTP))
27 D SETLN("Position: "_$$POSNAME(+SCTP))
28 D SETLN("Effective Date: "_$$FMTE^XLFDT(SCDATE))
29 D SETLN("Total Processed: "_$$PASSCNT^SCMCBK5(DFNA))
30 D SETLN("From Team: "_$$TMNAME(+SCFTP))
31 D SETLN("From Position: "_$$POSNAME(+SCFTP))
32 D SETLN(" ")
33 IF $D(SCFIELDA) D
34 .F SCNDX=1:1:14 S SCFLD=SCNDX*.01 IF $D(SCFIELDA(SCFLD)) D
35 ..S $P(SCNODE,U,SCNDX)=SCFIELDA(SCFLD)
36 ..D SETLN($$TEXT(404.43,SCNODE,SCNDX,SCSPACE,1))
37 D SETLN(" ")
38BAD IF $O(@SCBADTP@(0)) D
39 .D SETLN(" ")
40 .;;D SETLN("There has been NO new position reassignment for the following patients:")
41 .D SETLN("The following position reassignments did not complete processing:")
42 .S DFN=0
43 .F S DFN=$O(@SCBADTP@(DFN)) Q:'DFN D
44 ..S SCPTNM=$P(^DPT(DFN,0),U,1)
45 ..D PID^VADPT6
46 ..S ^TMP("SCTP MAIL LST",$J,SCTP,2,DFN)=(" "_SCPTNM_" ("_$G(VA("PID"))_")")
47 ..S ^TMP("SCTP MAIL LST",$J,SCTP,3,DFN)=" "_@SCBADTP@(DFN)
48 ..S ^TMP("SCTP MAIL LST",$J,SCTP,2,"B",SCPTNM,DFN)=""
49 .S SCPTNM=""
50 .F S SCPTNM=$O(^TMP("SCTP MAIL LST",$J,SCTP,2,"B",SCPTNM)) Q:SCPTNM']"" D
51 ..S DFN=0
52 ..F S DFN=$O(^TMP("SCTP MAIL LST",$J,SCTP,2,"B",SCPTNM,DFN)) Q:'DFN D
53 ...S SCDETAIL=$G(^TMP("SCTP MAIL LST",$J,SCTP,2,DFN)) Q:SCDETAIL']"" D SETLN(SCDETAIL)
54 ...S SCDETAIL=$G(^TMP("SCTP MAIL LST",$J,SCTP,3,DFN)) Q:SCDETAIL']"" D SETLN(SCDETAIL)
55 S XMDUZ="PCMM Reassignment"
56 K XMY S XMY(DUZ)=""
57 S SCX=$O(^SD(404.91,"B",0))_","
58 I +SCX S XMY("G."_$$GET1^DIQ(404.91,SCX,804))=""
59 D ^XMD
60QTMULT K:$G(SCDELTEM) ^TMP("SCTP MAIL LST",$J,SCTP)
61 K ^TMP($J,"SCTPXM")
62 Q
63 ;
64 ;----------------------------- subs ------------------------------------
65 ;
66SETLN(TEXT) ;
67 Q:$G(TEXT)=""
68 ; increments SCLNCNT, adds text to scTPxm(sclncnt)
69 S SCLNCNT=SCLNCNT+1
70 S ^TMP($J,"SCTPXM",SCLNCNT)=TEXT
71 Q
72 ;
73TEXT(SCFILE,SCNODE,SCPC,SCSPACE,SCLAB) ;returns fldname & external value
74 ;returns fldname & external value
75 ; Note- Only works for non wp fields of standard numbering conventions
76 ; SCFLILE =FILENUM
77 ; SCNODE = 0 NODE
78 ; SCPC = piece of node
79 ; SCSPACE = 80 SPACES
80 ; SCLAB = 1 if print field name
81 N SCX,SCINT,SCFLD
82 S SCX=""
83 S SCINT=$P(SCNODE,U,SCPC)
84 G:SCINT="" QTTXT
85 S SCFLD=SCPC*.01
86 ;;;
87 IF $G(SCLAB) D
88 .S SCX=$$DDNAME^SCMCRU(SCFILE,SCFLD)_":"
89 .S:$G(SCLAB)=1 SCX=SCX_$E(SCSPACE,1,(27-$L(SCX)))
90 .S:$G(SCLAB)=2 SCX=SCX_$E(SCSPACE,1,(52-$L(SCX)))
91 S:SCINT]"" SCX=SCX_$$EXTERNAL^DILFD(SCFILE,SCFLD,"",SCINT)
92QTTXT Q SCX
93 ;
94DDNAME(FILE,FIELD) ;return the fieldname
95 N SCX
96 D FIELD^DID(FILE,FIELD,"","LABEL","SCX")
97 Q $G(SCX("LABEL"))
98 ;
99POSNAME(SCX) ; return position external name
100 Q $P($G(^SCTM(404.57,+SCX,0)),U)
101 ;
102TMNAME(SCX) ; return team external name
103 Q $P($G(^SCTM(404.51,+$P($G(^SCTM(404.57,+SCX,0)),U,2),0)),U)
104 ;
105
Note: See TracBrowser for help on using the repository browser.