source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDM2.m@ 677

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

initial load of FOIAVistA 6/30/08 version

File size: 4.9 KB
Line 
1SDM2 ;SF/GFT - MAKE APPOINTMENT ; 07 Jan 2000 6:30 PM
2 ;;5.3;Scheduling;**32,132,168,356,434,467,478**;Aug 13, 1993
3 ;
4 ;SD/467 - call EWL to open its entry if matching appointment is canceled
5 W *7,!,"PATIENT ALREADY HAS APPOINTMENT "
6 N SDATA,SDCMHDL ; for evt dvr
7 I $D(^DPT(DFN,"S",SD,0)),$P(^(0),"^",2)'["C" S S=SD,I=+^(0) D FLEN W "(",APL," MINUTES) THEN" D IN,PROT G:$D(SDPROT) ^SDM1 R ".",!," DO YOU WANT TO CANCEL IT? ",X:DTIME S X=$$UP^XLFSTR(X) D:X?1"Y".A STAT G CAN:X?1"Y".A W "??",*7 G ^SDM1
8SDAY S %=1 W "ON THE SAME DAY (" D AT,IN W ") ...OK" D YN^DICN I '% W !,"RESPOND YES OR NO",!,"PATIENT ALREADY HAS APPOINTMENT " G SDAY
9 G ^SDM1:(%-1),PRECAN^SDM1
10 ;
11CAN Q:'$D(^SC(I,"SL")) S SCI=I,DIV=$S($P(^SC(I,0),"^",15)]"":" "_$P(^(0),"^",15),1:" 1") I $D(^DPT("ASDPSD","C",DIV,I,S,DFN)) K ^(DFN)
12 S SD17=$P(^DPT(DFN,"S",S,0),"^") K ^SC("ARAD",I,S,DFN) S (DA,SDSY)=0 F SDSX=0:0 S SDSX=$O(^SC(I,"S",S,1,SDSX)) Q:'SDSX Q:'$D(^(SDSX,0)) D C Q:SDSY&(DA)
13 I $D(^DPT("ASDPSD","B",DIV,$P(S,"."),DFN)) D CK1
14 G OUT:'SDSY S SL1=$P(^SC(I,"S",S,1,SDSY,0),U,2) I DA,'$D(^("OB")) K ^SC(I,"S",S,1,DA,"OB")
15 S SDRT="D",SDTTM=SD,SDPL=SDSY,SDSC=I D RT^SDUTL
16 I I'=SC D
17 .W !
18 .I $$BADADR^DGUTL3(DFN)>0 D Q
19 ..W !!,"**BAD ADDRESS INDICATOR FOR THIS PATIENT. NO LETTER WILL BE PRINTED.**",!!
20 .S DIR("A")="DO YOU WISH TO PRINT LETTERS FOR THE CANCELLED APPOINTMENT"
21 .S DIR("A",1)="THIS IS THE ONLY OPPORTUNITY.",DIR("B")="YES"
22 .S DIR(0)="Y" D ^DIR W ! K DIR
23 .Q:(Y'=1)
24 .N SDWH,A,SC,SDCL S SDWH="P",A=+DFN,SDCL(1)=I_"^"_S N DFN
25 .S %ZIS("A")="Device for cancellation letter: ",%ZIS("B")=""
26 .N I,S,SDHX,SDP
27 .D ^%ZIS Q:POP U IO
28 .D SDLET^SDCNP1A
29 .D ^%ZISC
30 N SCSNOD,SCLNK,SCSRV,SCGMR,SCSTPCOD
31 S SCSNOD=^SC(I,"S",S,1,SDSY,0),SCLNK=$P($G(^SC(I,"S",S,1,SDSY,"CONS")),U),SDADM="" S:'$D(STPCOD) STPCOD=$P($G(^SC(I,0)),U,7) K TMPD ;SD/478
32 I SCLNK'="" K ^SC("AWAS1",SCLNK) S SCSRV=$P($G(^GMR(123,SCLNK,0)),U,5),SCGMR=0 F S SCGMR=$O(^GMR(123.5,SCSRV,688,SCGMR)) Q:'+SCGMR S SCSTPCOD=$P(^GMR(123.5,SCSRV,688,SCGMR,0),U) I STPCOD=SCSTPCOD D
33 .S TMP=1 S:'$D(CNSLTLNK) CNSLTLNK=SCLNK Q ;SD/478
34 K ^SC(I,"S",S,1,SDSY)
35 I '$D(^SC(I,"ST",$P(SD,"."),1)) G OUT
36 S SD1(1)=^SC(I,"SL"),SD1=$P(SD1(1),"^",3),SB1=$S(SD1:SD1,1:8)-1/100,SD1=$P(SD1(1),"^",6),HSI1=$S(SD1:SD1,1:4),SI1=$S(SD1="":4,SD1<3:4,SD1:SD1,1:4),SDDIF1=$S(HSI1<3:8/HSI1,1:2) K SD1
37 S S=^SC(I,"ST",$P(SD,"."),1),SDQ=SD#1-SB1*100,ST=SDQ#1*SI1\.6+($P(SDQ,".")*SI1),SS=SL1*HSI1/60
38 I SDQ'<1 F I=ST+ST:SDDIF1 S SDQ=$E(STR,$F(STR,$E(S,I+1))) Q:SDQ="" S S=$E(S,1,I)_SDQ_$E(S,I+2,999),SS=SS-1 Q:SS'>0
39 S ^(1)=S K SL1,SB1,SDDIF1,HSI1,SI1,SDQ ;NAKED REFERENCE - ^SC(IFN,"ST",Date,1)
40OUT D EVT Q:$D(SDNSF) D CANCEL^SDCNSLT W *7,!,"APPOINTMENT IN ",$P(^SC(SCI,0),"^",1)," CANCELLED!" S X=SD D DOW^SDM1 W !,"APPOINTMENT NOW BEING MADE IN ",$P(^SC(SC,0),"^",1) K SCI G S^SDM1 ;SD/478
41 ;
42C I +^SC(I,"S",S,1,SDSX,0)=DFN,$P(^(0),"^",9)'["C" S SDSY=SDSX Q
43 Q:'$D(^("OB"))!DA S:^("OB")?1"O".E DA=SDSX Q ;NAKED REFERENCE - ^SC(IFN,"S",Date,1,SDSX,"OB")
44 ;
45AT W "AT ",$E(S_0,9,10),":",$E(S_"000",11,12) Q
46IN W:SC-I&$D(^SC(I,0)) " IN ",$P(^(0),U,1) Q
47PROT K SDPROT
48 I $D(^SC(I,"SDPROT")),$P(^("SDPROT"),U)="Y",'$D(^SC(I,"SDPRIV",DUZ)) D Q
49 .W !!,*7,">>> Access to ",$$CNAM(I)," is prohibited!"
50 .W !," Only users with a special code may access this clinic.",!
51 .S SDPROT=""
52 ;
53 I $$CODT^SDCOU(DFN,SD,I) D Q
54 .W !?5,*7,">>> A check out date has been entered for this appointment!"
55 .W !?5," Please enter another date and time. Thank you.",!
56 .S SDPROT=""
57 Q
58 ;
59CNAM(SDCL) ;Return clinic name
60 ;Input: SDCL=clinic ien
61 N SDX
62 S SDX=$P($G(^SC(+SDCL,0)),U)
63 Q $S($L(SDX):SDX,1:"this clinic")
64 ;
65FLEN S APL="" I $D(^SC(I,"S",SD)) F ZL=0:0 S ZL=$O(^SC(I,"S",SD,1,ZL)) Q:ZL="" I +^(ZL,0)=DFN S APL=$P(^SC(I,"S",SD,1,ZL,0),"^",2)
66 Q
67 ;
68DISP G ^SDM1 ; LINE TAG IS NO LONGER USED
69 ;W !?4 K S F SDQ=Y:0 S SDQ=$N(^SC(SC,"S",SDQ)) Q:Y+1<SDQ!(SDQ<0) F I=0:0 S I=$N(^SC(SC,"S",SDQ,1,I)) Q:I'>0 Q:'$D(^(I,0)) S ST=$S($P(^(0),U,4)="":"BLANK",1:"'"_$E($P(^(0),U,4),1,28)_"'"),S(ST)=$S($D(S(ST)):S(ST)+1,1:1)
70 ;I '$D(S) W "NO APPNT'S SCHEDULED YET" G ^SDM1
71 ;W "'OTHER' TYPES ALREADY SCHEDULED: ",!
72 ;S S=0 F I=0:1 S S=$N(S(S)) G ^SDM1:S=-1 W:$X+$L(S)>72 ! W S,": ",S(S)," "
73CK1 S SDZ=0 F SD1=$P(S,"."):0 S SD1=$O(^DPT(DFN,"S",SD1)) Q:'SD1!((SD1\1)'=(S\1)) I $P(^(SD1,0),"^",2)'["C",$P(^(0),"^",2)'["N" S SDZ=1 Q
74 Q:SDZ F SD1=2,4 I $D(^SC("AAS",SD1,$P(S,"."),DFN)) S SDZ=1 Q
75 Q:SDZ IF $D(^SCE(+$$EXAE^SDOE(DFN,S\1,S\1),0)) S SDX=1
76 Q:SDZ K ^DPT("ASDPSD","B",DIV,$P(S,"."),DFN) Q
77STAT N X S SDCMHDL=$$HANDLE^SDAMEVT(1) D BEFORE^SDAMEVT(.SDATA,DFN,SD,I,"",SDCMHDL),NOW^%DTC
78 S $P(^DPT(DFN,"S",SD,0),"^",2)="C",$P(^(0),"^",14)=$E(%,1,12) S:$D(DUZ) $P(^(0),"^",12)=DUZ S ^DPT("ASDCN",+^(0),SD,DFN)=""
79 K ^TMP("SDWLREB",$J),^TMP($J,"SDWLPL") N SC S SC=+^DPT(DFN,"S",SD,0) D OPENEWL^SDWLREB(DFN,SD,SC,0) K ^TMP($J,"SDWLP")
80 I $D(^TMP("SDWLREB",$J)) D MESS^SDWLREB ; SD/467
81 Q
82 ;
83EVT ; -- separate tag if need to NEW vars
84 ; -- cancel event
85 D CANCEL^SDAMEVT(.SDATA,DFN,SDTTM,SDSC,SDPL,0,SDCMHDL)
86 Q
Note: See TracBrowser for help on using the repository browser.