BSDLTP.m

BSDLTP ;ALB/LDB - PRINT SCHEDULING LETTERS ; [ 01/02/2004  9:07 AM ]

 ;;5.3;Scheduling;**79,106,170,80,1013**;Aug 13, 1993

 ;IHS/ANMC/LJF 8/18/2000 set DIC(W) to warn if clinic inactivated

 ;                       added variables to kill list

 ;ihs/cmi/maw 05/02/2011 added W to allowable letters to print

 ;

MAIN(L0) ;-- pass i letter type

 I L0="W" G R2

R D EXIT S SD9=0,SDLT=1,DIC=407.6,DIC(0)="AEQMZ",DIC("A")="SELECT THE TYPE OF LETTER TO PRINT: ",DIC("S")="I ""^A^C^N^P^W^""[(""^""_$P($G(^(0)),U)_""^"")" D ^DIC G:Y'>0 EXIT S L0=Y(0,0) K DIC,DA  ;ihs/cmi/maw 5/2/2011 PATCH 1013 added W

R1 R !,"PRINT LETTER ASSIGNED TO THE CLINIC(S)" S %=1 D YN^DICN G:'% HELP1 G:%<0 EXIT I %=1 S SDLET=0 G DIV

 S L0="W"

R2 K DIC,X,Y S DIC=407.5,DIC("S")="I $P(^(0),""^"",2)="_""""_L0_"""",DIC(0)="AEQMZ" D ^DIC G:Y'>0 EXIT S SDLET=+Y

DIV S SDLT1=SDLET,SDV1=$O(^DG(40.8,0)) K DIC,X,Y I $D(^DG(43,1,"GL")),$P(^("GL"),"^",2) S DIC=40.8,DIC(0)="AEQM" D @($S(L0="P":"PALST",L0="C":"CNLET",L0="N":"NSLET1",L0="W":"WLLET",1:"PCNLET")_"^SDDIV") G:+Y<0 R S SDV1=+Y  ;ihs/cmi/maw P1013

 S VAUTD=0,VAUTD(SDV1)=$P(^DG(40.8,SDV1,0),"^"),SDFORM=0,SDTIME="*" I $D(^DG(40.8,SDV1,"LTR")),^("LTR") S SDFORM=1

