Routine: BSDX40

BSDX40 ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;

 ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010

 ;  APL - Print Appointment Letter

APL(BSDXY,BSDXAPID,LT)  ; Print Appointment Letter

 ; BSDXAPPT = Pointer to appointment in BSDX APPOINTMENT (^BSDXAPPT) file 9002018.4

 ; LT       = Letter type - "N"=No Show; "A"=Cancelled by Patient; "C"=Cancelled by Clinic

 ; Called by BSDX PRINT APPT LETTER remote procedure

 N BSDXI,BSDXNOD,BSDXTMP,DFN,IN,RES,SCLT,SDC,SDLET,SDS,SDT

 D ^XBKVAR S X="ERROR^BSDXERR",@^%ZOSF("TRAP")

 S BSDXI=0

 K ^BSDXTMP($J)

 S BSDXY="^BSDXTMP("_$J_")"

 S ^BSDXTMP($J,0)="T00080ERRORID"_$C(30)

 I '+BSDXAPID D ERR^BSDXERR("Invalid Appointment ID.") Q

 I '$D(^BSDXAPPT(BSDXAPID,0)) D ERR^BSDXERR("Invalid Appointment ID.") Q

 I $G(LT)="" D ERR^BSDXERR("Invalid Letter Type.") Q

 S BSDXNOD=^BSDXAPPT(BSDXAPID,0)

 S SDT=$P(BSDXNOD,U)  ;Get appt time

 S DFN=$P(BSDXNOD,U,5)  ;Get patient pointer to VA PATIENT (^DPT) file 2

 S RES=$P(BSDXNOD,U,7) S SDC=$P(^BSDXRES(RES,0),U,4)  ;get resource and clinic

 S SDS=^DPT(DFN,"S",SDT,0)

 S SCLT=$S(LT="N":1,LT="C":3,LT="A":4,1:"2") ;get storage position of LETTER pointer

 S SDLET=$P($G(^SC(SDC,"LTR")),U,SCLT)

 I SDLET="" D ERR^BSDXERR($S(SCLT=1:"No-Show",SCLT=2:"Pre-Appointment",SCLT=3:"Clinic Cancellation",1:"Patient Cancellation")_"Letter not defined for Clinic "_$P(^SC(SDC,0),U)_".") Q

 ; data header

 S ^BSDXTMP($J,0)="T10000TEXT"_$C(30)

 ;WRITE GREETING AND OPENING TEXT OF LETTER

 S Y=$P(SDT,".")

 D DTS^SDUTL

 S BSDXTMP="Date Printed: "_Y_$C(10,13)

 S BSDXTMP=BSDXTMP_"#"_$$HRCN^BDGF2(+DFN,DUZ(2))_$C(10,13)

 F I=1:1:4 S BSDXTMP=BSDXTMP_""_$C(10,13)

 D ADDR

 F I=1:1:3 S BSDXTMP=BSDXTMP_""_$C(10,13)

W1 ;

 S BSDXTMP=BSDXTMP_$$GREETING^BSDU(SDLET,DFN)_$C(10,13)

 F I=1:1:2 S BSDXTMP=BSDXTMP_""_$C(10,13)

 ;loop and display initial section of Letter

 S IN=0 F  S IN=$O(^VA(407.5,SDLET,1,IN)) Q:IN'>0  D

 . S BSDXTMP=BSDXTMP_^VA(407.5,SDLET,1,IN,0)_$C(10,13)

 S BSDXTMP=BSDXTMP_""_$C(10,13)

 ;Display appt/clinic info

 D WRAPP

 S BSDXTMP=BSDXTMP_""_$C(10,13)

 ;loop and display final section of letter

 S IN=0 F  S IN=$O(^VA(407.5,SDLET,2,IN)) Q:IN'>0  D

 . S BSDXTMP=BSDXTMP_^VA(407.5,SDLET,2,IN,0)_$C(10,13)

 S BSDXTMP=BSDXTMP_$C(30)

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(31)

