SCMRTPM ;ALB/REW/PDR/cmf - Patient Position Changes MailMessages ; nov 1998
;;5.3;Scheduling;**148,157,1015**;AUG 13, 1993;Build 21
;
;
MAILLST(SCTP,SCFIELDA,SCDATE,SCBADTP,SCFTP) ;
; Input:
; SCTP - Pointer to Team Position File (#404.57)
; SCFIELDA - Field array with internal values
; SCDATE - Effective Date
; SCBADTP - DFN array of patients unassignable to position
; SCFTP - Pointer to 404.57 ('from' team ien)
;
G:$G(SCNOMAIL) QTMULT ;- flag can be set to stop message generation
G:'$D(SCBADTP) QTMULT
G:'$O(@SCBADTP@(0)) QTMULT ;if no BAD REassignments
N XMDUZ,XMY,XMSUB,XMTEXT,VA,VAERR,XMZ,Y,SCTPDT,ZTQUEUED
N DFN,SCOK,SCPTNM,SCFLD,SCNODE,SCNDX,SCSPACE,SCE,SCB
N SCTPNM,SCTMNM,SCFTPNM,SCFTMNM,SCDELTEM,SCDETAIL
S ZTQUEUED=1
S DELTEM=1 ;ok to delete tmp global
S $P(SCSPACE," ",80)=""
S XMSUB="Multiple PATIENT-POSITION REASSIGNMENT FAILURES for "_$$POSNAME(+SCTP)
S XMTEXT="^TMP($J,""SCTPXM"","
S SCLNCNT=0
S SCOK=1
D SETLN("Team: "_$$TMNAME(+SCTP))
D SETLN("Position: "_$$POSNAME(+SCTP))
D SETLN("Effective Date: "_$$FMTE^XLFDT(SCDATE))
D SETLN("Total Processed: "_$$PASSCNT^SCMCBK5(DFNA))
D SETLN("From Team: "_$$TMNAME(+SCFTP))
D SETLN("From Position: "_$$POSNAME(+SCFTP))
D SETLN(" ")
IF $D(SCFIELDA) D
.F SCNDX=1:1:14 S SCFLD=SCNDX*.01 IF $D(SCFIELDA(SCFLD)) D
..S $P(SCNODE,U,SCNDX)=SCFIELDA(SCFLD)
..D SETLN($$TEXT(404.43,SCNODE,SCNDX,SCSPACE,1))
D SETLN(" ")
BAD IF $O(@SCBADTP@(0)) D
.D SETLN(" ")
.;;D SETLN("There has been NO new position reassignment for the following patients:")
.D SETLN("The following position reassignments did not complete processing:")
.S DFN=0
.F S DFN=$O(@SCBADTP@(DFN)) Q:'DFN D
..S SCPTNM=$P(^DPT(DFN,0),U,1)
..D PID^VADPT6
..S ^TMP("SCTP MAIL LST",$J,SCTP,2,DFN)=(" "_SCPTNM_" ("_$G(VA("PID"))_")")
..S ^TMP("SCTP MAIL LST",$J,SCTP,3,DFN)=" "_@SCBADTP@(DFN)
..S ^TMP("SCTP MAIL LST",$J,SCTP,2,"B",SCPTNM,DFN)=""
.S SCPTNM=""
.F S SCPTNM=$O(^TMP("SCTP MAIL LST",$J,SCTP,2,"B",SCPTNM)) Q:SCPTNM']"" D
..S DFN=0
..F S DFN=$O(^TMP("SCTP MAIL LST",$J,SCTP,2,"B",SCPTNM,DFN)) Q:'DFN D
...S SCDETAIL=$G(^TMP("SCTP MAIL LST",$J,SCTP,2,DFN)) Q:SCDETAIL']"" D SETLN(SCDETAIL)
...S SCDETAIL=$G(^TMP("SCTP MAIL LST",$J,SCTP,3,DFN)) Q:SCDETAIL']"" D SETLN(SCDETAIL)
S XMDUZ="PCMM Reassignment"
K XMY S XMY(DUZ)=""
S SCX=$O(^SD(404.91,"B",0))_","
I +SCX S XMY("G."_$$GET1^DIQ(404.91,SCX,804))=""
D ^XMD
QTMULT K:$G(SCDELTEM) ^TMP("SCTP MAIL LST",$J,SCTP)
K ^TMP($J,"SCTPXM")
Q
;
;----------------------------- subs ------------------------------------
;
SETLN(TEXT) ;
Q:$G(TEXT)=""
; increments SCLNCNT, adds text to scTPxm(sclncnt)
S SCLNCNT=SCLNCNT+1
S ^TMP($J,"SCTPXM",SCLNCNT)=TEXT
Q
;
TEXT(SCFILE,SCNODE,SCPC,SCSPACE,SCLAB) ;returns fldname & external value
;returns fldname & external value
; Note- Only works for non wp fields of standard numbering conventions
; SCFLILE =FILENUM
; SCNODE = 0 NODE
; SCPC = piece of node
; SCSPACE = 80 SPACES
; SCLAB = 1 if print field name
N SCX,SCINT,SCFLD
S SCX=""
S SCINT=$P(SCNODE,U,SCPC)
G:SCINT="" QTTXT
S SCFLD=SCPC*.01
;;;
IF $G(SCLAB) D
.S SCX=$$DDNAME^SCMCRU(SCFILE,SCFLD)_":"
.S:$G(SCLAB)=1 SCX=SCX_$E(SCSPACE,1,(27-$L(SCX)))
.S:$G(SCLAB)=2 SCX=SCX_$E(SCSPACE,1,(52-$L(SCX)))
S:SCINT]"" SCX=SCX_$$EXTERNAL^DILFD(SCFILE,SCFLD,"",SCINT)
QTTXT Q SCX
;
DDNAME(FILE,FIELD) ;return the fieldname
N SCX
D FIELD^DID(FILE,FIELD,"","LABEL","SCX")
Q $G(SCX("LABEL"))
;
POSNAME(SCX) ; return position external name
Q $P($G(^SCTM(404.57,+SCX,0)),U)
;
TMNAME(SCX) ; return team external name
Q $P($G(^SCTM(404.51,+$P($G(^SCTM(404.57,+SCX,0)),U,2),0)),U)
;
SCMRTPM ;ALB/REW/PDR/cmf - Patient Position Changes MailMessages ; nov 1998
+1 ;;5.3;Scheduling;**148,157,1015**;AUG 13, 1993;Build 21
+2 ;
+3 ;
MAILLST(SCTP,SCFIELDA,SCDATE,SCBADTP,SCFTP) ;
+1 ; Input:
+2 ; SCTP - Pointer to Team Position File (#404.57)
+3 ; SCFIELDA - Field array with internal values
+4 ; SCDATE - Effective Date
+5 ; SCBADTP - DFN array of patients unassignable to position
+6 ; SCFTP - Pointer to 404.57 ('from' team ien)
+7 ;
+8 ;- flag can be set to stop message generation
IF $GET(SCNOMAIL)
GOTO QTMULT
+9 IF '$DATA(SCBADTP)
GOTO QTMULT
+10 ;if no BAD REassignments
IF '$ORDER(@SCBADTP@(0))
GOTO QTMULT
+11 NEW XMDUZ,XMY,XMSUB,XMTEXT,VA,VAERR,XMZ,Y,SCTPDT,ZTQUEUED
+12 NEW DFN,SCOK,SCPTNM,SCFLD,SCNODE,SCNDX,SCSPACE,SCE,SCB
+13 NEW SCTPNM,SCTMNM,SCFTPNM,SCFTMNM,SCDELTEM,SCDETAIL
+14 SET ZTQUEUED=1
+15 ;ok to delete tmp global
SET DELTEM=1
+16 SET $PIECE(SCSPACE," ",80)=""
+17 SET XMSUB="Multiple PATIENT-POSITION REASSIGNMENT FAILURES for "_$$POSNAME(+SCTP)
+18 SET XMTEXT="^TMP($J,""SCTPXM"","
+19 SET SCLNCNT=0
+20 SET SCOK=1
+21 DO SETLN("Team: "_$$TMNAME(+SCTP))
+22 DO SETLN("Position: "_$$POSNAME(+SCTP))
+23 DO SETLN("Effective Date: "_$$FMTE^XLFDT(SCDATE))
+24 DO SETLN("Total Processed: "_$$PASSCNT^SCMCBK5(DFNA))
+25 DO SETLN("From Team: "_$$TMNAME(+SCFTP))
+26 DO SETLN("From Position: "_$$POSNAME(+SCFTP))
+27 DO SETLN(" ")
+28 IF $DATA(SCFIELDA)
Begin DoDot:1
+29 FOR SCNDX=1:1:14
SET SCFLD=SCNDX*.01
IF $DATA(SCFIELDA(SCFLD))
Begin DoDot:2
+30 SET $PIECE(SCNODE,U,SCNDX)=SCFIELDA(SCFLD)
+31 DO SETLN($$TEXT(404.43,SCNODE,SCNDX,SCSPACE,1))
End DoDot:2
End DoDot:1
+32 DO SETLN(" ")
BAD IF $ORDER(@SCBADTP@(0))
Begin DoDot:1
+1 DO SETLN(" ")
+2 ;;D SETLN("There has been NO new position reassignment for the following patients:")
+3 DO SETLN("The following position reassignments did not complete processing:")
+4 SET DFN=0
+5 FOR
SET DFN=$ORDER(@SCBADTP@(DFN))
IF 'DFN
QUIT
Begin DoDot:2
+6 SET SCPTNM=$PIECE(^DPT(DFN,0),U,1)
+7 DO PID^VADPT6
+8 SET ^TMP("SCTP MAIL LST",$JOB,SCTP,2,DFN)=(" "_SCPTNM_" ("_$GET(VA("PID"))_")")
+9 SET ^TMP("SCTP MAIL LST",$JOB,SCTP,3,DFN)=" "_@SCBADTP@(DFN)
+10 SET ^TMP("SCTP MAIL LST",$JOB,SCTP,2,"B",SCPTNM,DFN)=""
End DoDot:2
+11 SET SCPTNM=""
+12 FOR
SET SCPTNM=$ORDER(^TMP("SCTP MAIL LST",$JOB,SCTP,2,"B",SCPTNM))
IF SCPTNM']""
QUIT
Begin DoDot:2
+13 SET DFN=0
+14 FOR
SET DFN=$ORDER(^TMP("SCTP MAIL LST",$JOB,SCTP,2,"B",SCPTNM,DFN))
IF 'DFN
QUIT
Begin DoDot:3
+15 SET SCDETAIL=$GET(^TMP("SCTP MAIL LST",$JOB,SCTP,2,DFN))
IF SCDETAIL']""
QUIT
DO SETLN(SCDETAIL)
+16 SET SCDETAIL=$GET(^TMP("SCTP MAIL LST",$JOB,SCTP,3,DFN))
IF SCDETAIL']""
QUIT
DO SETLN(SCDETAIL)
End DoDot:3
End DoDot:2
End DoDot:1
+17 SET XMDUZ="PCMM Reassignment"
+18 KILL XMY
SET XMY(DUZ)=""
+19 SET SCX=$ORDER(^SD(404.91,"B",0))_","
+20 IF +SCX
SET XMY("G."_$$GET1^DIQ(404.91,SCX,804))=""
+21 DO ^XMD
QTMULT IF $GET(SCDELTEM)
KILL ^TMP("SCTP MAIL LST",$JOB,SCTP)
+1 KILL ^TMP($JOB,"SCTPXM")
+2 QUIT
+3 ;
+4 ;----------------------------- subs ------------------------------------
+5 ;
SETLN(TEXT) ;
+1 IF $GET(TEXT)=""
QUIT
+2 ; increments SCLNCNT, adds text to scTPxm(sclncnt)
+3 SET SCLNCNT=SCLNCNT+1
+4 SET ^TMP($JOB,"SCTPXM",SCLNCNT)=TEXT
+5 QUIT
+6 ;
TEXT(SCFILE,SCNODE,SCPC,SCSPACE,SCLAB) ;returns fldname & external value
+1 ;returns fldname & external value
+2 ; Note- Only works for non wp fields of standard numbering conventions
+3 ; SCFLILE =FILENUM
+4 ; SCNODE = 0 NODE
+5 ; SCPC = piece of node
+6 ; SCSPACE = 80 SPACES
+7 ; SCLAB = 1 if print field name
+8 NEW SCX,SCINT,SCFLD
+9 SET SCX=""
+10 SET SCINT=$PIECE(SCNODE,U,SCPC)
+11 IF SCINT=""
GOTO QTTXT
+12 SET SCFLD=SCPC*.01
+13 ;;;
+14 IF $GET(SCLAB)
Begin DoDot:1
+15 SET SCX=$$DDNAME^SCMCRU(SCFILE,SCFLD)_":"
+16 IF $GET(SCLAB)=1
SET SCX=SCX_$EXTRACT(SCSPACE,1,(27-$LENGTH(SCX)))
+17 IF $GET(SCLAB)=2
SET SCX=SCX_$EXTRACT(SCSPACE,1,(52-$LENGTH(SCX)))
End DoDot:1
+18 IF SCINT]""
SET SCX=SCX_$$EXTERNAL^DILFD(SCFILE,SCFLD,"",SCINT)
QTTXT QUIT SCX
+1 ;
DDNAME(FILE,FIELD) ;return the fieldname
+1 NEW SCX
+2 DO FIELD^DID(FILE,FIELD,"","LABEL","SCX")
+3 QUIT $GET(SCX("LABEL"))
+4 ;
POSNAME(SCX) ; return position external name
+1 QUIT $PIECE($GET(^SCTM(404.57,+SCX,0)),U)
+2 ;
TMNAME(SCX) ; return team external name
+1 QUIT $PIECE($GET(^SCTM(404.51,+$PIECE($GET(^SCTM(404.57,+SCX,0)),U,2),0)),U)
+2 ;
+3