L0 I L0="C" D IND G:$D(DTOUT)!(%=-1) R

 I L0="W" Q  ;ihs/cmi/maw 05/02/2011 PATCH 1013 select numbers to print and then quit

 S VAUTNI=2 I "APW"[L0!(L0="C"&(SD9)) D PC G:S1=-1 R I "Pp"[S1 D PAT G R:Y<0,DATE  ;ihs/cmi/maw 05/02/2011 added W

 S SDCONC="B" I L0="P" D NCOUNT^SDAL0 I SDCONC=U G R

 D NCLINIC^SDAL0 G:Y<0 R I VAUTC D EX G:%Y="^"!($D(DTOUT)) R I $D(X),X="^" G R

 ;IHS/ITSC/WAR 11/6/03 Commented out 1 line, beginnig with I L0="P"

DATE ;N %DT D DATE^SDUTL G:POP&('$D(SDBD)) EXIT G:POP&(X="^") EXIT S:'$D(SDED) SDED=SDBD S L2=$S(L0="C"&('SD9):"BEG1^SDC0",L0="N":"BC^SDN1",L0="P":"^SDL1",1:"^SDCNL")

 ;I L0="P" S SDBD=DT,SDED=$$FMADD^XLFDT(DT,365) S L2="^SDL1" G QUE  ;IHS/ANMC/LJF 11/02/2001  don't ask dates for pre-appt letters

 I L0="P" S SDT00="AEF"   ;IHS/ITSC/LJF 1/2/04 assume future dates for pre-appt letters

 N %DT D DATE^SDUTL G:POP&('$D(SDBD)) EXIT G:POP&(X="^") EXIT S:'$D(SDED) SDED=SDBD S L2=$S(L0="C"&('SD9):"BEG1^SDC0",L0="N":"BC^SDN1",L0="P":"^SDL1",L0="W":"^SDL1",1:"^SDCNL")  ;ihs/cmi/maw 05/02/2011 added W

QUE S DGPGM=L2,DGVAR="SDCONC^SDLT^SDFORM^SDV1^SDLT1^SDLET^VAUTD#^SDBD^SDED"_$S($D(VAUTNALL):"^VAUTNALL",1:"")_$S($D(VAUTC):"^VAUTC#",1:"")_$S($D(VAUTN):"^VAUTN#",1:"")

 S DGVAR=DGVAR_$S(L2="^SDCNL":"^SD9",1:"^SDTIME")_$S($D(S1):"^S1",1:"")_$S($D(SDVAUTC):"^SDVAUTC#",1:"")

 D ZIS^DGUTQ G:POP EXIT

 U IO D @L2

EXIT K %,%Y,A2,BEGDATE,C,DIC,DGPGM,DGVAR,DIV,DIW,DIWF,DIWL,DIWR,DIWT,ENDDATE,ENDATE,L,LL,L0,L2,POP,S1,SD9,SDC,SDDAT,SDCL,SC,SDADD,SDARRAY,SDTADB,SDTADE,SDBD,SDCONC,SDCNT,SDD,SDED,SDHX,SDIV,SDFORM,SDLET,SDLT1,SDLT,SDMDT,SDT0,SDTIME,SDV,SDV1,SDX

 D KVA^VADPT,KILL^AUPNPAT K SDT00   ;IHS/ANMC/LJF 8/18/2000

 K SDX1,VAUTC,VAUTN,VAUTNI,VAUTD,SDVAUTC,X,XX,Y,W,Z0,Z5,^UTILITY("SDLT"),^UTILITY($J,"W") D CLOSE^DGUTQ Q

HELP W !,"LETTER TYPE MUST EXIST IN LETTERS TYPE FILE!" S DIC=407.6 K DIC("S") D ^DIC G R

HELP1 W !,"If you want to print another letter for the selected clinic(s), you must answer",!,"""N"""_" and select another letter of the appropriate type. If you do this, that ",!,"letter will print for (ALL) the selected clinic(s)." G R1

PC R !,"Enter 'P' for individual PATIENT letters or 'C' for letters by CLINIC: P// ",S1:DTIME S:S1["^"!('$T) S1=-1 Q:S1=-1  S:S1="" S1="P" I "PCpc"'[S1 W "??" D HELP2 G PC

 Q

HELP2 W !,"Entering 'P' will allow you to select PATIENT(S) and entering a 'C' will allow",!,"you to select CLINIC(S)." Q

PAT S VAUTNI=2,VAUTNALL=1 D PATIENT^VAUTOMA Q

EX S SDCNT=0 W !,"Do you want to exclude any Clinic(s)" S %=2 D YN^DICN I '% W !,"RESPOND YES OR NO" G EX

 K SDVAUTC Q:%-1

EXASK ;

 S DIC("W")=$$INACTMSG^BSDU  ;IHS/ANMC/LJF 8/18/2000

 S DIC=44,DIC(0)="AEQM",DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))",DIC("A")="Select Clinic to be excluded: " D ^DIC K DIC("A"),DIC("S") Q:"^"[X  G:Y<0 EXASK I $D(SDVAUTC(+Y)) W !,*7,"THIS CLINIC HAS ALREADY BEEN SELECTED!" G EXASK

 S SDCNT=SDCNT+1,SDVAUTC(+Y)="" W " ...OK" W:SDCNT'<10 !,*7,"ONLY TEN CLINICS ARE ALLOWED TO BE SELECTED!" G:SDCNT<10 EXASK

 Q

MAX W !,*7,"NO MORE THAN TEN CLINICS ALLOWED TO BE EXCLUDED" Q

IND S %=1,SD9=0 W !,"DID CLINIC CANCEL AVAILABILITY" D YN^DICN I '% D HLP3 G IND

 S:%-1 SD9=1 Q

HLP3 W !!,"If the clinic was cancelled for any length of time respond 'Y'.",!,"If individual appointments were cancelled without cancelling the clinic respond 'N'",! Q

 W !,"CLINIC CANCELLATION LETTERS will be selectable with 'C' response.",! Q

SEL ;-- select the entries on the list manager screen to print

 Q

 ;

BSDLTP    ;ALB/LDB - PRINT SCHEDULING LETTERS ; [ 01/02/2004  9:07 AM ]

 +1       ;;5.3;Scheduling;**79,106,170,80,1013**;Aug 13, 1993

 +2       ;IHS/ANMC/LJF 8/18/2000 set DIC(W) to warn if clinic inactivated

 +3       ;                       added variables to kill list

 +4       ;ihs/cmi/maw 05/02/2011 added W to allowable letters to print

 +5       ;

MAIN(L0)  ;-- pass i letter type

 +1        IF L0="W"

               GOTO R2

R         ;ihs/cmi/maw 5/2/2011 PATCH 1013 added W

           DO EXIT

           SET SD9=0

           SET SDLT=1

           SET DIC=407.6

           SET DIC(0)="AEQMZ"

           SET DIC("A")="SELECT THE TYPE OF LETTER TO PRINT: "

           SET DIC("S")="I ""^A^C^N^P^W^""[(""^""_$P($G(^(0)),U)_""^"")"

           DO ^DIC

           IF Y'>0

               GOTO EXIT

           SET L0=Y(0,0)

           KILL DIC,DA

R1         READ !,"PRINT LETTER ASSIGNED TO THE CLINIC(S)"

           SET %=1

           DO YN^DICN

           IF '%

               GOTO HELP1

           IF %<0

               GOTO EXIT

           IF %=1

               SET SDLET=0

               GOTO DIV

 +1        SET L0="W"

R2         KILL DIC,X,Y

           SET DIC=407.5

           SET DIC("S")="I $P(^(0),""^"",2)="_""""_L0_""""

           SET DIC(0)="AEQMZ"

           DO ^DIC

           IF Y'>0

               GOTO EXIT

           SET SDLET=+Y

DIV       ;ihs/cmi/maw P1013

           SET SDLT1=SDLET

           SET SDV1=$ORDER(^DG(40.8,0))

           KILL DIC,X,Y

           IF $DATA(^DG(43,1,"GL"))

               IF $PIECE(^("GL"),"^",2)

                   SET DIC=40.8

                   SET DIC(0)="AEQM"

                   DO @($SELECT(L0="P":"PALST",L0="C":"CNLET",L0="N":"NSLET1",L0="W":"WLLET",1:"PCNLET")_"^SDDIV")

                   IF +Y<0

                       GOTO R

                   SET SDV1=+Y

 +1        SET VAUTD=0

           SET VAUTD(SDV1)=$PIECE(^DG(40.8,SDV1,0),"^")

           SET SDFORM=0

           SET SDTIME="*"

           IF $DATA(^DG(40.8,SDV1,"LTR"))

               IF ^("LTR")

                   SET SDFORM=1

L0         IF L0="C"

               DO IND

               IF $DATA(DTOUT)!(%=-1)

                   GOTO R

 +1       ;ihs/cmi/maw 05/02/2011 PATCH 1013 select numbers to print and then quit

           IF L0="W"

               QUIT 

 +2       ;ihs/cmi/maw 05/02/2011 added W

           SET VAUTNI=2

           IF "APW"[L0!(L0="C"&(SD9))

               DO PC

               IF S1=-1

                   GOTO R

               IF "Pp"[S1

                   DO PAT

                   IF Y<0

                       GOTO R

                   GOTO DATE

 +3        SET SDCONC="B"

           IF L0="P"

               DO NCOUNT^SDAL0

               IF SDCONC=U

                   GOTO R

 +4        DO NCLINIC^SDAL0

           IF Y<0

               GOTO R

           IF VAUTC

               DO EX

               IF %Y="^"!($DATA(DTOUT))

                   GOTO R

               IF $DATA(X)

                   IF X="^"

                       GOTO R

 +5       ;IHS/ITSC/WAR 11/6/03 Commented out 1 line, beginnig with I L0="P"

DATE      ;N %DT D DATE^SDUTL G:POP&('$D(SDBD)) EXIT G:POP&(X="^") EXIT S:'$D(SDED) SDED=SDBD S L2=$S(L0="C"&('SD9):"BEG1^SDC0",L0="N":"BC^SDN1",L0="P":"^SDL1",1:"^SDCNL")

 +1       ;I L0="P" S SDBD=DT,SDED=$$FMADD^XLFDT(DT,365) S L2="^SDL1" G QUE  ;IHS/ANMC/LJF 11/02/2001  don't ask dates for pre-appt letters

 +2       ;IHS/ITSC/LJF 1/2/04 assume future dates for pre-appt letters

           IF L0="P"

               SET SDT00="AEF"

 +3       ;ihs/cmi/maw 05/02/2011 added W

           NEW %DT

           DO DATE^SDUTL

           IF POP&('$DATA(SDBD))

               GOTO EXIT

           IF POP&(X="^")

               GOTO EXIT

           IF '$DATA(SDED)

               SET SDED=SDBD

           SET L2=$SELECT(L0="C"&('SD9):"BEG1^SDC0",L0="N":"BC^SDN1",L0="P":"^SDL1",L0="W":"^SDL1",1:"^SDCNL")

QUE        SET DGPGM=L2

           SET DGVAR="SDCONC^SDLT^SDFORM^SDV1^SDLT1^SDLET^VAUTD#^SDBD^SDED"_$SELECT($DATA(VAUTNALL):"^VAUTNALL",1:"")_$SELECT($DATA(VAUTC):"^VAUTC#",1:"")_$SELECT($DATA(VAUTN):"^VAUTN#",1:"")

 +1        SET DGVAR=DGVAR_$SELECT(L2="^SDCNL":"^SD9",1:"^SDTIME")_$SELECT($DATA(S1):"^S1",1:"")_$SELECT($DATA(SDVAUTC):"^SDVAUTC#",1:"")

 +2        DO ZIS^DGUTQ

           IF POP

               GOTO EXIT

 +3        USE IO

           DO @L2

EXIT       KILL %,%Y,A2,BEGDATE,C,DIC,DGPGM,DGVAR,DIV,DIW,DIWF,DIWL,DIWR,DIWT,ENDDATE,ENDATE,L,LL,L0,L2,POP,S1,SD9,SDC,SDDAT,SDCL,SC,SDADD,SDARRAY,SDTADB,SDTADE,SDBD,SDCONC,SDCNT,SDD,SDED,SDHX,SDIV,SDFORM,SDLET,SDLT1,SDLT,SDMDT,SDT0,SDTIME,SDV,SDV1,SDX

 +1       ;IHS/ANMC/LJF 8/18/2000

           DO KVA^VADPT

           DO KILL^AUPNPAT

           KILL SDT00

 +2        KILL SDX1,VAUTC,VAUTN,VAUTNI,VAUTD,SDVAUTC,X,XX,Y,W,Z0,Z5,^UTILITY("SDLT"),^UTILITY($JOB,"W")

           DO CLOSE^DGUTQ

           QUIT 

HELP       WRITE !,"LETTER TYPE MUST EXIST IN LETTERS TYPE FILE!"

           SET DIC=407.6

           KILL DIC("S")

           DO ^DIC

           GOTO R

HELP1      WRITE !,"If you want to print another letter for the selected clinic(s), you must answer",!,"""N"""_" and select another letter of the appropriate type. If you do this, that ",!,"letter will print for (ALL) the selected clinic(s)."

           GOTO R1

PC         READ !,"Enter 'P' for individual PATIENT letters or 'C' for letters by CLINIC: P// ",S1:DTIME

           IF S1["^"!('$TEST)

               SET S1=-1

           IF S1=-1

               QUIT 

           IF S1=""

               SET S1="P"

           IF "PCpc"'[S1

               WRITE "??"

               DO HELP2

               GOTO PC

 +1        QUIT 

HELP2      WRITE !,"Entering 'P' will allow you to select PATIENT(S) and entering a 'C' will allow",!,"you to select CLINIC(S)."

           QUIT 

PAT        SET VAUTNI=2

           SET VAUTNALL=1

           DO PATIENT^VAUTOMA

           QUIT 

EX         SET SDCNT=0

           WRITE !,"Do you want to exclude any Clinic(s)"

           SET %=2

           DO YN^DICN

           IF '%

               WRITE !,"RESPOND YES OR NO"

               GOTO EX

 +1        KILL SDVAUTC

           IF %-1

               QUIT 

EXASK     ;

 +1       ;IHS/ANMC/LJF 8/18/2000

           SET DIC("W")=$$INACTMSG^BSDU

 +2        SET DIC=44

           SET DIC(0)="AEQM"

           SET DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))"

           SET DIC("A")="Select Clinic to be excluded: "

           DO ^DIC

           KILL DIC("A"),DIC("S")

           IF "^"[X

               QUIT 

           IF Y<0

               GOTO EXASK

           IF $DATA(SDVAUTC(+Y))

               WRITE !,*7,"THIS CLINIC HAS ALREADY BEEN SELECTED!"

               GOTO EXASK

 +3        SET SDCNT=SDCNT+1

           SET SDVAUTC(+Y)=""

           WRITE " ...OK"

           IF SDCNT'<10

               WRITE !,*7,"ONLY TEN CLINICS ARE ALLOWED TO BE SELECTED!"

           IF SDCNT<10

               GOTO EXASK

 +4        QUIT 

MAX        WRITE !,*7,"NO MORE THAN TEN CLINICS ALLOWED TO BE EXCLUDED"

           QUIT 

IND        SET %=1

           SET SD9=0

           WRITE !,"DID CLINIC CANCEL AVAILABILITY"

           DO YN^DICN

           IF '%

               DO HLP3

               GOTO IND

 +1        IF %-1

               SET SD9=1

           QUIT 

HLP3       WRITE !!,"If the clinic was cancelled for any length of time respond 'Y'.",!,"If individual appointments were cancelled without cancelling the clinic respond 'N'",!

           QUIT 

 +1        WRITE !,"CLINIC CANCELLATION LETTERS will be selectable with 'C' response.",!

           QUIT 

SEL       ;-- select the entries on the list manager screen to print

 +1        QUIT 

 +2       ;