WRAPP ;WRITE APPOINTMENT INFORMATION

 N SDCL,SDX,SDX1,X

 S SDX=SDT S SDCL=$P(^SC(SDC,0),U)_" Clinic" D FORM

 S SDX1=$S($D(SDT):SDT,1:X) S:$D(SDS) S=SDS F B=3,4,5 I $P(S,"^",B)]"" S SDCL=$S(B=3:"LAB",B=4:"XRAY",1:"EKG"),SDX=$P(S,"^",B) D FORM

 S (SDX,X)=SDX1 Q

FORM ;EP;

 ;IHS/ANMC/LJF 11/24/2000;3/23/2001 see line below

 N DOW,SDDAT,SDHX,SDT0

 S X=SDX

 S SDHX=X

 D DW^%DTC

 S DOW=X,X=SDHX

 S SDT0=$$TIME^BDGF(X),SDDAT=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",$E(SDHX,4,5))_" "_+$E(SDHX,6,7)_", "_(1700+$E(SDHX,1,3))

 S BSDXTMP=BSDXTMP_DOW_"  "_$J(SDDAT,12)_"  "_$J(SDT0,8)_" "_SDCL_$C(10,13)

REST ;EP; WRITE THE REMAINDER OF LETTER

 I $G(S1)="C" D FUTURE^BSDLT1(+A,$G(BSDCNT)) K BSDCNT  ;IHS/ANMC/LJF 11/29/2000;9/11/2001

 I SDLET W !?12 K ^UTILITY($J,"W"),DIWL,DIWR,DIWF S DIWL=6,DIWF="C70W" F Z5=0:0 S Z5=$O(^VA(407.5,SDLET,2,Z5)) Q:Z5'>0  S X=^(Z5,0) D ^DIWP  ;IHS/ANMC/LJF 11/24/2000

 D ^DIWW K ^UTILITY($J,"W") I 'SDFORM W @IOF Q  ;IHS/ANMC/LJF 6/5/2002 form feed at end of letter (LJF7 6/11/2002)

 F I=$Y:1:IOSL-12 W !

 D ADDR  W @IOF Q   ;IHS/ANMC/LJF 6/5/2002 put form feed at end of letter (LJF7 6/11/2002)

ADDR K VAHOW

 S BSDXTMP=BSDXTMP_$$FML^DGNFUNC(DFN)_$C(10,13) S VAHOW=2

 I $D(^DG(43,1,"BT")),'$P(^("BT"),"^",3) S VAPA("P")=""

 S X1=$P(SDT,"."),X2=5 D C^%DTC I '$D(VAPA("P")) S (VATEST("ADD",9),VATEST("ADD",10))=X

 D ADD^VADPT

 N SDCCACT1,SDCCACT2

 S SDCCACT1=^UTILITY("VAPA",$J,12),SDCCACT2=$P($G(^UTILITY("VAPA",$J,22,2)),"^",3)

 ;if confidential address is not active for scheduling/appointment letters, print to regular address

 I ($G(SDCCACT1)=0)!($G(SDCCACT2)'="Y") D

 .F LL=1:1:3 I ^UTILITY("VAPA",$J,LL)]"" S BSDXTMP=BSDXTMP_$S(LL=1:"",1:", ")_^UTILITY("VAPA",$J,LL)

 .S BSDXTMP=BSDXTMP_$C(10,13)

 .I ^UTILITY("VAPA",$J,4)]"" S BSDXTMP=BSDXTMP_^UTILITY("VAPA",$J,4)

 .I ^UTILITY("VAPA",$J,5)]"" S BSDXTMP=BSDXTMP_", "_$P(^UTILITY("VAPA",$J,5),"^",2)

 .I ^UTILITY("VAPA",$J,6)]"" S BSDXTMP=BSDXTMP_"  "_^UTILITY("VAPA",$J,6)_$C(10,13)

 ;if confidential address is active for scheduling/appointment letters, print to confidential address

 I $G(SDCCACT1)=1,$G(SDCCACT2)="Y" D

 .F LL=13:1:16 I ^UTILITY("VAPA",$J,LL)]"" S BSDXTMP=BSDXTMP_^UTILITY("VAPA",$J,LL)_$C(10,13)

 .I ^UTILITY("VAPA",$J,16)']"" S BSDXTMP=BSDXTMP_""_$C(10,13)

 .I ^UTILITY("VAPA",$J,17)]"" S BSDXTMP=BSDXTMP_", "_$P(^UTILITY("VAPA",$J,17),"^",2)_$C(10,13)

 .I ^UTILITY("VAPA",$J,18)]"" S BSDXTMP=BSDXTMP_"  "_$P(^UTILITY("VAPA",$J,18),U,2)_$C(10,13)

 S BSDXTMP=BSDXTMP_""_$C(10,13)

 D KVAR^VADPT

