source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDCNSLT.m@ 1487

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

initial load of FOIAVistA 6/30/08 version
File size: 6.7 KB
Line 
1SDCNSLT ;ALB/HAG-LINK APPOINTMENTS TO CONSULTS; 4/12/05 3:44pm ; Compiled February 5, 2007 14:09:59
2 ;;5.3;Scheduling;**478,496**;Aug 13, 1993;Build 11
3A ;===GET ACTIVE AND PENDING CONSULT
4 N A,ND,CNT,CONS,CPRSTAT,DTENTR,DTIN,DTLMT,DTR,NOS,NOSHOW,SENDER,SERVICE,SRV,P8,PROC,PT,PTNM,STATUS
5 K TMP S NOSHOW="no-show",CNT=0,$P(DSH,"-",IOM-1)="",PT=DFN,X1=DT,X2=-365 D C^%DTC S DTLMT=X
6 S A=":" F S A=$O(^GMR(123,"F",PT,A),-1) Q:'+A S ND=$G(^GMR(123,A,0)) Q:ND="" S PROC=$P($G(^GMR(123,A,1.11)),U),DTENTR=$P(ND,U) I DTENTR>DTLMT S CPRSTAT=$P(ND,U,12) D:CPRSTAT=5!(CPRSTAT=6)!(CPRSTAT=8)!(CPRSTAT=13)
7 .I STPCOD'="" S SRV=$P(ND,U,5) Q:'+SRV I $D(^GMR(123.5,"AB1",STPCOD,SRV)) S PTIEN=$P(ND,U,2) D
8 ..I CPRSTAT=8 S SHOW=0 Q:$D(^SC("AWAS1",A)) S NOS=$O(^GMR(123,A,40,":"),-1) Q:'+NOS S X2=$P($G(^GMR(123,A,40,NOS,0)),U),X1=DT D ^%DTC Q:X'=""&(X>180) D SCHED(PTIEN,STPCOD,.SHOW) Q:'SHOW
9 ..;CPRSTAT 13 is a cancel
10 ..I CPRSTAT=13 S NOS=$O(^GMR(123,A,40,":"),-1) Q:'+NOS S NOS=$O(^GMR(123,A,40,NOS),-1) Q:'+NOS S X2=$P($G(^GMR(123,A,40,NOS,0)),U),X1=DT D ^%DTC Q:X'=""&(X>180) S COMMENT=$G(^GMR(123,A,40,NOS,1,1,0)) Q:COMMENT'[NOSHOW
11 ..S:+PTIEN PTNM=$P(^DPT(PTIEN,0),U) S SERVICE=$P(^GMR(123.5,SRV,0),U),STATUS=$P(^ORD(100.01,CPRSTAT,0),U),SENDER=$P(ND,U,14) S:+SENDER SENDER=$P(^VA(200,SENDER,0),U)
12 ..S Y=DTENTR D DD^%DT S DTIN=Y,DTR=$E(DTENTR,4,5)_"/"_$E(DTENTR,6,7)_"/"_$E(DTENTR,2,3)_"@"_$P(Y,"@",2)
13 ..S CNT=CNT+1,TMP(CNT)=PTIEN_U_SERVICE_U_SENDER_U_STATUS_U_DTR_U_A_U_DTIN_U_$P(ND,U,17)_U_PROC
14 Q:'$D(TMP)
15QST N DIR,DTOUT,DUOUT,CNSULT
16 S DIR(0)="Y",DIR("A")="Will this appointment be for a CONSULT/PROCEDURE",DIR("B")="YES",DIR("?")="Answer 'Y'es if appointment is for a Consult or Procedure." W ! D ^DIR S CNSULT=Y
17 I CNSULT[U!(CNSULT=0)!(CNSULT="") K TMP Q
18HDR W !!,"Please select from the list of consult(s), press 0 for none.",!
19 W !,PTNM,!!,"# Service",?27,"Sending Provider",?45,"Request Date",?60,"Cons #",?68,"Reqst Type",!,DSH
20 S A=0 F S A=$O(TMP(A)) Q:'+A S ND=TMP(A),P8=$P(ND,U,8) W !,A,". ",$S(P8="P":$E($P(ND,U,9),1,23),1:$E($P(ND,U,2),1,23)),?27,$E($P(ND,U,3),1,17),?45,$E($P(ND,U,5),1,14)," ",$P(ND,U,6) W ?68,$S(P8="P":"Procedure",P8="C":"Consult",1:"")
21 W !
22READ R !,"Select Consult: ",CONS:DTIME G:CONS="" A
23 I CONS=0!(CONS[U) W " ... NONE." K TMP Q
24 I "? "[CONS W !," Select consult by number on the left side." G READ
25 I '$D(TMP(CONS)) W *7," ?? Select consult by number on the left side." G READ
26 S CNSLTLNK=$P(TMP(CONS),U,6)
27 Q
28SCHED(PTIEN,STPCOD,SHOW) ;===CONSULT IS SCHEDULE NOW CHECK IF IT HAS APPOINTMENT BY STOP CODE.
29 N APT,CLNC,B,S1,S2,S3,S4,STOP,STOPCOD,X,Y
30 S %DT="ST",X="T-1" D ^%DT S APT=Y,S1=0,STOP=0 F S APT=$O(^DPT(PTIEN,"S",APT)) Q:'+APT!(STOP) S S1=1,CLNC=$P(^DPT(PTIEN,"S",APT,0),U) I CLNC'="" S STOPCOD=$P(^SC(CLNC,0),U,7) I STOPCOD'="" S S2=0 I STOPCOD=STPCOD S S2=1 D
31 .S S3=0,S4=0,B=0 F S B=$O(^SC(CLNC,"S",APT,1,B)) Q:'+B!(STOP) S S3=1 D
32 ..I ($P($G(^SC(CLNC,"S",APT,1,B,0)),U)=PTIEN) S S4=1,STOP=1,SHOW=0
33 I S1=0 S SHOW=1 Q ;show if no appointment in the patient side
34 I S2=0 S SHOW=1 Q ;show if stop code does not match
35 I S3=0 S SHOW=1 Q ;show if no appointment in the clinic
36 I S4=0 S SHOW=1 Q ;show if patient does not match in appointment
37 Q
38LINK(SC,SDY,SD,CNSLTLNK) ;===LINK APPOINTMENT TO CONSULT
39 N DA,DIE,DR,TDA,X
40 S TDA=SDY,DA(2)=SC,DA(1)=SD,DA=TDA,DIE="^SC("_DA(2)_",""S"","_DA(1)_",1,",DR="688////^S X=CNSLTLNK" D ^DIE
41 Q
42EDITCS(SD,TMPD,TMPYCLNC,CNSLTLNK) ;===MARK CONSULT AS SCHEDULED
43 N CSCHDT,SNDPRV,TME,X,Y,COMMENT,ER
44 S %DT="ST",X="NOW" D ^%DT S CSCHDT=Y
45 S SNDPRV=$P($G(^GMR(123,CNSLTLNK,0)),U,14),Y=SD D DD^%DT S TME=$P($P(Y,"@",2),":",1,2)
46 S COMMENT(1)=$P(TMPYCLNC,U,2)_" Consult Appt. on "_$E(SD,4,5)_"/"_$E(SD,6,7)_"/"_$E(SD,2,3)_" @ "_TME
47 S COMMENT(2)=TMPD
48 D SCH^SDQQCN2(.ER,CNSLTLNK,SNDPRV,CSCHDT,0,,.COMMENT) K COMMENT
49 Q
50CANCEL ;===appt was cancelled then mark consult as edit/resubmit, add comment.
51 N APPT,CONSULT,CPRSSTAT,ER,GM40,GMRND,SDPATNT,USER,SNDPRV,J
52 ;Variables CNDIE, CNDA and CNINDX used in calling routine for Cancel letter printed comment in consult.
53 S:$D(SCLNK) CONSULT=SCLNK
54 S:'$D(SCLNK) CONSULT=$P($G(^SC(SDSC,"S",SDTTM,1,SDPL,"CONS")),U)
55 Q:'+CONSULT
56 S:$D(SCSNOD) SDPATNT=$P(SCSNOD,U)
57 S:'$D(SCSNOD) SDPATNT=$P($G(^SC(SDSC,"S",SDTTM,1,SDPL,0)),U)
58 S CPRSSTAT=$P($G(^GMR(123,CONSULT,0)),U,12) I CPRSSTAT'="" S CPRSSTAT=$P($G(^ORD(100.01,CPRSSTAT,0)),U) Q:CPRSSTAT'="SCHEDULED"
59 S SNDPRV=$P($G(^GMR(123,CONSULT,0)),U,14)
60 S USER=$P(^VA(200,DUZ,0),U),Y=SDTTM D DD^%DT S APPT=$E(SDTTM,4,5)_"/"_$E(SDTTM,6,7)_"/"_$E(SDTTM,2,3)_" @ "_$P(Y,"@",2)
61 S COMMENT(1)=$P(^SC(SDSC,0),U)_" Appt. on "_APPT_" was cancelled"_$S($D(SDWH):$S(SDWH["P":" by the Patient.",SDWH["C":" by the Clinic.",1:"."),$D(SDADM):" for administrative purposes.",1:", whole clinic.")
62 S CNINDX=2 S:$D(TMPD) COMMENT(2)="Remarks: "_TMPD,CNINDX=CNINDX+1 K TMPD
63 N SDERR S SDERR=$$STATUS^GMRCGUIS(CONSULT,6,3,SNDPRV,"","",.COMMENT)
64 S CNDIE="^GMR(123,"_CONSULT_",40,",CNDA=+$G(COMMENT(0))
65 K COMMENT,DA
66 S AUTO(SDSC,SDTTM,SDPATNT)=CONSULT
67 S DA(2)=SDSC,DA(1)=SDTTM,DA=SDPL,DIE="^SC("_DA(2)_",""S"","_DA(1)_",1,",DR="688///@" D ^DIE
68 K SCSNOD,SDADM,SCLNK
69 Q
70AUTOREB(SC,NDATE,LNK,CY) ;===AUTO REBOOK
71 N DIC,DA,DIE,DR,Y,TME,SNDPRV,CSCHDT,COMMENT,ER
72 S DA(2)=SC,DA(1)=NDATE,DA=CY,DIE="^SC("_DA(2)_",""S"","_DA(1)_",1,",DR="688////^S X=LNK" D ^DIE
73 S Y=NDATE D DD^%DT S TME=$P(Y,"@",2)
74 S COMMENT(1)=$P(^SC(SC,0),U)_" Consult Appt. on "_$E(NDATE,4,5)_"/"_$E(NDATE,6,7)_"/"_$E(NDATE,2,3)_" @ "_TME_" (Auto Rebooked)."
75 S %DT="ST",X="NOW" D ^%DT S CSCHDT=Y
76 S SNDPRV=$P($G(^GMR(123,LNK,0)),U,14)
77 D SCH^SDQQCN2(.ER,LNK,SNDPRV,CSCHDT,0,,.COMMENT) K COMMENT
78 Q
79NOSHOW(SC,SDDTM,CNPAT,CNSTLNK,CN,AUTO,NSDIE,NSDA) ;
80 ;Appt. was a NoShow, then mark Consult as Edit/Resubmit, add comment using silent call to notify user.
81 ;Variables NSDIE and NSDA used in calling routine for NoShow letter printed comment in consult.
82 N CSNOD,CPRSSTAT,NOSHOW,CSRQSRV,TPRNT,CSPRT,USER,Y,APPT,COMMENT,DA,DIC,DUZ2,DIC,DR,GM40,GMRND,ER,SNDPRV,J
83 S CSNOD=$G(^GMR(123,CNSTLNK,0)),CPRSSTAT=$P(CSNOD,U,12),SNDPRV=$P(CSNOD,U,14),NOSHOW="no-show",AUTO(SC,SDDTM,CNPAT)=CNSTLNK
84 I CPRSSTAT'="" S CPRSSTAT=$P($G(^ORD(100.01,CPRSSTAT,0)),U) Q:CPRSSTAT'="SCHEDULED"
85 S CSRQSRV=$P(CSNOD,U,5) I CSRQSRV'="" S TPRNT=$P($G(^GMR(123.5,CSRQSRV,123)),U,9) I TPRNT'="" S:$P($G(^%ZIS(1,TPRNT,0)),U)'="" CSPRT=$P(^(0),U) ;reprint consult
86 S USER=$P(^VA(200,DUZ,0),U),Y=SDDTM D DD^%DT S APPT=$E(SDDTM,4,5)_"/"_$E(SDDTM,6,7)_"/"_$E(SDDTM,2,3)_" @ "_$P(Y,"@",2)
87 S COMMENT(1)=$P(^SC(SC,0),U)_" Appt. on "_APPT_" was a "_NOSHOW_"." ;no-show is a key word used by a search do not change
88 N SDERR S SDERR=$$STATUS^GMRCGUIS(CNSTLNK,6,3,SNDPRV,"","",.COMMENT)
89 S NSDIE="^GMR(123,"_CNSTLNK_",40,",NSDA=+$G(COMMENT(0))
90 K COMMENT,DA
91 S DA(2)=SC,DA(1)=SDDTM,DA=CN,DIE="^SC("_DA(2)_",""S"","_DA(1)_",1,",DR="688///@" D ^DIE
92 I $D(CSPRT) D EN^GMRCP5(CNSTLNK,"C",CSPRT)
93 K CNSTLNK Q
Note: See TracBrowser for help on using the repository browser.