Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDECWL2

SDECWL2.m

Go to the documentation of this file. 
SDECWL2 ;ALB/SAT,WTC,LAB - VISTA SCHEDULING RPCS ;Apr 10, 2020@15:22

 ;;5.3;Scheduling;**627,642,658,665,694,745**;Aug 13, 1993;Build 40

 ;;Per VHA Directive 2004-038, this routine should not be modified

 ;

 Q

 ;

WLSET(RET,INP) ;Waitlist Set

 ;SD*5.3*745 replace external 'INP...' due to XINDEX issue.  Parameters are then rolled into the INP array

 ;WLSET(RET,S1,S2,S3,S4,S5,S6,S7,S8,S9,S10,S11,S12,S13,S14,S15,S16,S17,S18,S19,S20,S21,S22,S23,S24,S25,S26,SD27) external parameter tag in SDEC

 ; INP - Input parameters array

 ;  INP(1)  = (integer)  Wait List IEN point to

 ;                       SD WAIT LIST file 409.3.

 ;                       If null, a new entry will be added

 ;  INP(2)  = (text)     DFN Pointer to the PATIENT file 2

 ;  INP(3)  = (date)     Originating Date/time in external date form

 ;  INP(4)  = (text)     Institution name NAME field from the INSTITUTION file

 ;  INP(5)  = (text)     Wait List Type

 ;                        PCMM TEAM ASSIGNMENT

 ;                        PCMM POSITION ASSIGNMENT

 ;                        SERVICE/SPECIALITY

 ;                        SPECIFIC CLINIC

 ;  INP(6)  = (text)     WL Specific Team name - NAME field in the TEAM file 404.51

 ;  INP(7)  = (text)     WL Specific Position name - NAME field in the

 ;                       TEAM POSITION file 404.57.

 ;  INP(8)  = (text)     WL Service/Specialty name - NAME field in

 ;                       SD WL SERVICE/SPECIALTY file 409.31 OR ien from 409.31

 ;  INP(9)  = (text)     WL Specific Clinic name - NAME field in

 ;                       SD WL CLINIC LOCATION file 409.32.

 ;  INP(10) = (text)     Originating User name  - NAME field in NEW PERSON file 200

 ;  INP(11) = (text)     Priority - 'ASAP' or 'FUTURE'

 ;  INP(12) = (text)     Request By - 'PROVIDER' or 'PATIENT'

 ;  INP(13) = (text)     Provider name  - NAME field in NEW PERSON file 200

 ;  INP(14) = (date)     Desired Date of appointment in external format.

 ;  INP(15) = (text)     comment must be 1-60 characters

 ;  INP(16) = (text)     EWL Enrollee Status

 ;                        NEW

 ;                        ESTABLISHED

 ;                        PRIOR

 ;                        UNDETERMINED

 ;  INP(17) = (text)     NOT USED - PATIENT TELEPHONE  4-20 characters

 ;  INP(18) = (text)     ENROLLMENT PRIORITY - Valid Values are:

 ;                                             GROUP 1

 ;                                             GROUP 2

 ;                                             GROUP 3

 ;                                             GROUP 4

 ;                                             GROUP 5

 ;                                             GROUP 6

 ;                                             GROUP 7

 ;                                             GROUP 8

 ;  INP(19) = (text)    NOT USED - APPT SCHEDULED DATE

 ;  INP(20) = (text)     <NOT USED>  MULTIPLE APPOINTMENT RTC      NO; YES

 ;  INP(21) = (integer)  <NOT USED>  MULT APPT RTC INTERVAL integer between 1-365

 ;  INP(22) = (integer)  <NOT USED>  MULT APPT NUMBER integer between 1-100

 ;  INP(23) = Patient Contacts separated by ::

 ;            Each :: piece has the following ~~ pieces:

 ;            1) = (date)    DATE ENTERED external date/time

 ;            2) = (text)    PC ENTERED BY USER ID or NAME - Pointer to NEW PERSON file or NAME

 ;            4) = (text)    ACTION - 'CALLED', 'MESSAGE LEFT', or 'LETTER'

 ;            5) = (optional) PATIENT PHONE Free-Text 4-20 characters

 ;            6) = NOT USED (optional) Comment 1-160 characters

 ;  INP(24) = (optional) SERVICE CONNECTED PRIORITY valid values are NO  YES

 ;  INP(25) = (optional) SERVICE CONNECTED PERCENTAGE = numeric 0-100

 ;  INP(27) = (optional) Appointment Type ID pointer to APPOINTMENT TYPE file 409.1

 ;

 N X,Y,%DT

 N DFN,MI,WLIEN,WLORIGDT,WLINST,WLINSTI,WLTYPE,WLTEAM,WLPOS,WLSRVSP,WLCLIN

 N WLUSER,WLPRIO,WLREQBY,WLPROV,WLDAPTDT,WLCOMM,WLEESTAT,WLEDT,WLQUIT

 N AUDF,FNUM,FDA,WLNEW,WLRET,WLMSG,WLDATA,WLERR,WLHOS

 N WLAPTYP,WLPATTEL,WLENPRI,WLSVCCON,WLSVCCOP

 S (AUDF,WLQUIT)=0

 S FNUM=$$FNUM^SDECWL

 S RET="I00020ERRORID^T00030ERRORTEXT"_$C(30)

 ; Use MERGE instead of SET so we can know if values were actually specified or not.

 ; This way, if a value is null, we will delete any previous value,

 ; but if it is missing, then we will just ignore it.

 M WLIEN=INP(1)

 S WLHOS=""

 S DFN=$G(INP(2))

 I '+DFN S RET=RET_"-1^Invalid Patient ID."_$C(30,31) Q

 I '$D(^DPT(DFN,0)) S RET=RET_"-1^Invalid Patient ID"_$C(30,31) Q

 S WLEDT=$P($G(INP(3)),":",1,2)

 ;

 ;  Change date/time conversion so midnight is handled properly.  wtc 694 5/17/18

 ;

 S WLEDT=$$NETTOFM^SDECDATE(WLEDT,"Y","N") I WLEDT=-1 S RET=RET_"-1^Invalid Origination date."_$C(30,31) Q  ;

 ;S %DT="TX" S X=WLEDT D ^%DT S WLEDT=Y

 ;I Y=-1 S RET=RET_"-1^Invalid Origination date."_$C(30,31) Q

 S WLORIGDT=$P(WLEDT,".",1)

 S WLINST=$G(INP(4)) I WLINST'="" D

 .I '+WLINST S WLINST=$O(^DIC(4,"B",WLINST,0))

 S WLTYPE=$G(INP(5)) I WLTYPE'="" S WLTYPE=$S(WLTYPE="PCMM TEAM ASSIGNMENT":1,WLTYPE="PCMM POSSITION ASSIGNMENT":2,WLTYPE="SERVICE/SPECIALITY":3,WLTYPE="SPECIFIC CLINIC":4,+WLTYPE:+WLTYPE,1:"")

 I WLTYPE="" S RET=RET_"-1^Invalid Wait List Type."_$c(30,31) Q

 S WLTEAM=$G(INP(6)) I WLTEAM'="" D

 .I '+WLTEAM S WLTEAM=$O(^SCTM(404.51,"B",WLTEAM,0))

 .I +WLTEAM I '$D(^SCTM(404.51,+WLTEAM,0)) S WLTEAM=""

 S WLPOS=$G(INP(7)) I WLPOS'="" D

 .I '+WLPOS S WLPOS=$O(^DIC(404.57,"B",WLPOS,0))

 .I +WLPOS I '$D(^SCTM(404.57,WLPOS,0)) S WLPOS=""

 S WLCLIN=$G(INP(9))

 I WLCLIN'="" D   ;WLCLIN pointer to SD WL CLINIC LOCATION; WLHOS pointer to HOSPITAL LOCATION

 .I +WLCLIN D

 ..I '$D(^SDWL(409.32,+WLCLIN,0)) S RET=RET_"-1^"_WLCLIN_" is an invalid WL Waitlist Specific Clinic ID."_$C(30,31) S WLQUIT=1 Q

 ..S WLHOS=+$P($G(^SDWL(409.32,+WLCLIN,0)),U,1)

 .I '+WLCLIN D

 ..S WLHOS=$O(^SC("B",WLCLIN,0))  ;$S(+WLCLIN:$P($G(^SC($P($G(^SDWL(409.32,WLCLIN,0)),U,1),0)),U,1),1:WLCLIN)

 ..S WLCLIN=$O(^SDWL(409.32,"B",+WLHOS,0)) I 'WLCLIN S RET=RET_"-1^"_WLCLIN_" is an invalid WL Waitlist Specific Clinic Name."_$C(30,31) S WLQUIT=1 Q

 Q:+WLQUIT  ;alb/sat 665

 S INP(8)=$G(INP(8))

 I INP(8)'="",WLCLIN'="" S RET=RET_"-1^Cannot include both Clinic and Service."_$C(30,31) Q   ;alb/sat 642

 I +INP(8),'$D(^SDWL(409.31,+INP(8),0)) S RET=RET_"-1^Invalid service/specialty "_+INP(8)_"."_$C(30,31) Q   ;alb/sat 642

 S WLUSER=$G(INP(10))

 I WLUSER'="" I '+WLUSER S WLUSER=$O(^VA(200,"B",WLUSER,0))

 I WLUSER="" S WLUSER=DUZ

 S WLREQBY=$G(INP(12)) I WLREQBY'="" S WLREQBY=$S(WLREQBY="PATIENT":2,WLREQBY="PROVIDER":1,1:"")

 S WLPROV=$G(INP(13)) I WLPROV'="" I '+WLPROV S WLPROV=$O(^VA(200,"B",WLPROV,0))

 S WLDAPTDT=$G(INP(14))

 S %DT="" S X=$P($G(WLDAPTDT),"@",1) D ^%DT S WLPRIO=$S(Y=$P($$NOW^XLFDT,".",1):"A",1:"F")

 S WLDAPTDT=Y

 I Y=-1 S WLDAPTDT=""   ;S RET=RET_"-1^Invalid Desired Date."_$C(30,31) Q

 S (INP(15),WLCOMM)=$TR($G(INP(15)),"^"," ")  ;alb/sat 658

 S WLEESTAT=$G(INP(16)) I WLEESTAT'="" S WLEESTAT=$S(WLEESTAT="NEW":"N",WLEESTAT="ESTABLISHED":"E",WLEESTAT="PRIOR":"P",WLEESTAT="UNDETERMINED":"U",1:WLEESTAT)

 M WLPATTEL=INP(17)

 S WLENPRI=$G(INP(18)) D

 .S:WLENPRI'="" WLENPRI=$S(WLENPRI="GROUP 1":1,WLENPRI="GROUP 2":2,WLENPRI="GROUP 3":3,WLENPRI="GROUP 4":4,WLENPRI="GROUP 5":5,WLENPRI="GROUP 6":6,WLENPRI="GROUP 7":7,WLENPRI="GROUP 8":8,1:WLENPRI)

 S WLSVCCON=$G(INP(24)) S:WLSVCCON'="" WLSVCCON=$S(WLSVCCON="YES":1,1:0)

 S WLSVCCOP=$G(INP(25)) I WLSVCCOP'="" S WLSVCCOP=+$G(WLSVCCOP) S:(+WLSVCCOP<0)!(+WLSVCCOP>100) WLSVCCOP=""

 S WLAPTYP=+$G(INP(27)) I +WLAPTYP,'$D(^SD(409.1,WLAPTYP,0)) S WLAPTYP=""

 S WLIEN=$G(WLIEN)

 S WLNEW=WLIEN=""

 I WLNEW D

 . S FDA=$NA(FDA(FNUM,"+1,"))

 . S @FDA@(.01)=+DFN

 . ;This handles the date/time coming in as "8/27/2014 12:00:00 AM"

 . S:$G(WLORIGDT)'="" @FDA@(1)=WLORIGDT

 . S:$G(WLINST)'="" @FDA@(2)=+WLINST

 . S:$G(WLTYPE)'="" @FDA@(4)=WLTYPE

 . ;S:$G(WLTEAM)'="" @FDA@(5)=+WLTEAM

 . S:$G(WLPOS)'="" @FDA@(6)=+WLPOS

 . ;S:$G(WLSRVSP)'="" @FDA@(7)=$S(+WLSRVSP:$P($G(^SDWL(409.31,WLSRVSP,0)),U),1:WLSRVSP)

 . S:$G(WLCLIN)'="" @FDA@(8)=+WLCLIN

 . S:$G(WLHOS)'="" @FDA@(8.5)=WLHOS

 . S:+WLAPTYP @FDA@(8.7)=+WLAPTYP

 . S:$G(WLUSER)'="" @FDA@(9)=+WLUSER

 . S:$G(WLEDT)'="" @FDA@(9.5)=WLEDT

 . S:$G(WLPRIO)'="" @FDA@(10)=WLPRIO

 . S:$G(WLENPRI)'="" @FDA@(10.5)=WLENPRI

 . S:$G(WLREQBY)'="" @FDA@(11)=WLREQBY

 . S:$G(WLPROV)'="" @FDA@(12)=+WLPROV

 . S:$G(WLSVCCOP)'="" @FDA@(14)=WLSVCCOP

 . S:$G(WLSVCCON)'="" @FDA@(15)=WLSVCCON

 . S:$G(WLDAPTDT)'="" @FDA@(22)=WLDAPTDT

 . S @FDA@(23)="O"

 . S:$G(WLCOMM)'="" @FDA@(25)=WLCOMM

 . S:$G(WLEESTAT)'="" @FDA@(27)=WLEESTAT

 . S:+WLAPTYP @FDA@(8.7)=+WLAPTYP

 E  D

 . S WLIEN=WLIEN_"," ; Append the comma for both

 . K WLDATA,WLERR

 . D GETS^DIQ(FNUM,WLIEN,"*","IE","WLDATA","WLERR")

 . I $D(WLERR) M WLMSG=WLERR K FDA Q

 . S FDA=$NA(FDA(FNUM,WLIEN))

 . I $D(WLORIGDT) D

 . . I WLORIGDT'=WLDATA(FNUM,WLIEN,1,"I") S @FDA@(1)=WLORIGDT

 . I $D(WLINST),WLINST'=WLDATA(FNUM,WLIEN,2,"I") S @FDA@(2)=$S(WLINST="":"@",1:+WLINST)

 . I $D(WLTYPE),WLTYPE'=WLDATA(FNUM,WLIEN,4,"E") S @FDA@(4)=WLTYPE

 . ;I $D(WLTEAM),WLTEAM'=WLDATA(FNUM,WLIEN,5,"I") S @FDA@(5)=$S(WLTEAM="":"@",1:+WLTEAM)

 . I $D(WLPOS),WLPOS'=WLDATA(FNUM,WLIEN,6,"I") S @FDA@(6)=$S(WLPOS="":"@",1:+WLPOS)

 . ;I $D(WLSRVSP),WLSRVSP'=WLDATA(FNUM,WLIEN,7,"I") S @FDA@(7)=$S(WLSRVSP="":"@",+WLSRVSP:$P($G(^DIC(40.7,$P($G(^SDWL(409.31,WLSRVSP,0)),U),0)),U),1:WLSRVSP)

 . I $D(WLCLIN),WLCLIN'=WLDATA(FNUM,WLIEN,8,"I") S @FDA@(8)=$S(WLCLIN="":"@",1:+WLCLIN),AUDF=1 S:WLDATA(FNUM,WLIEN,7,"I")'="" @FDA@(7)="@"

 . I $D(WLHOS),WLHOS'=WLDATA(FNUM,WLIEN,8.5,"I") S @FDA@(8.5)=WLHOS,AUDF=1 S:WLDATA(FNUM,WLIEN,7,"I")'="" @FDA@(7)="@"

 . S:+WLAPTYP @FDA@(8.7)=+WLAPTYP

 . I $D(WLUSER),WLUSER'=WLDATA(FNUM,WLIEN,9,"I") S @FDA@(9)=$S(WLUSER="":"@",1:+WLUSER)

 . I $D(WLEDT),WLEDT'=$G(WLDATA(FNUM,WLIEN,9.5,"I")) S @FDA@(9.5)=WLEDT

 . I $D(WLPRIO),WLPRIO'=WLDATA(FNUM,WLIEN,10,"I") S @FDA@(10)=$S(WLPRIO="":"@",1:WLPRIO)

 . I $D(WLENPRI),WLENPRI'=WLDATA(FNUM,WLIEN,10.5,"E") S @FDA@(10.5)=WLENPRI

 . I $D(WLREQBY),WLREQBY'=WLDATA(FNUM,WLIEN,11,"I") S @FDA@(11)=$S(WLREQBY="":"@",1:WLREQBY)

 . I $D(WLPROV),WLPROV'=WLDATA(FNUM,WLIEN,12,"I") S @FDA@(12)=$S(WLPROV="":"@",1:+WLPROV)

 . I $D(WLSVCCOP),WLSVCCOP'=$G(WLDATA(FNUM,WLIEN,14,"I")) S @FDA@(14)=WLSVCCOP

 . I $D(WLSVCCON),WLSVCCON'=WLDATA(FNUM,WLIEN,15,"E") S @FDA@(15)=WLSVCCON

 . I $D(WLDAPTDT),WLDAPTDT'=WLDATA(FNUM,WLIEN,22,"I") S @FDA@(22)=$S(WLDAPTDT="":"@",1:WLDAPTDT)

 . I $D(WLCOMM),WLCOMM'=WLDATA(FNUM,WLIEN,25,"I") S @FDA@(25)=$S(WLCOMM="":"@",1:WLCOMM)

 . I $D(WLEESTAT),WLEESTAT'=WLDATA(FNUM,WLIEN,27,"I") S @FDA@(27)=$S(WLEESTAT="":"@",1:WLEESTAT)

 ; Only call UPDATE^DIE if there are any array entries in FDA

 D:$D(@FDA) UPDATE^DIE("","FDA","WLRET","WLMSG")

 I $D(WLMSG) D

 . F MI=1:1:$G(WLMSG("DIERR")) S RET=RET_"-1^"_$G(WLMSG("DIERR",MI,"TEXT",1))_$C(30)

 . S RET=RET_$C(31)

 Q:$D(WLMSG)

 S WLINSTI=$P($G(^SDWL(409.3,$S(+WLIEN:WLIEN,1:WLRET(1)),0)),U,3)

 I $G(INP(6))'="" D WL6   ;wl specific team

 I $G(INP(8))'="" D WL8   ;wl service specialty

 I $D(INP(23)) D WL23(INP(23),$S(+WLIEN:WLIEN,1:WLRET(1)))   ;patient contacts

 I +AUDF D WLAUD($S(+WLIEN:+WLIEN,1:WLRET(1)),WLCLIN,WLHOS,INP(8))   ;VS AUDIT

 I +$G(WLRET(1)) S RET=RET_WLRET(1)_U_$C(30,31)

 E  S RET=RET_+WLIEN_U_$C(30,31)

 Q

 ;