LAST4(DFN) ;Return patient "last four"

 N SDX

 S SDX=$G(^DPT(+DFN,0))

 Q $E(SDX)_$E($P(SDX,U,9),6,9)

BSDX40    ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;

 +1       ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010

 +2       ;

 +3       ;  APL - Print Appointment Letter

 +4       ;

APL(BSDXY,BSDXAPID,LT) ; Print Appointment Letter

 +1       ; BSDXAPPT = Pointer to appointment in BSDX APPOINTMENT (^BSDXAPPT) file 9002018.4

 +2       ; LT       = Letter type - "N"=No Show; "A"=Cancelled by Patient; "C"=Cancelled by Clinic

 +3       ; Called by BSDX PRINT APPT LETTER remote procedure

 +4        NEW BSDXI,BSDXNOD,BSDXTMP,DFN,IN,RES,SCLT,SDC,SDLET,SDS,SDT

 +5        DO ^XBKVAR

           SET X="ERROR^BSDXERR"

           SET @^%ZOSF("TRAP")

 +6        SET BSDXI=0

 +7        KILL ^BSDXTMP($JOB)

 +8        SET BSDXY="^BSDXTMP("_$JOB_")"

 +9        SET ^BSDXTMP($JOB,0)="T00080ERRORID"_$CHAR(30)

 +10       IF '+BSDXAPID

               DO ERR^BSDXERR("Invalid Appointment ID.")

               QUIT

 +11       IF '$DATA(^BSDXAPPT(BSDXAPID,0))

               DO ERR^BSDXERR("Invalid Appointment ID.")

               QUIT

 +12       IF $GET(LT)=""

               DO ERR^BSDXERR("Invalid Letter Type.")

               QUIT

 +13       SET BSDXNOD=^BSDXAPPT(BSDXAPID,0)

 +14      ;Get appt time

           SET SDT=$PIECE(BSDXNOD,U)

 +15      ;Get patient pointer to VA PATIENT (^DPT) file 2

           SET DFN=$PIECE(BSDXNOD,U,5)

 +16      ;get resource and clinic

           SET RES=$PIECE(BSDXNOD,U,7)

           SET SDC=$PIECE(^BSDXRES(RES,0),U,4)

 +17       SET SDS=^DPT(DFN,"S",SDT,0)

 +18      ;get storage position of LETTER pointer

           SET SCLT=$SELECT(LT="N":1,LT="C":3,LT="A":4,1:"2")

 +19       SET SDLET=$PIECE($GET(^SC(SDC,"LTR")),U,SCLT)

 +20       IF SDLET=""

               DO ERR^BSDXERR($SELECT(SCLT=1:"No-Show",SCLT=2:"Pre-Appointment",SCLT=3:"Clinic Cancellation",1:"Patient Cancellation")_"Letter not defined for Clinic "_$PIECE(^SC(SDC,0),U)_".")

               QUIT

 +21      ; data header

 +22       SET ^BSDXTMP($JOB,0)="T10000TEXT"_$CHAR(30)

 +23      ;WRITE GREETING AND OPENING TEXT OF LETTER

 +24       SET Y=$PIECE(SDT,".")

 +25       DO DTS^SDUTL

 +26       SET BSDXTMP="Date Printed: "_Y_$CHAR(10,13)

 +27       SET BSDXTMP=BSDXTMP_"#"_$$HRCN^BDGF2(+DFN,DUZ(2))_$CHAR(10,13)

 +28       FOR I=1:1:4

               SET BSDXTMP=BSDXTMP_""_$CHAR(10,13)

 +29       DO ADDR

 +30       FOR I=1:1:3

               SET BSDXTMP=BSDXTMP_""_$CHAR(10,13)

