SDL1 ;BSN/GRR,ALB/LDB - PRE-APPOINTMENT LETTERS ; 7/7/04 10:45am
;;5.3;Scheduling;**106,330,340,407,398**;Aug 13, 1993
;
;******************MODIFICATIONS***********************************
;
; DATE PATCH DEVELOPER DESCRIPTION
; ---- ----- --------- -----------
; 12/12/2003 SD*5.3*330 JOHN LUNDEN FIX FORM FEED LOGIC
;
;******************************************************************
;
U IO N SDBAD K ^UTILITY($J) S SDLT1=SDLET G:"Pp"'[S1 BC
I $D(VAUTN) D
.F C=0:0 S C=$O(VAUTN(C)) Q:'C S DFN=C D
..D BAD Q:SDBAD D DATE
D LST Q
DATE F D=SDBD:0 S D=$O(^DPT(C,"S",D)) Q:'D!(D>(SDED+.9999)) I $D(^(D,0)),$P(^(0),"^",2)'["C",$S('$D(^DPT(C,.35)):1,$P(^(.35),"^",1)']"":1,1:0) S A1=C,B1=D,D1=+^DPT(C,"S",D,0) D SET
Q
APP F J=0:0 S J=$O(^UTILITY($J,L,A,J)) Q:'J S SDX=J,SDC=^(J),S=^DPT(+A,"S",J,0) D WRAPP^SDLT
D REST^SDLT Q
BC S U="^" I $D(VAUTC),'VAUTC D CL G LST
ALCL F C=0:0 S C=$O(^SC(C)) Q:'C I '$D(SDVAUTC(C)),$P(^SC(C,0),U,3)="C",$S('$D(^("I")):1,'+^("I"):1,+^("I")<SDBD&('$P(^("I"),U,2)):0,+^("I")<SDBD&($P(^("I"),U,2)>SDED):0,1:1) D NCHECK I $T D D D:$D(SDD) OVER
LST N SDFIRST S SDFIRST=1 ;SD*5.3*330. Flag to determine first pag
F L=0:0 S L=$O(^UTILITY($J,L)) Q:'L D
.F A=0:0 S A=$O(^UTILITY($J,L,A)) Q:'A D
..S DFN=A D BAD Q:SDBAD
..S SDLET=L D ^SDLT,APP
D NO,END,CLOSE^DGUTQ Q
CL F C=0:0 S C=$O(VAUTC(C)) Q:'C S:'SDLT1 SDLET=0 D OVER
Q
OVER Q:'$D(^SC(C,"S"))
F SDT=SDBD:0 S SDT=$O(^SC(C,"S",SDT)) Q:'SDT!(SDT>(SDED+.9999)) D
.F K=0:0 S K=$O(^SC(C,"S",SDT,1,K)) Q:'K D
..S DFN=+^(K,0)
..I $P(^(0),"^",9)'["C" D BAD Q:SDBAD D CHECK
Q
END W ! K %,%H,%I,%Y,%DT,%IS,%ZIS,A,B,C,D,DN,CLIN,CNN,DATE,DATEND,DFN,DIC,DIV,DOW,GDATE,SDHX,I,J,J1,K,L,L0,PDAT,S,S1,SC,SDADD,SDFORM,SDT,SDXX,TIME,X,Y,Z,Z0,Z5 Q
CHECK I $S('$D(^DPT(DFN,.35)):1,$P(^(.35),"^",1)']"":1,1:0),$D(^DPT(DFN,"S",SDT,0)),$P(^(0),"^",2)'["C",'$D(^DPT(DFN,.1)) S A1=DFN,B1=SDT,D1=C D SET
Q
SET I $D(^SC(D1,"LTR"))!(SDLT1) S:'SDLT1 SDLET=$P(^SC(D1,"LTR"),"^",2) I SDLET S ^UTILITY($J,SDLET,A1,B1)=D1 S:'SDLT1 SDLET=0 K A,A1,B1,D1 Q
I 'SDLET S ^UTILITY($J,"C",A1,D1)="" K A,A1,B1,D1 Q
Q
NO I $D(VAUTN),'$O(^UTILITY($J,0)),'$D(^UTILITY($J,"C")) D
.I SDBAD Q ;W !,"THIS PATIENT(S) HAS THE BAD ADDRESS INDICATOR SET AND PRE-APPOINTMENT LETTER(S) WILL NOT PRINT." Q
.W !,"NO ACTIVE APPOINTMENTS FOR THE PATIENT(S) DURING THAT TIME PERIOD!",*7
I $D(^UTILITY($J,"C")) W @IOF F X=0:0 S X=$O(^UTILITY($J,"C",X)) Q:'X W !!,$P(^DPT(X,0),"^")," ",$P(^(0),"^",9)," HAS FUTURE APPTS., but" D NOCL
I $D(^TMP($J,"BADADD")) D BADADD^SDLT K ^TMP($J,"BADADD")
Q
NOCL F XX=0:0 S XX=$O(^UTILITY($J,"C",X,XX)) Q:'XX W !,$P(^SC(XX,0),"^")," Clinic is not assigned a PRE-APPOINTMENT LETTER"
Q
D K SDD I ($P(^SC(C,0),"^",15)=SDV1)!(SDV1=$O(^DG(40.8,0))&($P(^SC(C,0),"^",15)="")) S SDD=1
Q
NCHECK ;
N NOC S NOC=$P($G(^SC(C,0)),U,17)
I SDCONC="B" Q
I SDCONC="C"&(NOC="N") Q
I SDCONC="N"&(NOC="Y") Q
Q
BAD S SDBAD=$$BADADR^DGUTL3(+DFN)
S:SDBAD ^TMP($J,"BADADD",$P(^DPT(+DFN,0),"^"),+DFN)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDL1 3092 printed Dec 13, 2024@02:58:12 Page 2
SDL1 ;BSN/GRR,ALB/LDB - PRE-APPOINTMENT LETTERS ; 7/7/04 10:45am
+1 ;;5.3;Scheduling;**106,330,340,407,398**;Aug 13, 1993
+2 ;
+3 ;******************MODIFICATIONS***********************************
+4 ;
+5 ; DATE PATCH DEVELOPER DESCRIPTION
+6 ; ---- ----- --------- -----------
+7 ; 12/12/2003 SD*5.3*330 JOHN LUNDEN FIX FORM FEED LOGIC
+8 ;
+9 ;******************************************************************
+10 ;
+11 USE IO
NEW SDBAD
KILL ^UTILITY($JOB)
SET SDLT1=SDLET
if "Pp"'[S1
GOTO BC
+12 IF $DATA(VAUTN)
Begin DoDot:1
+13 FOR C=0:0
SET C=$ORDER(VAUTN(C))
if 'C
QUIT
SET DFN=C
Begin DoDot:2
+14 DO BAD
if SDBAD
QUIT
DO DATE
End DoDot:2
End DoDot:1
+15 DO LST
QUIT
DATE FOR D=SDBD:0
SET D=$ORDER(^DPT(C,"S",D))
if 'D!(D>(SDED+.9999))
QUIT
IF $DATA(^(D,0))
IF $PIECE(^(0),"^",2)'["C"
IF $SELECT('$DATA(^DPT(C,.35)):1,$PIECE(^(.35),"^",1)']"":1,1:0)
SET A1=C
SET B1=D
SET D1=+^DPT(C,"S",D,0)
DO SET
+1 QUIT
APP FOR J=0:0
SET J=$ORDER(^UTILITY($JOB,L,A,J))
if 'J
QUIT
SET SDX=J
SET SDC=^(J)
SET S=^DPT(+A,"S",J,0)
DO WRAPP^SDLT
+1 DO REST^SDLT
QUIT
BC SET U="^"
IF $DATA(VAUTC)
IF 'VAUTC
DO CL
GOTO LST
ALCL FOR C=0:0
SET C=$ORDER(^SC(C))
if 'C
QUIT
IF '$DATA(SDVAUTC(C))
IF $PIECE(^SC(C,0),U,3)="C"
IF $SELECT('$DATA(^("I")):1,'+^("I"):1,+^("I")<SDBD&('$PIECE(^("I"),U,2)):0,+^("I")<SDBD&($PIECE(^("I"),U,2)>SDED):0,1:1)
DO NCHECK
IF $TEST
DO D
if $DATA(SDD)
DO OVER
LST ;SD*5.3*330. Flag to determine first pag
NEW SDFIRST
SET SDFIRST=1
+1 FOR L=0:0
SET L=$ORDER(^UTILITY($JOB,L))
if 'L
QUIT
Begin DoDot:1
+2 FOR A=0:0
SET A=$ORDER(^UTILITY($JOB,L,A))
if 'A
QUIT
Begin DoDot:2
+3 SET DFN=A
DO BAD
if SDBAD
QUIT
+4 SET SDLET=L
DO ^SDLT
DO APP
End DoDot:2
End DoDot:1
+5 DO NO
DO END
DO CLOSE^DGUTQ
QUIT
CL FOR C=0:0
SET C=$ORDER(VAUTC(C))
if 'C
QUIT
if 'SDLT1
SET SDLET=0
DO OVER
+1 QUIT
OVER if '$DATA(^SC(C,"S"))
QUIT
+1 FOR SDT=SDBD:0
SET SDT=$ORDER(^SC(C,"S",SDT))
if 'SDT!(SDT>(SDED+.9999))
QUIT
Begin DoDot:1
+2 FOR K=0:0
SET K=$ORDER(^SC(C,"S",SDT,1,K))
if 'K
QUIT
Begin DoDot:2
+3 SET DFN=+^(K,0)
+4 IF $PIECE(^(0),"^",9)'["C"
DO BAD
if SDBAD
QUIT
DO CHECK
End DoDot:2
End DoDot:1
+5 QUIT
END WRITE !
KILL %,%H,%I,%Y,%DT,%IS,%ZIS,A,B,C,D,DN,CLIN,CNN,DATE,DATEND,DFN,DIC,DIV,DOW,GDATE,SDHX,I,J,J1,K,L,L0,PDAT,S,S1,SC,SDADD,SDFORM,SDT,SDXX,TIME,X,Y,Z,Z0,Z5
QUIT
CHECK IF $SELECT('$DATA(^DPT(DFN,.35)):1,$PIECE(^(.35),"^",1)']"":1,1:0)
IF $DATA(^DPT(DFN,"S",SDT,0))
IF $PIECE(^(0),"^",2)'["C"
IF '$DATA(^DPT(DFN,.1))
SET A1=DFN
SET B1=SDT
SET D1=C
DO SET
+1 QUIT
SET IF $DATA(^SC(D1,"LTR"))!(SDLT1)
if 'SDLT1
SET SDLET=$PIECE(^SC(D1,"LTR"),"^",2)
IF SDLET
SET ^UTILITY($JOB,SDLET,A1,B1)=D1
if 'SDLT1
SET SDLET=0
KILL A,A1,B1,D1
QUIT
+1 IF 'SDLET
SET ^UTILITY($JOB,"C",A1,D1)=""
KILL A,A1,B1,D1
QUIT
+2 QUIT
NO IF $DATA(VAUTN)
IF '$ORDER(^UTILITY($JOB,0))
IF '$DATA(^UTILITY($JOB,"C"))
Begin DoDot:1
+1 ;W !,"THIS PATIENT(S) HAS THE BAD ADDRESS INDICATOR SET AND PRE-APPOINTMENT LETTER(S) WILL NOT PRINT." Q
IF SDBAD
QUIT
+2 WRITE !,"NO ACTIVE APPOINTMENTS FOR THE PATIENT(S) DURING THAT TIME PERIOD!",*7
End DoDot:1
+3 IF $DATA(^UTILITY($JOB,"C"))
WRITE @IOF
FOR X=0:0
SET X=$ORDER(^UTILITY($JOB,"C",X))
if 'X
QUIT
WRITE !!,$PIECE(^DPT(X,0),"^")," ",$PIECE(^(0),"^",9)," HAS FUTURE APPTS., but"
DO NOCL
+4 IF $DATA(^TMP($JOB,"BADADD"))
DO BADADD^SDLT
KILL ^TMP($JOB,"BADADD")
+5 QUIT
NOCL FOR XX=0:0
SET XX=$ORDER(^UTILITY($JOB,"C",X,XX))
if 'XX
QUIT
WRITE !,$PIECE(^SC(XX,0),"^")," Clinic is not assigned a PRE-APPOINTMENT LETTER"
+1 QUIT
D KILL SDD
IF ($PIECE(^SC(C,0),"^",15)=SDV1)!(SDV1=$ORDER(^DG(40.8,0))&($PIECE(^SC(C,0),"^",15)=""))
SET SDD=1
+1 QUIT
NCHECK ;
+1 NEW NOC
SET NOC=$PIECE($GET(^SC(C,0)),U,17)
+2 IF SDCONC="B"
QUIT
+3 IF SDCONC="C"&(NOC="N")
QUIT
+4 IF SDCONC="N"&(NOC="Y")
QUIT
+5 QUIT
BAD SET SDBAD=$$BADADR^DGUTL3(+DFN)
+1 if SDBAD
SET ^TMP($JOB,"BADADD",$PIECE(^DPT(+DFN,0),"^"),+DFN)=""
+2 QUIT
