- 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 Feb 19, 2025@00:24:42 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