W1        ;

 +1        SET BSDXTMP=BSDXTMP_$$GREETING^BSDU(SDLET,DFN)_$CHAR(10,13)

 +2        FOR I=1:1:2

               SET BSDXTMP=BSDXTMP_""_$CHAR(10,13)

 +3       ;loop and display initial section of Letter

 +4        SET IN=0

FOR

               SET IN=$ORDER(^VA(407.5,SDLET,1,IN))

               IF IN'>0

                   QUIT

               Begin DoDot:1

 +5                SET BSDXTMP=BSDXTMP_^VA(407.5,SDLET,1,IN,0)_$CHAR(10,13)

               End DoDot:1

 +6        SET BSDXTMP=BSDXTMP_""_$CHAR(10,13)

 +7       ;Display appt/clinic info

 +8        DO WRAPP

 +9        SET BSDXTMP=BSDXTMP_""_$CHAR(10,13)

 +10      ;loop and display final section of letter

 +11       SET IN=0

FOR

               SET IN=$ORDER(^VA(407.5,SDLET,2,IN))

               IF IN'>0

                   QUIT

               Begin DoDot:1

 +12               SET BSDXTMP=BSDXTMP_^VA(407.5,SDLET,2,IN,0)_$CHAR(10,13)

               End DoDot:1

 +13       SET BSDXTMP=BSDXTMP_$CHAR(30)

 +14       SET BSDXI=BSDXI+1

           SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP

 +15       SET BSDXI=BSDXI+1

           SET ^BSDXTMP($JOB,BSDXI)=$CHAR(31)

 +16       QUIT

WRAPP     ;WRITE APPOINTMENT INFORMATION

 +1        NEW SDCL,SDX,SDX1,X

 +2        SET SDX=SDT

           SET SDCL=$PIECE(^SC(SDC,0),U)_" Clinic"

           DO FORM

 +3        SET SDX1=$SELECT($DATA(SDT):SDT,1:X)

           IF $DATA(SDS)

               SET S=SDS

           FOR B=3,4,5

               IF $PIECE(S,"^",B)]""

                   SET SDCL=$SELECT(B=3:"LAB",B=4:"XRAY",1:"EKG")

                   SET SDX=$PIECE(S,"^",B)

                   DO FORM

 +4        SET (SDX,X)=SDX1

           QUIT

FORM      ;EP;

 +1       ;IHS/ANMC/LJF 11/24/2000;3/23/2001 see line below

 +2        NEW DOW,SDDAT,SDHX,SDT0

 +3        SET X=SDX

 +4        SET SDHX=X

 +5        DO DW^%DTC

 +6        SET DOW=X

           SET X=SDHX

 +7        SET SDT0=$$TIME^BDGF(X)

           SET SDDAT=$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",$EXTRACT(SDHX,4,5))_" "_+$EXTRACT(SDHX,6,7)_", "_(1700+$EXTRACT(SDHX,1,3))

 +8        SET BSDXTMP=BSDXTMP_DOW_"  "_$JUSTIFY(SDDAT,12)_"  "_$JUSTIFY(SDT0,8)_" "_SDCL_$CHAR(10,13)

 +9        QUIT

REST      ;EP; WRITE THE REMAINDER OF LETTER

 +1       ;IHS/ANMC/LJF 11/29/2000;9/11/2001

           IF $GET(S1)="C"

               DO FUTURE^BSDLT1(+A,$GET(BSDCNT))

               KILL BSDCNT

 +2       ;IHS/ANMC/LJF 11/24/2000

           IF SDLET

               WRITE !?12

               KILL ^UTILITY($JOB,"W"),DIWL,DIWR,DIWF

               SET DIWL=6

               SET DIWF="C70W"

               FOR Z5=0:0

                   SET Z5=$ORDER(^VA(407.5,SDLET,2,Z5))

                   IF Z5'>0

                       QUIT

                   SET X=^(Z5,0)

                   DO ^DIWP

 +3       ;IHS/ANMC/LJF 6/5/2002 form feed at end of letter (LJF7 6/11/2002)

           DO ^DIWW

           KILL ^UTILITY($JOB,"W")

           IF 'SDFORM

               WRITE @IOF

               QUIT

 +4        FOR I=$Y:1:IOSL-12

               WRITE !

 +5       ;IHS/ANMC/LJF 6/5/2002 put form feed at end of letter (LJF7 6/11/2002)

           DO ADDR

           WRITE @IOF

           QUIT

 +6       ;