WL6 ;WL SPECIFIC TEAM does not store with bulk UPDATE^DIE with external data; don't know why

 N FDA,H

 S H=$O(^SCTM(404.51,"B",+$G(INP(6)),0))

 I +H K FDA S FDA=$NA(FDA(409.3,$S(+WLIEN:WLIEN,1:WLRET(1))_",")) S @FDA@(5)=H D UPDATE^DIE("","FDA")

 Q

 ;

WL8 ;WL SERVICE/SPECIALTY does not store with bulk UPDATE^DIE if duplicates; need to look for 1st active one

 ; WL Service/Specialty name - NAME field in

 ; SD WL SERVICE/SPECIALTY file 409.31.

 N ADUF,SDWLNOD,WLSRVSP

 S WLSRVSP=""

 I +INP(8) S WLSRVSP=INP(8)

 I WLSRVSP="" S H="" F  S H=$O(^DIC(40.7,"B",$G(INP(8)),H)) Q:H=""  D  Q:WLSRVSP'=""

 .I $P(^DIC(40.7,H,0),U,3)'="",$P(^DIC(40.7,H,0),U,3)<$$NOW^XLFDT() Q

 .S WLSRVSP=$O(^SDWL(409.31,"B",H,0))

 I WLSRVSP'="" D

 .K FDA

 .S FDA=$NA(FDA(409.3,$S(+WLIEN:WLIEN,1:WLRET(1))_","))

 .S @FDA@(7)=WLSRVSP,ADUF=1

 .I +WLIEN,$D(WLDATA) D

 ..S:WLDATA(FNUM,WLIEN,8,"I")'="" @FDA@(8)="@"  ;errors

 ..S:WLDATA(FNUM,WLIEN,8.5,"I")'="" @FDA@(8.5)="@" ;errors

 .D:$D(FDA) UPDATE^DIE("","FDA")

 Q

 ;

