DGRP14 ;ALB/MRL/EG/GAH - REGISTRATION SCREEN 14/APPOINTMENT INFORMATION ; 10/18/06
;;5.3;Registration;**568,585,725,770**;Aug 13, 1993;Build 4
S DGRPS=14 D H^DGRPU S (Z,DGRPW)=1 D WW^DGRPV W " Enrollment Clinics: "
S I1=""
F I=0:0 S I=$O(^DPT(DFN,"DE",I)) Q:'I D:$P(^(I,0),U,2)'="I"
. S I1=1,X=$S($D(^SC(+^(0),0)):$P(^(0),U,1)_", ",1:"")
. W:(79-$X)<$L(X) !?24 W X
W:'I1 "NOT ACTIVELY ENROLLED IN ANY CLINICS AT THIS TIME"
W ! S Z=2 D WW^DGRPV W " Pending Appt's",?18,": " S I1="",I2=DT_".9999"
N DGARRAY,APTDT,CLIFN,CLNAM
S DGARRAY("FLDS")="1;2;3",DGARRAY(3)="R;I;NT",DGARRAY(4)=DFN,DGARRAY(1)=DT,DGARRAY("SORT")="P"
S I1=$$SDAPI^SDAMA301(.DGARRAY)
;Check for appointment retrieval error.
I I1<0 W $$FAPCHK^DGENRPD2 G Q
S APTDT=0
F S APTDT=$O(^TMP($J,"SDAMA301",DFN,APTDT)) Q:'APTDT D
.;check to see if appointment is cancelled, if so
.;ignore this appointment eg 01/25/2005
.;I $$CANCEL(DFN,APTDT)="Y" Q TAKEN OUT IN PATCH 770.
.S CLNAM=$P($P(^TMP($J,"SDAMA301",DFN,APTDT),U,2),";",2)
.S X=$S(CLNAM]"":CLNAM,1:"UNKNOWN CLINIC")_" ("_$$FMTE^DILIBF(APTDT,"5U")_"), " W:(79-$X)<$L(X) !?24 W X
.Q
I 'I1 W "NO PENDING APPOINTMENTS ON FILE"
Q K I,I1,I2,X,Y,DGARRAY,APTDT,CLNAM,^TMP($J,"SDAMA301") G ^DGRPP
;
;input DFN - patient id
; APPDATE - appointment date
;return Y - Yes
; N - No
CANCEL(DFN,APPDATE) ;
N X,STATUS,U
S U="^"
S X=$G(^DPT(DFN,"S",APPDATE,0))
I X="" Q "Y" ;probably bad data
S STATUS=$P(X,U,2)
I STATUS="" Q "N"
I STATUS="I" Q "N"
Q "Y"
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRP14 1543 printed Apr 09, 2024@21:45:44 Page 2
DGRP14 ;ALB/MRL/EG/GAH - REGISTRATION SCREEN 14/APPOINTMENT INFORMATION ; 10/18/06
+1 ;;5.3;Registration;**568,585,725,770**;Aug 13, 1993;Build 4
+2 SET DGRPS=14
DO H^DGRPU
SET (Z,DGRPW)=1
DO WW^DGRPV
WRITE " Enrollment Clinics: "
+3 SET I1=""
+4 FOR I=0:0
SET I=$ORDER(^DPT(DFN,"DE",I))
if 'I
QUIT
if $PIECE(^(I,0),U,2)'="I"
Begin DoDot:1
+5 SET I1=1
SET X=$SELECT($DATA(^SC(+^(0),0)):$PIECE(^(0),U,1)_", ",1:"")
+6 if (79-$X)<$LENGTH(X)
WRITE !?24
WRITE X
End DoDot:1
+7 if 'I1
WRITE "NOT ACTIVELY ENROLLED IN ANY CLINICS AT THIS TIME"
+8 WRITE !
SET Z=2
DO WW^DGRPV
WRITE " Pending Appt's",?18,": "
SET I1=""
SET I2=DT_".9999"
+9 NEW DGARRAY,APTDT,CLIFN,CLNAM
+10 SET DGARRAY("FLDS")="1;2;3"
SET DGARRAY(3)="R;I;NT"
SET DGARRAY(4)=DFN
SET DGARRAY(1)=DT
SET DGARRAY("SORT")="P"
+11 SET I1=$$SDAPI^SDAMA301(.DGARRAY)
+12 ;Check for appointment retrieval error.
+13 IF I1<0
WRITE $$FAPCHK^DGENRPD2
GOTO Q
+14 SET APTDT=0
+15 FOR
SET APTDT=$ORDER(^TMP($JOB,"SDAMA301",DFN,APTDT))
if 'APTDT
QUIT
Begin DoDot:1
+16 ;check to see if appointment is cancelled, if so
+17 ;ignore this appointment eg 01/25/2005
+18 ;I $$CANCEL(DFN,APTDT)="Y" Q TAKEN OUT IN PATCH 770.
+19 SET CLNAM=$PIECE($PIECE(^TMP($JOB,"SDAMA301",DFN,APTDT),U,2),";",2)
+20 SET X=$SELECT(CLNAM]"":CLNAM,1:"UNKNOWN CLINIC")_" ("_$$FMTE^DILIBF(APTDT,"5U")_"), "
if (79-$X)<$LENGTH(X)
WRITE !?24
WRITE X
+21 QUIT
End DoDot:1
+22 IF 'I1
WRITE "NO PENDING APPOINTMENTS ON FILE"
Q KILL I,I1,I2,X,Y,DGARRAY,APTDT,CLNAM,^TMP($JOB,"SDAMA301")
GOTO ^DGRPP
+1 ;
+2 ;input DFN - patient id
+3 ; APPDATE - appointment date
+4 ;return Y - Yes
+5 ; N - No
CANCEL(DFN,APPDATE) ;
+1 NEW X,STATUS,U
+2 SET U="^"
+3 SET X=$GET(^DPT(DFN,"S",APPDATE,0))
+4 ;probably bad data
IF X=""
QUIT "Y"
+5 SET STATUS=$PIECE(X,U,2)
+6 IF STATUS=""
QUIT "N"
+7 IF STATUS="I"
QUIT "N"
+8 QUIT "Y"
