SCMCCON.m

SCMCCON ;ALB/REW - Patient Consult MailMessages ; 26 Mar 1996

 ;;5.3;Scheduling;**41,87,100,130,1015**;AUG 13, 1993;Build 21

 ;1

MAIL(DFN,SCCLNM,ENORAP,DATE,SCTMCNA) ;Do Patient Team Changes MailMan Message

 ;   DFN    - ien to PATIENT File

 ;   SCCLNM - Name of Clinic

 ;   ENORAP - Enrollment or Appointment? 1=Enrollment, 2=Appointment

 ;   DATE   - Date of interest, Default =DT

 ;   SCTMCNA- Array of teams affected

 ;

 ; - called by SCMC PT TEAM CHANGES MAIL MESSAGE protocol

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

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

 N SCTMAR,SCSTAT,SCNODE,SCY,SCSPACE,SCCNDTS,SCSTAT,SCTM

 S SCCNDTS("BEGIN")=DATE,SCCNDTS("END")=DATE

 S SCSTAT=$S(ENORAP=1:"Enrollment",(ENORAP=2):"Appointment",1:"")

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

 ;   SCTMAR - ARRAY OF TEAMS (before & after)

 ;set xmy array for practitioners in positions receiving consult notices

 G:'$$PCMMXMY^SCAPMC25(4,DFN,SCTMCNA,"SCCMDTS",0) END

 D:'$G(DGQUIET) EN^DDIOL("Sending Patient-Consult "_SCSTAT_" Message")

 D PID^VADPT6

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

 S XMSUB=SCSTAT_" PATIENT-CLINIC "_SCSTAT_" for Patient ("_$E(SCPTNM,1)_VA("BID")_")",XMTEXT="SCCNXM(",SCLNCNT=0

 D SETLN("This notice is sent because:")

 D SETLN("  The patient had an "_SCSTAT_" to "_$G(SCCLNM)_" and")

 D SETLN("  has restricted consults due to the following team assignment(s):")

 S SCTM=0

 F  S SCTM=$O(@SCTMCNA@(SCTM)) Q:'SCTM  D

 .D SETLN("         "_@SCTMCNA@(SCTM))

 S SCLNCNT=$$PCMAIL^SCMCMM(DFN,"SCCNXM",DT)

 S XMDUZ=$G(DUZ,.5)

 S XMY(XMDUZ)=""

 D ^XMD

END ;

 Q

 ;

SETLN(TEXT) ;

 Q:$G(TEXT)=""

 ; increments SCLNCNT, adds text to sccnxm(sclncnt)

 S SCLNCNT=SCLNCNT+1

 S SCCNXM(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^SCMCTMM(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

SCMCCON   ;ALB/REW - Patient Consult MailMessages ; 26 Mar 1996

 +1       ;;5.3;Scheduling;**41,87,100,130,1015**;AUG 13, 1993;Build 21

 +2       ;1

MAIL(DFN,SCCLNM,ENORAP,DATE,SCTMCNA) ;Do Patient Team Changes MailMan Message

 +1       ;   DFN    - ien to PATIENT File

 +2       ;   SCCLNM - Name of Clinic

 +3       ;   ENORAP - Enrollment or Appointment? 1=Enrollment, 2=Appointment

 +4       ;   DATE   - Date of interest, Default =DT

 +5       ;   SCTMCNA- Array of teams affected

 +6       ;

 +7       ; - called by SCMC PT TEAM CHANGES MAIL MESSAGE protocol

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

           IF $GET(SCNOMAIL)

               GOTO END

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

 +10       NEW SCTMAR,SCSTAT,SCNODE,SCY,SCSPACE,SCCNDTS,SCSTAT,SCTM

 +11       SET SCCNDTS("BEGIN")=DATE

           SET SCCNDTS("END")=DATE

 +12       SET SCSTAT=$SELECT(ENORAP=1:"Enrollment",(ENORAP=2):"Appointment",1:"")

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

 +14      ;   SCTMAR - ARRAY OF TEAMS (before & after)

 +15      ;set xmy array for practitioners in positions receiving consult notices

 +16       IF '$$PCMMXMY^SCAPMC25(4,DFN,SCTMCNA,"SCCMDTS",0)

               GOTO END

 +17       IF '$GET(DGQUIET)

               DO EN^DDIOL("Sending Patient-Consult "_SCSTAT_" Message")

 +18       DO PID^VADPT6

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

 +20       SET XMSUB=SCSTAT_" PATIENT-CLINIC "_SCSTAT_" for Patient ("_$EXTRACT(SCPTNM,1)_VA("BID")_")"

           SET XMTEXT="SCCNXM("

           SET SCLNCNT=0

 +21       DO SETLN("This notice is sent because:")

 +22       DO SETLN("  The patient had an "_SCSTAT_" to "_$GET(SCCLNM)_" and")

 +23       DO SETLN("  has restricted consults due to the following team assignment(s):")

 +24       SET SCTM=0

 +25       FOR 

               SET SCTM=$ORDER(@SCTMCNA@(SCTM))

               IF 'SCTM

                   QUIT 

               Begin DoDot:1

 +26               DO SETLN("         "_@SCTMCNA@(SCTM))

               End DoDot:1

 +27       SET SCLNCNT=$$PCMAIL^SCMCMM(DFN,"SCCNXM",DT)

 +28       SET XMDUZ=$GET(DUZ,.5)

 +29       SET XMY(XMDUZ)=""

 +30       DO ^XMD

END       ;

 +1        QUIT 

 +2       ;

SETLN(TEXT) ;

 +1        IF $GET(TEXT)=""

               QUIT 

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

 +3        SET SCLNCNT=SCLNCNT+1

 +4        SET SCCNXM(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^SCMCTMM(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