ADDR       KILL VAHOW

 +1        SET BSDXTMP=BSDXTMP_$$FML^DGNFUNC(DFN)_$CHAR(10,13)

           SET VAHOW=2

 +2        IF $DATA(^DG(43,1,"BT"))

               IF '$PIECE(^("BT"),"^",3)

                   SET VAPA("P")=""

 +3        SET X1=$PIECE(SDT,".")

           SET X2=5

           DO C^%DTC

           IF '$DATA(VAPA("P"))

               SET (VATEST("ADD",9),VATEST("ADD",10))=X

 +4        DO ADD^VADPT

 +5        NEW SDCCACT1,SDCCACT2

 +6        SET SDCCACT1=^UTILITY("VAPA",$JOB,12)

           SET SDCCACT2=$PIECE($GET(^UTILITY("VAPA",$JOB,22,2)),"^",3)

 +7       ;if confidential address is not active for scheduling/appointment letters, print to regular address

 +8        IF ($GET(SDCCACT1)=0)!($GET(SDCCACT2)'="Y")

               Begin DoDot:1

 +9                FOR LL=1:1:3

                       IF ^UTILITY("VAPA",$JOB,LL)]""

                           SET BSDXTMP=BSDXTMP_$SELECT(LL=1:"",1:", ")_^UTILITY("VAPA",$JOB,LL)

 +10               SET BSDXTMP=BSDXTMP_$CHAR(10,13)

 +11               IF ^UTILITY("VAPA",$JOB,4)]""

                       SET BSDXTMP=BSDXTMP_^UTILITY("VAPA",$JOB,4)

 +12               IF ^UTILITY("VAPA",$JOB,5)]""

                       SET BSDXTMP=BSDXTMP_", "_$PIECE(^UTILITY("VAPA",$JOB,5),"^",2)

 +13               IF ^UTILITY("VAPA",$JOB,6)]""

                       SET BSDXTMP=BSDXTMP_"  "_^UTILITY("VAPA",$JOB,6)_$CHAR(10,13)

               End DoDot:1

 +14      ;if confidential address is active for scheduling/appointment letters, print to confidential address

 +15       IF $GET(SDCCACT1)=1

               IF $GET(SDCCACT2)="Y"

                   Begin DoDot:1

 +16                   FOR LL=13:1:16

                           IF ^UTILITY("VAPA",$JOB,LL)]""

                               SET BSDXTMP=BSDXTMP_^UTILITY("VAPA",$JOB,LL)_$CHAR(10,13)

 +17                   IF ^UTILITY("VAPA",$JOB,16)']""

                           SET BSDXTMP=BSDXTMP_""_$CHAR(10,13)

 +18                   IF ^UTILITY("VAPA",$JOB,17)]""

                           SET BSDXTMP=BSDXTMP_", "_$PIECE(^UTILITY("VAPA",$JOB,17),"^",2)_$CHAR(10,13)

 +19                   IF ^UTILITY("VAPA",$JOB,18)]""

                           SET BSDXTMP=BSDXTMP_"  "_$PIECE(^UTILITY("VAPA",$JOB,18),U,2)_$CHAR(10,13)

                   End DoDot:1

 +20       SET BSDXTMP=BSDXTMP_""_$CHAR(10,13)

 +21       DO KVAR^VADPT

 +22       QUIT

 +23      ;

LAST4(DFN) ;Return patient "last four"

 +1        NEW SDX

 +2        SET SDX=$GET(^DPT(+DFN,0))

 +3        QUIT $EXTRACT(SDX)_$EXTRACT($PIECE(SDX,U,9),6,9)

 +4       ;

BSDX40.m