WLACT(NAME) ;

 N ACTIVE,H

 S ACTIVE=""

 S H="" F  S H=$O(^DIC(40.7,"B",NAME,H)) Q:H=""  D  Q:ACTIVE'=""

 .I $P(^DIC(40.7,H,0),U,3)'="",$P(^DIC(40.7,H,0),U,3)<$$NOW^XLFDT() Q

 .S ACTIVE=H

 Q ACTIVE

 ;

WL23(INP23,WLI) ;Patient Contacts

 N STR23,WLASD,WLASDH,WLDATA1,WLERR1,WLI1,WLIENS,WLIENS1,WLRET1,FDA

 N WLUSR,X,Y,%DT

 S WLIENS=WLI_","

 F WLI1=1:1:$L(INP23,"::") D

 .S STR23=$P(INP23,"::",WLI1)

 .K FDA

 . ;

 . ;  Change date/time conversion so midnight is handled properly.  wtc 694 5/17/18

 . ;

 . S WLASD=$$NETTOFM^SDECDATE($P($P(STR23,"~~",1),":",1,2),"Y","N") ;

 . ;S %DT="T" S X=$P($P(STR23,"~~",1),":",1,2) D ^%DT S WLASD=Y

 .I (WLASD=-1)!(WLASD="") Q

 .S WLASDH=""   ;$O(^SDWL(409.3,WLI,4,"B",WLASD,0))

 .S WLIENS1=$S(WLASDH'="":WLASDH,1:"+1")_","_WLIENS

 .S FDA=$NA(FDA(409.344,WLIENS1))

 .I WLASDH'="" D

 ..D GETS^DIQ(409.344,WLIENS1,"*","IE","WLDATA1","WLERR1")

 ..I $P(STR23,"~~",1)'="" S @FDA@(.01)=$P($P(STR23,"~~",1),":",1,2) ;DATE ENTERED external date/time

 ..I $P(STR23,"~~",2)'="" S WLUSR=$P(STR23,"~~",2) S @FDA@(2)=$S(WLUSR="":"@",+WLUSR:$P($G(^VA(200,WLUSR,0)),U,1),1:WLUSR)  ;PC ENTERED BY USER

 ..I $P(STR23,"~~",4)'="" S @FDA@(3)=$P(STR23,"~~",4)     ;ACTION  C=Called; M=Message Left; L=LETTER

 ..I $P(STR23,"~~",5)'="" S @FDA@(4)=$P(STR23,"~~",5)     ;PATIENT PHONE

 ..;I $P(STR23,"~~",6)'="" S @FDA@(5)=$E($P(STR23,"~~",6),1,160)     ;COMMENT

 .I WLASDH="" D

 ..I $P(STR23,"~~",1)'="" S @FDA@(.01)=$P($P(STR23,"~~",1),":",1,2) ;DATE ENTERED external date/time

 ..I $P(STR23,"~~",2)'=""  S WLUSR=$P(STR23,"~~",2) S @FDA@(2)=$S(WLUSR="":"@",+WLUSR:$P($G(^VA(200,WLUSR,0)),U,1),1:WLUSR)     ;PC ENTERED BY USER

 ..I $P(STR23,"~~",4)'="" S @FDA@(3)=$P(STR23,"~~",4)     ;ACTION  C=Called; M=Message Left; L=LETTER

 ..I $P(STR23,"~~",5)'="" S @FDA@(4)=$P(STR23,"~~",5)     ;PATIENT PHONE

 ..;I $P(STR23,"~~",6)'="" S @FDA@(5)=$E($P(STR23,"~~",6),1,160)     ;COMMENT

 .D:$D(@FDA) UPDATE^DIE("E","FDA","WLRET1","WLMSG1")

 .;D:$D(@FDA) UPDATE^DIE("E","FDA","WLRET1")

 Q

 ;

WLAUD(WLIEN,WLCLIN,SDCL,WLSTOP,DATE,USER)  ;populate VS AUDIT multiple field 45

 ; WLIEN   - (required) pointer to SDEC APPT REQUEST file 409.85

 ; WLCLIN  - (optional) pointer to SD WL SPECIFIC CLINIC

 ; SDCL    - (optional) pointer to HOSPITAL LOCATION file 44

 ; WLSTOP  - (optional) pointer to CLINIC STOP file

 ; DATE    - (optional) date/time in fileman format

 N SDFDA,SDP,SDPN

 S WLIEN=$G(WLIEN) Q:WLIEN=""

 S WLCLIN=$G(WLCLIN)

 S SDCL=$G(SDCL)

 S WLSTOP=$G(WLSTOP)

 S SDP=$O(^SDWL(409.3,WLIEN,6,9999999),-1)

 I +SDP S SDPN=^SDWL(409.3,WLIEN,6,SDP,0) I $P(SDPN,U,3)=WLCLIN,$P(SDPN,U,4)=SDCL,$P(SDPN,U,5)=WLSTOP Q

 S DATE=$G(DATE) S:DATE="" DATE=$E($$NOW^XLFDT,1,12)

 S USER=$G(USER) S:USER="" USER=DUZ

 S SDFDA(409.345,"+1,"_WLIEN_",",.01)=DATE

 S SDFDA(409.345,"+1,"_WLIEN_",",1)=USER

 S:WLCLIN'="" SDFDA(409.345,"+1,"_WLIEN_",",2)=WLCLIN

 S:SDCL'="" SDFDA(409.345,"+1,"_WLIEN_",",3)=SDCL

 S:WLSTOP'="" SDFDA(409.345,"+1,"_WLIEN_",",4)=WLSTOP

 D UPDATE^DIE("","SDFDA")

 Q