source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDCNP1A.m@ 1255

Last change on this file since 1255 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.0 KB
RevLine 
[613]1SDCNP1A ;ALB/LDB - CANCEL APPT. (continued) ; 5/26/05 10:59am
2 ;;5.3;Scheduling;**167,340,398,478,517**;Aug 13, 1993;Build 4
3LOOP S SDCNT1=0 F SDAP=0:0 S SDAP=$O(^UTILITY($J,"SDCNP2","REBK",DFN,SDAP)) Q:SDAP'>0 S SDP1=^(SDAP),S1=$P(SDP1,"^",2),S9=$P(^SC(S1,0),"^") D SDDT Q:X8="^" D RBK S MAX=1
4 Q
5SDDT W !!,"IN ",S9 D:'$D(DT) DT^SDUTL D DT S %DT="AEX",%DT("A")="START REBOOKING FROM WHAT DATE: "_D S %DT(0)=DT D ^%DT K %DT S X8=X Q:$D(DTOUT)!(X="^") S:X8="" Y=DT G:Y<0 SDDT S SDDT=+Y\1 K X,Y,DIC S X1=SDDT,X2=DT D ^%DTC
6 S (M8,MAX)=0,S1=$P(SDP1,"^",2),S2=$P(SDP1,"^"),M1=$S($D(^SC(S1,"SDP")):$P(^("SDP"),"^",4),1:0) D MAX G:M8 SDDT
7 I S2>DT S X1=SDDT,X2=1 D C^%DTC S SDDT=X
8 Q
9MAX I X>M1 S M8=1 W !!,"Exceeds maximum number of days for rebooking in ",S9 S MAX=0
10 Q
11RBK S GDATE=S2,SC=S1,LEN=$P(SDP1,"^",6),A=DFN_"^"_LEN,(CDATE,DATE)=SDDT D OVR1,SDIN D ^SDAUT1 D:'MAX NRBK D:MAX ^SDAUT2,SDNP K SDIN Q
12OVR1 N X S SL=$S($D(^SC(SC,"SL")):^("SL"),1:"") Q:'SL S X=$P(SL,U,6),SI=$S(X="":4,X<3:4,X:X,1:4),X=$P(SL,U,3),STARTDAY=$S($L(X):X,1:8),SDSTRTDT=$S(DT>DATE:DT,1:DATE),STIME=$S($D(^SC(SC,"SDP")):$P(^("SDP"),U,3),1:"0800"),SDSTRTDT=SDSTRTDT+2
13 Q
14SDIN I $D(^SC(SC,"I")) S SDIN=+^("I") Q
15 Q
16SDNP S SDCL(SDAP)=SC_"^"_GDATE_"^"_NDATE S:NDATE SDCNT1=SDCNT1+1 Q
17NRBK W !,"NO REBOOKING ALLOWED FOR ",$P(^SC(SC,0),"^") Q
18DT S X1=$P(DT,"."),X2=10 D C^%DTC S Y=X D D^DIQ S D=Y_"//" Q
19PROT S SDPRT=0 I $D(^SC(+I,"SDPROT")),$P(^("SDPROT"),U)="Y",'$D(^SC(+I,"SDPRIV",DUZ)) W !,*7,"Appt. in ",$P(^SC(+I,0),"^")," NOT CANCELLED ",!,"Access to this clinic is restricted to only privileged users!",*7 S SDPRT=1 Q
20 Q
21 ;SD/517 added new IF statement, changed For loop & added 2 new linetags
22FLEN S (ZPL,SDSP)="" ;SD/517
23 S COV=$S($P(^DPT(DFN,"S",NDT,0),"^",11)=1:" (COLLATERAL) ",1:"") I $D(^SC(SC,"S",NDT)) S ZL=0 F S ZL=$O(^SC(SC,"S",NDT,1,ZL)) Q:'ZL D
24 .I '$D(^SC(SC,"S",NDT,1,ZL,0)) D FLEN1 Q
25 .I +^SC(SC,"S",NDT,1,ZL,0)=DFN S APL=$P(^(0),U,2),SDSP=$P($G(^SC(SC,"S",NDT,1,ZL,"CONS")),U)
26 .Q
27 ;S COV=$S($P(^DPT(DFN,"S",NDT,0),"^",11)=1:" (COLLATERAL) ",1:"") I $D(^SC(SC,"S",NDT)) F ZL=0:0 S ZL=$O(^SC(SC,"S",NDT,1,ZL)) Q:ZL'>0 I +^(ZL,0)=DFN S APL=$P(^(0),"^",2),SDSP=$P($G(^SC(SC,"S",NDT,1,ZL,"CONS")),U) Q ;SD/478
28 Q
29 ;
30 ;SD/517 added new linetag to kill any lingering "C" nodes
31FLEN1 Q:'$D(^SC(SC,"S",NDT,1,ZL,"C"))
32 S DA(2)=SC,DA(1)=NDT,DA=ZL,DIK="^SC("_DA(2)_",""S"","_DA(1)_",1," D ^DIK
33 Q
34 ;
35LOOP1 S SDCNT1=0 F L=0:0 S L=$O(^UTILITY($J,"SDCNP",L)) Q:L'>0 I ^(L)["JUST CANCELLED" S $P(SDCL(L),"^")=$P(^(L),"^",2),$P(SDCL(L),"^",2)=$P(^(L),"^")
36 K ^UTILITY($J) Q
37SDLET N NDT,GDT
38 U IO D Q
39 F SDP=0:0 S SDP=$O(SDCL(SDP)) Q:SDP'>0 D
40 . S SDP1=SDCL(SDP),SDC=+SDP1,GDT=$P(SDP1,"^",2),NDT=$P(SDP1,"^",3),SDV1=$P(^SC(SDC,0),"^",15)
41 . D B I (SDB)!(SDK) Q
42 . S:'SDV1 SDV1=+$O(^DG(40.8,0))
43 . D F S:SDLET ^UTILITY($J,SDLET,+A,GDT)=SDC_"^"_NDT
44 F SDLET=0:0 S SDLET=$O(^UTILITY($J,SDLET)) Q:SDLET'>0 F B0=0:0 S A1=B0,B0=$O(^UTILITY($J,SDLET,B0)) D:'B0 R Q:'B0 D:A1&(A1'=B0) R S A=B0 D ^SDLT,APP
45 I $D(^UTILITY($J,"NO")) W @IOF,! F SC=0:0 S SC=$O(^UTILITY($J,"NO",SC)) Q:SC'>0 W !,$P(^SC(SC,0),"^")," Clinic is not assigned a letter",!!
46E I $D(^TMP($J,"BADADD")) D BADADD^SDLT K ^TMP($J,"BADADD") I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K ^DIR(0)
47 ;I $G(SDB),SDB W !!,"BAD ADDRESS INDICATOR FOR THIS PATIENT. NO LETTER WILL BE PRINTED." S DIR(0)="E" D ^DIR K DIR(0)
48 I $G(SDK),'SDK W !!,"NO LETTER CAN BE PRINTED FOR THIS PATIENT." S DIR(0)="E" D ^DIR K DIR(0)
49 K A,SDCL D CLOSE^DGUTQ
50Q K A1,SDFORM,SDLET,SDNDT,SDP1,SDV1,^UTILITY($J),SDB,SDK Q
51F S SDFORM="" I $D(^DG(40.8,SDV1,"LTR")),^("LTR") S SDFORM=^("LTR")
52 S SDLET="" I $D(^SC(SDC,"LTR")) S:SDWH["P" SDLET=$P(^("LTR"),"^",4) S:SDWH'["P" SDLET=$P(^("LTR"),"^",3)
53 I 'SDLET S ^UTILITY($J,"NO",SDC)=""
54 Q
55R I $D(^UTILITY($J,"R",SDLET,A1)) W !!,"The appointment(s) have been rescheduled as follows:",! F A2=0:0 S A2=$O(^UTILITY($J,"R",SDLET,A1,A2)) Q:A2'>0 S (X,SDX)=A2,SDC=+^(A2),A=A1,SDS=^DPT(DFN,"S",SDX,0) D WRAPP^SDLT K X,SDX
56 D REST^SDLT Q
57APP F SDX=0:0 S SDX=$O(^UTILITY($J,SDLET,A,SDX)) Q:SDX'>0 S S=^DPT(+A,"S",SDX,0),SDC=+^(0) D WRAPP^SDLT I $P(^UTILITY($J,SDLET,A,SDX),"^",2) S ^UTILITY($J,"R",SDLET,A,$P(^UTILITY($J,SDLET,A,SDX),"^",2))=$P(^(SDX),"^")
58 Q
59CKK I $L(SDDI)>4!($L(SDDM)>4) S SDERR=1 W !,"There is no appointment number ",$S($L(SDDI)>5:SDDI,1:SDDM) Q
60 Q
61CKK1 F Z0=SDDI,SDDM Q:'SDDI!('SDDM&(SDDI-Z0)) S SDERR=0 S:$L(Z0)>5 SDERR=1 Q:SDERR S:$L(SDDI)<5 SDDI=+SDDI S:$L(SDDM)<5 SDDM=+SDDM I $L(Z0)>5!('$D(^UTILITY($J,"SDCNP",Z0,"CNT"))) S SDERR=1 Q
62 W:SDERR !,*7,"There is no appointment number ",Z0 H 2 Q
63CKK2 F Z0=SDDI,SDDM Q:'SDDI!('SDDM&(SDDI-Z0)) S SDERR=0 S:$L(Z0)>5 SDERR=1 Q:SDERR S:$L(SDDI)<5 SDDI=+SDDI S:$L(SDDM)<5 SDDM=+SDDM I $L(Z0)>5!('$D(^UTILITY($J,"SDCNP2",DFN,Z0))) S SDERR=1 Q
64 W:SDERR !,*7,"There is no appointment number ",Z0 Q
65B S SDB=$$BADADR^DGUTL3(+A)
66 S:SDB ^TMP($J,"BADADD",$P(^DPT(+A,0),"^"),+A)=""
67CHECK S SDK=0 I $S('$D(^DPT(+A,.35)):1,$P(^(.35),"^",1)']"":1,1:0),$D(^DPT(+A,"S",GDT,0)),$S($P(^(0),"^",2)["N":1,$D(SDCP)&$P(^(0),"^",2)["C":1,1:0),$P(^(0),"^",14)=SDTIME!(SDTIME="*"),'$D(^DPT(+A,.1)) S SDK=1
68 Q
Note: See TracBrowser for help on using the repository browser.