SCMRTMM.m

SCMRTMM ;ALB/REW/PDR - Patient Team Multiple Reasssignment MailMessages ; 17 JUL 98

 ;;5.3;Scheduling;**148,157,1015**;AUG 13, 1993;Build 21

 ;

SETLN(TEXT) ;

 Q:$G(TEXT)=""

 ; increments SCLNCNT, adds text to sctmxm(sclncnt)

 S SCLNCNT=SCLNCNT+1

 S ^TMP($J,"SCTMXM",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(SCFILE,SCFLD)_":"

 . S:$G(SCLAB)=1 SCX=SCX_$E(SCSPACE,1,(23-$L(SCX)))

 . S:$G(SCLAB)=2 SCX=SCX_$E(SCSPACE,1,(50-$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"))

 ;

MAILLST(SCTM,SCFIELDA,SCDATE,SCBADTM) ; Reports only reassignment failures

 ; Input:

 ;    SCTM     - Pointer to Team File (#404.51)

 ;    SCFIELDA - Field array with internal values

 ;    SCDATE   - Effective Date

 ;    SCBADTM  - DFN array of patients unassignable to team

 ;

 G:$G(SCNOMAIL) QTMULT  ;- flag can be set to stop message generation

 G:'$S('$D(SCBADTM):0,1:$O(@SCBADTM@(0))) QTMULT  ; bail out if nothing to print

 N XMDUZ,XMY,XMSUB,XMTEXT,VA,VAERR,XMZ,Y,ZTQUEUED

 N SCTMNM,DFN,SCOK,SCPTNM,SCFLD,SCNODE,SCNDX,SCSPACE,SCE,SCB,SCTMDT,SCDELTEM

 S ZTQUEUED=1

 S SCDELTEM=1 ;ok to delete tmp global

 IF $D(SCFIELDA) D

 . IF $D(SCFIELDA(.02)) S SCB=SCFIELDA(.02)

 . IF $D(SCFIELDA(.09)) S SCE=SCFIELDA(.09)

 S SCB=$G(SCB,DT)

 S SCE=$G(SCE,DT)

 S $P(SCSPACE," ",80)=""

 S SCTMDT("BEGIN")=$S(SCB<SCDATE:SCB,1:SCDATE)

 S SCTMDT("END")=$S(SCE>SCDATE:SCE,1:SCDATE)

 S SCTMDT("INCL")=0

 S SCTMNM=$P($G(^SCTM(404.51,+SCTM,0)),U,1)

 S XMSUB="Multiple PATIENT-TEAM REASSIGNMENT FAILURES for "_SCTMNM,XMTEXT="^TMP($J,""SCTMXM"",",SCLNCNT=0

 D:'$G(DGQUIET) EN^DDIOL("Sending Multiple Patient-Team Reassignment Failures Message")

 S SCOK=1

 S SCTMNM=$P($G(^SCTM(404.51,+SCTM,0)),U,1)

 D SETLN("Team:                  "_SCTMNM)

 S Y=SCDATE X ^DD("DD")

 D SETLN("Effective Date:        "_Y)

 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.42,SCNODE,SCNDX,SCSPACE,1))

 D SETLN(" ")

BAD ; Guts of message

 D SETLN(" ")

 D SETLN("There has been NO new team reassignment for the following patients:")

 S DFN=0

 F  S DFN=$O(@SCBADTM@(DFN)) Q:'DFN  D

 . ;;;S:$$PCMMXMY^SCAPMC25(3,DFN,,"SCTMDT",0) SCOK=0

 . S SCPTNM=$P(^DPT(DFN,0),U,1)

 . D PID^VADPT6

 . S ^TMP("SCTM MAIL LST",$J,SCTM,2,DFN)=(" "_SCPTNM_" ("_$G(VA("PID"))_")")_":"

 . S ^TMP("SCTM MAIL LST",$J,SCTM,3,DFN)=" "_@SCBADTM@(DFN)

 . S ^TMP("SCTM MAIL LST",$J,SCTM,2,"B",SCPTNM,DFN)=""

 S SCPTNM=""

 F  S SCPTNM=$O(^TMP("SCTM MAIL LST",$J,SCTM,2,"B",SCPTNM)) Q:SCPTNM']""  D

 . S DFN=0

 . F  S DFN=$O(^TMP("SCTM MAIL LST",$J,SCTM,2,"B",SCPTNM,DFN)) Q:'DFN  D

 .. S SCDETAIL=$G(^TMP("SCTM MAIL LST",$J,SCTM,2,DFN)) Q:SCDETAIL']""  D SETLN(SCDETAIL)

 .. S SCDETAIL=$G(^TMP("SCTM MAIL LST",$J,SCTM,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("SCTM MAIL LST",$J,SCTM)

 K ^TMP($J,"SCTMXM")

 Q

SCMRTMM   ;ALB/REW/PDR - Patient Team Multiple Reasssignment MailMessages ; 17 JUL 98

 +1       ;;5.3;Scheduling;**148,157,1015**;AUG 13, 1993;Build 21

 +2       ;

SETLN(TEXT) ;

 +1        IF $GET(TEXT)=""

               QUIT 

 +2       ; increments SCLNCNT, adds text to sctmxm(sclncnt)

 +3        SET SCLNCNT=SCLNCNT+1

 +4        SET ^TMP($JOB,"SCTMXM",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(SCFILE,SCFLD)_":"

 +16               IF $GET(SCLAB)=1

                       SET SCX=SCX_$EXTRACT(SCSPACE,1,(23-$LENGTH(SCX)))

 +17               IF $GET(SCLAB)=2

                       SET SCX=SCX_$EXTRACT(SCSPACE,1,(50-$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       ;

MAILLST(SCTM,SCFIELDA,SCDATE,SCBADTM) ; Reports only reassignment failures

 +1       ; Input:

 +2       ;    SCTM     - Pointer to Team File (#404.51)

 +3       ;    SCFIELDA - Field array with internal values

 +4       ;    SCDATE   - Effective Date

 +5       ;    SCBADTM  - DFN array of patients unassignable to team

 +6       ;

 +7       ;- flag can be set to stop message generation

           IF $GET(SCNOMAIL)

               GOTO QTMULT

 +8       ; bail out if nothing to print

           IF '$SELECT('$DATA(SCBADTM)

               GOTO QTMULT

 +9        NEW XMDUZ,XMY,XMSUB,XMTEXT,VA,VAERR,XMZ,Y,ZTQUEUED

 +10       NEW SCTMNM,DFN,SCOK,SCPTNM,SCFLD,SCNODE,SCNDX,SCSPACE,SCE,SCB,SCTMDT,SCDELTEM

 +11       SET ZTQUEUED=1

 +12      ;ok to delete tmp global

           SET SCDELTEM=1

 +13       IF $DATA(SCFIELDA)

               Begin DoDot:1

 +14               IF $DATA(SCFIELDA(.02))

                       SET SCB=SCFIELDA(.02)

 +15               IF $DATA(SCFIELDA(.09))

                       SET SCE=SCFIELDA(.09)

               End DoDot:1

 +16       SET SCB=$GET(SCB,DT)

 +17       SET SCE=$GET(SCE,DT)

 +18       SET $PIECE(SCSPACE," ",80)=""

 +19       SET SCTMDT("BEGIN")=$SELECT(SCB<SCDATE:SCB,1:SCDATE)

 +20       SET SCTMDT("END")=$SELECT(SCE>SCDATE:SCE,1:SCDATE)

 +21       SET SCTMDT("INCL")=0

 +22       SET SCTMNM=$PIECE($GET(^SCTM(404.51,+SCTM,0)),U,1)

 +23       SET XMSUB="Multiple PATIENT-TEAM REASSIGNMENT FAILURES for "_SCTMNM

           SET XMTEXT="^TMP($J,""SCTMXM"","

           SET SCLNCNT=0

 +24       IF '$GET(DGQUIET)

               DO EN^DDIOL("Sending Multiple Patient-Team Reassignment Failures Message")

 +25       SET SCOK=1

 +26       SET SCTMNM=$PIECE($GET(^SCTM(404.51,+SCTM,0)),U,1)

 +27       DO SETLN("Team:                  "_SCTMNM)

 +28       SET Y=SCDATE

           XECUTE ^DD("DD")

 +29       DO SETLN("Effective Date:        "_Y)

 +30       DO SETLN(" ")

 +31       IF $DATA(SCFIELDA)

               Begin DoDot:1

 +32               FOR SCNDX=1:1:14

                       SET SCFLD=SCNDX*.01

                       IF $DATA(SCFIELDA(SCFLD))

                           Begin DoDot:2

 +33                           SET $PIECE(SCNODE,U,SCNDX)=SCFIELDA(SCFLD)

 +34                           DO SETLN($$TEXT(404.42,SCNODE,SCNDX,SCSPACE,1))

                           End DoDot:2

               End DoDot:1

 +35       DO SETLN(" ")

BAD       ; Guts of message

 +1        DO SETLN(" ")

 +2        DO SETLN("There has been NO new team reassignment for the following patients:")

 +3        SET DFN=0

 +4        FOR 

               SET DFN=$ORDER(@SCBADTM@(DFN))

               IF 'DFN

                   QUIT 

               Begin DoDot:1

 +5       ;;;S:$$PCMMXMY^SCAPMC25(3,DFN,,"SCTMDT",0) SCOK=0

 +6                SET SCPTNM=$PIECE(^DPT(DFN,0),U,1)

 +7                DO PID^VADPT6

 +8                SET ^TMP("SCTM MAIL LST",$JOB,SCTM,2,DFN)=(" "_SCPTNM_" ("_$GET(VA("PID"))_")")_":"

 +9                SET ^TMP("SCTM MAIL LST",$JOB,SCTM,3,DFN)=" "_@SCBADTM@(DFN)

 +10               SET ^TMP("SCTM MAIL LST",$JOB,SCTM,2,"B",SCPTNM,DFN)=""

               End DoDot:1

 +11       SET SCPTNM=""

 +12       FOR 

               SET SCPTNM=$ORDER(^TMP("SCTM MAIL LST",$JOB,SCTM,2,"B",SCPTNM))

               IF SCPTNM']""

                   QUIT 

               Begin DoDot:1

 +13               SET DFN=0

 +14               FOR 

                       SET DFN=$ORDER(^TMP("SCTM MAIL LST",$JOB,SCTM,2,"B",SCPTNM,DFN))

                       IF 'DFN

                           QUIT 

                       Begin DoDot:2

 +15                       SET SCDETAIL=$GET(^TMP("SCTM MAIL LST",$JOB,SCTM,2,DFN))

                           IF SCDETAIL']""

                               QUIT 

                           DO SETLN(SCDETAIL)

 +16                       SET SCDETAIL=$GET(^TMP("SCTM MAIL LST",$JOB,SCTM,3,DFN))

                           IF SCDETAIL']""

                               QUIT 

                           DO SETLN(SCDETAIL)

                       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    ;

 +1        IF $GET(SCDELTEM)

               KILL ^TMP("SCTM MAIL LST",$JOB,SCTM)

 +2        KILL ^TMP($JOB,"SCTMXM")

 +3        QUIT