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

SDM1A.m

Go to the documentation of this file.
  1. SDM1A ;SF/GFT,ALB/TMP,MS/PB - MAKE APPOINTMENT ;JUN 29, 2017
  1. ;;5.3;Scheduling;**26,94,155,206,168,223,241,263,327,478,446,544,621,622,627,658,665,650,704,694,775,792,809**;Aug 13, 1993;Build 10
  1. ;
  1. OK I $D(SDMLT) D ^SDM4 Q:X="^"!(SDMADE=2)
  1. S ^SC(SC,"ST",$P(SD,"."),1)=S,^DPT(DFN,"S",SD,0)=SC,^SC(SC,"S",SD,0)=SD S:'$D(^DPT(DFN,"S",0)) ^(0)="^2.98P^^" S:'$D(^SC(SC,"S",0)) ^(0)="^44.001DA^^" L -^SC(SC,"ST",$P(SD,"."),1)
  1. S1 L +^SC(SC,"S",SD,1):$G(DILOCKTM,5) W:'$T "Another user is editing this record. Trying again.",! G:'$T S1 F SDY=1:1 I '$D(^SC(SC,"S",SD,1,SDY)) S:'$D(^(0)) ^(0)="^44.003PA^^" S ^(SDY,0)=DFN_U_(+SL)_"^^^^"_$G(DUZ)_U_DT L -^SC(SC,"S",SD,1) Q
  1. I SM S ^("OB")="O" ;NAKED REFERENCE - ^SC(IFN,"S",Date,1,SDY,"OB")
  1. I $D(^SC(SC,"RAD")),^("RAD")="Y"!(^("RAD")=1) S ^SC("ARAD",SC,SD,DFN)=""
  1. S SDINP=$$INP^SDAM2(DFN,SD)
  1. ;-- added sub-category
  1. S COV=3,SDYC="",COV=$S(COLLAT=1:1,1:3),SDYC=$S(COLLAT=7:1,1:"")
  1. S:SD<DT SDSRTY="W"
  1. S ^DPT(DFN,"S",SD,0)=SC_"^"_$$STATUS(SC,SDINP,SD)_"^^^^^"_COV_"^^^^"_SDYC_"^^^^^"_SDAPTYP_U_$G(SD17)_"^"_$G(DUZ)_U_DT_"^^^^^"_$G(SDXSCAT)_U_$P($G(SDSRTY),U,2)_U_$$NAVA^SDMANA(SC,SD,$P($G(SDSRTY),U,2)) ;544 added DUZ
  1. S ^DPT(DFN,"S",SD,1)=$G(SDDATE)_U_$G(SDSRFU)
  1. I $D(SDMULT) S SDCLNCND=^SC(SC,0),STPCOD=$P(SDCLNCND,U,7),TMPYCLNC=SC_U_$P(SDCLNCND,U) D A^SDCNSLT ;SD/478 MULTI CLINIC OPTION SELECTED
  1. ;xref DATE APPT. MADE field
  1. D
  1. .N DIV,DA,DIK
  1. .S DA=SD,DA(1)=DFN,DIK="^DPT(DA(1),""S"",",DIK(1)=20 D EN1^DIK
  1. .D EN^SDTMPHLA(DFN,SD) ; Patch 704 - added to send the update to TMP when an appointment is scheduled with VistA roll and scroll options
  1. .Q
  1. K:$D(^DPT(DFN,"S",SD,"R")) ^("R") K:$D(^DPT("ASDCN",SC,SD,DFN)) ^(DFN)
  1. S SDRT="A",SDTTM=SD,SDPL=SDY,SDSC=SC D RT^SDUTL
  1. W !," ",+SL,"-MINUTE APPOINTMENT MADE" K SDINP
  1. ;confirm request type & follow-up indicator
  1. I $D(SDSRTY(0)) D CONF(.SDSRTY,.SDSRFU,DFN,SD,SC) W !
  1. I $P(SD,".")'>DT,$D(^DPT(DFN,.321)) D EN1^SDM3
  1. ;Wait List SD*5.3*263
  1. ;I '$D(SDWLLIST) D ^SDWLR ;replaced with sd/372, see below
  1. EWLCHK ;check if patient has any open EWL entries (SD/372)
  1. ;get appointment
  1. K ^TMP($J,"SDAMA301"),^TMP($J,"APPT")
  1. D APPT^SDWLEVAL(DFN,SD,SC)
  1. Q:'$D(^TMP($J,"APPT"))
  1. N SDWL,SDWLF,SDWLIST S SDWL="" S SDWLF=0 ;alb/sat 627
  1. N SDEV D EN^SDWLEVAL(DFN,.SDEV) I SDEV,$L(SDEV(1))>0 D
  1. .K ^TMP("SDWLPL",$J),^TMP($J,"SDWLPL")
  1. .D INIT^SDWLPL(DFN,"M")
  1. .Q:'$D(^TMP($J,"SDWLPL"))
  1. .D LIST^SDWLPL("M",DFN)
  1. .D SDGET(.SDWLIST) ;alb/sat 627
  1. .F Q:'$D(^TMP($J,"SDWLPL")) N SDR D ANSW^SDWLEVAL(1,.SDR) S:SDR SDWLF=1 I 'SDR D LIST^SDWLPL("M",DFN) D
  1. ..F N SDR D ANSW^SDWLEVAL(0,.SDR) Q:'$D(^TMP($J,"SDWLPL")) I 'SDR W !,"MUST ENTER A REASON NOT TO DISPOSITION MATCHED EWL ENTRY",! ;alb/sat665 remove S SDWLF=1
  1. .S:+SDWLF SDWL=$$SDWL(.SDWLIST) ;alb/sat 627
  1. ;update SDEC APPOINTMENT file 409.84 ;alb/sat 627
  1. N SDECAR,SDREC,SDRES
  1. S SDREC=""
  1. I $G(CNSLTLNK)="",SDWL="" S SDREC=$$RECALL^SDECUTL(DFN,SD,SDSC) ;check if recall appt
  1. I SDWL="",$G(CNSLTLNK)="",SDREC="" S SDECAR=$$SDWLA(DFN,SD,SDSC,SDDATE,$G(SDAPTYP),$G(SDECANS)) ;alb/sat 665 add SDECANS
  1. K SDECANS
  1. S SDRES=$$GETRES^SDECUTL(SC,1)
  1. S SDAPTYP=$G(SDAPTYP) S:SDAPTYP="" SDAPTYP=$$GET1^DIQ(44,SC_",",2507,"I")
  1. ;alb/sat 658 - moved below OTHER INFO prompt to store in NOTE field of 409.84
  1. ;D SDECADD^SDEC07(SD,$$FMADD^XLFDT(SD,,,+SL),DFN,SDRES,0,SDDATE,"",$S(+SDWL:"E|"_SDWL,+$G(CNSLTLNK):"C|"_CNSLTLNK,+SDREC:"R|"_SDREC,+SDECAR:"A|"_SDECAR,1:""),,SC,,,,SDAPTYP) ;ADD SDEC APPOINTMENT ENTRY
  1. ;end addition/modification ;alb/sat 627
  1. ;CREATE 120 FLAG IF APPLICABLE; appt created
  1. FLG N SDST S SDST=$G(^TMP($J,"APPT",1)) I +SDST>0 D
  1. .Q ; sd/446
  1. .N SDT,SDDES,SDPAR,SDDES1,SDT1 S SDPAR=0 S SDT=+SDST,SDDES=$P(SDST,U,17) I SDDES="" S SDDES=DT ; today's date if no desired date
  1. .S X=SDT D H^%DTC S SDT1=%H
  1. .S X=SDDES D H^%DTC S SDDES1=%H
  1. .I SDT1-SDDES1>120 N SD120,SD120A S SD120=1,SD120A=1 D
  1. ..; CREATE ewl eN SDPR S SDPR=$S(SDDES=DT:"A",1:"F") entry with 120 flag
  1. ..N SDPR S SDPR=$S(SDDES=DT:"A",1:"F") ;10
  1. ..N SDWLIN S SDWLIN=+$P(SDST,U,15) ;2
  1. ..N SDWLSCPR S SDWLSCPR=0 I +$P(SDST,U,10)=11 S SDWLSCPR=1 ;15
  1. ..N SC,SDWLSCL S SC=+$P(SDST,U,2) D
  1. ...I $D(^SDWL(409.32,"B",SC)) S SDWLSCL=$O(^SDWL(409.32,"B",SC,"")) Q ;8
  1. ...;create 409.32 entry
  1. ...N DA,DIC S DIC(0)="LX",X=SC,DIC="^SDWL(409.32," D FILE^DICN
  1. ...S SDWLSCL=DA
  1. ...S DIE="^SDWL(409.32,"
  1. ...S DR=".02////^S X=SDWLIN" D ^DIE
  1. ...S DR="1////^S X=DT"
  1. ...S DR=DR_";2////^S X=DUZ"
  1. ...D ^DIE S SDPAR=1
  1. ..N DA S DIC(0)="LX",(X,SDWLDFN)=+$P(SDST,U,4),X=SDWLDFN,DIC="^SDWL(409.3," D FILE^DICN
  1. ..F L +^SDWL(409.3,DA):$G(DILOCKTM,5) Q:$T D
  1. ...I '$T W !,"Unable to acquire a lock on the Wait List file" Q
  1. ..; Update EWL variables.
  1. ..S SDWLDA=DA D EN^SDWLE11 ; get enrollee both SDWLDA and SDWLDFN have to be
  1. ..N SDWLCM S SDWLCM=" > 120 days; appt created"
  1. ..N SDWLSCPG S SDWLSCPG=$S($P($G(^DPT(SDWLDFN,.3)),U,1)="Y":$P(^(.3),U,2),1:"")
  1. ..S DR="1////^S X=DT"
  1. ..S DR=DR_";2////^S X=SDWLIN"
  1. ..S DR=DR_";4////^S X=4"
  1. ..S DR=DR_";8////^S X=SDWLSCL"
  1. ..S DR=DR_";9////^S X=DUZ"
  1. ..S DR=DR_";10////^S X=SDPR"
  1. ..S DR=DR_";11////^S X=2" ; by patient for this entry to avoid asking for provider
  1. ..S DR=DR_";14////^S X=SDWLSCPG"
  1. ..S DR=DR_";15////^S X=SDWLSCPR"
  1. ..S DR=DR_";22////^S X=SDDES"
  1. ..S DR=DR_";23////^S X=""O"""
  1. ..S DR=DR_";25////^S X=SDWLCM"
  1. ..S DR=DR_";36////^S X=SD120"
  1. ..S DR=DR_";39////^S X=SD120A"
  1. ..S DIE="^SDWL(409.3,"
  1. ..D ^DIE
  1. ..L -^SDWL(409.3,DA)
  1. ..D MESS^SDWL120(SDWLDFN,SC,SDT,SDPAR)
  1. ;continue appointment entry process
  1. ORD S %=2 W !,"WANT PATIENT NOTIFIED OF LAB,X-RAY, OR EKG STOPS" D YN^DICN I '% W !," Enter YES to notify patient on appt. letter of LAB, X-RAY, or EKG stops" G ORD
  1. I '(%-1) D ORDY^SDM3
  1. OTHER R !," OTHER INFO: ",D:DTIME I D["^" W !,*7,"'^' not allowed - hit return if no 'OTHER INFO' is to be entered" G OTHER
  1. S TMPD=D I $L(D)>150 D MSG^SDMM G OTHER ;SD/478
  1. I D]"",D?."?"!(D'?.ANP) W " ENTER LAB, SCAN, ETC." G OTHER
  1. I $L($G(^SC(SC,"S",SD,1,SDY,0)))+$L(D)+$L(DT)+$S($D(DUZ):$L(DUZ),1:0)>250 D MSG^SDMM G OTHER ; sd/446
  1. ;S $P(^(0),"^",4)=D,$P(^(0),U,6,7)=$S($D(DUZ):DUZ,1:"")_U_DT ;NAKED REFERENCE - ^SC(IFN,"S",Date,1,SDY,0)
  1. S $P(^(0),"^",4)=D ;NAKED REFERENCE - ^SC(IFN,"S",Date,1,SDY,0) 544 moved DUZ&DT to tag S1.
  1. ; SD*775 add SDSLSV to be evaluated
  1. S:$G(SL)="" SL=$S($D(SDSLSV):SDSLSV,1:$G(^SC(+SC,"SL"))) ;alb/sat 658 - SL gets killed in SDM3 if 'WANT PATIENT NOTIFIED OF LAB,X-RAY, OR EKG STOPS' is answered with Y
  1. D SDECADD^SDEC07(SD,$$FMADD^XLFDT(SD,,,+SL),DFN,SDRES,0,SDDATE,"",$S(+SDWL:"E|"_SDWL,+$G(CNSLTLNK):"C|"_CNSLTLNK,+SDREC:"R|"_SDREC,+SDECAR:"A|"_SDECAR,1:""),,SC,$G(D),,,SDAPTYP) ;ADD SDEC APPOINTMENT ENTRY ;alb/sat 658 moved from above
  1. D:$D(TMP) LINK^SDCNSLT(SC,SDY,SD,CNSLTLNK) ;SD/478
  1. D:$D(TMP) EDITCS^SDCNSLT(SD,TMPD,TMPYCLNC,CNSLTLNK) ;SD/478
  1. K TMP ;SD/478
  1. XR I $S('$D(^SC(SC,"RAD")):1,^("RAD")="Y":0,^("RAD")=1:0,1:1) S %=2 W !,"WANT PREVIOUS X-RAY RESULTS SENT TO CLINIC" D YN^DICN G:'% HXR I '(%-1) S ^SC("ARAD",SC,SD,DFN)=""
  1. SDMM S SDEMP=0 I COLLAT=7 S:SDEC'=SDCOL SDEMP=SDCOL G OV
  1. D ELIG^VADPT I $O(VAEL(1,0))>0 D ELIG^SDM4:"369"[SDAPTYP S SDEMP=$S(SDDECOD:SDDECOD,1:SDEMP)
  1. OV Q:$D(SDZM) K SDQ1,SDEC,SDCOL I +SDEMP S $P(^SC(SC,"S",SD,1,SDY,0),"^",10)=+SDEMP
  1. S SDMADE=1 D EVT
  1. LET ; SD*5.3*622 - help user print the PRE-APPT letter for a patient
  1. ; check for a PRE-APPT letter defined and if none, don't issue a device prompt
  1. N SDFN ; new SDFN to see the patient prompt next time
  1. S %=2 W !!,"WANT TO PRINT THE PRE-APPOINTMENT LETTER" D YN^DICN I %=0 W !,"RESPOND YES (Y) OR NO (N)" G:'% LET
  1. I (%=2)!(%=-1) Q
  1. I $P($G(^SC(SC,"LTR")),U,2)="" D Q
  1. . W $C(7),!!,"PATIENT "_$P(^DPT(DFN,0),U,1)," ",$P(^(0),U,9)," HAS FUTURE APPTS., but"
  1. . W !,$P(^SC(SC,0),U,1)_" is not assigned a PRE-APPOINTMENT LETTER",!
  1. . S DIR(0)="E" D ^DIR K DIR
  1. ;
  1. ; pre-define letter type (P), the division, date for appt, etc.
  1. S (SDBD,SDED)=SDTTM,L0="P",SD9=0,VAUTNALL=1,VAUTNI=2,S1="P",SDLT=1,SDV1=1,SDFORM=""
  1. S L2=$S(L0="P":"^SDL1",1:"^SDL1"),J=SDBD
  1. S (A,SDFN,S)=DFN,L="^SDL1",SDCL=+$P(^SC(SC,0),U,1),SDC=SC,SDX=SDTTM
  1. S SDLET=$P(^SC(SC,"LTR"),U,2) ; letter IEN
  1. S SDLET1=SDLET
  1. I SDY["DPT(" S SDAMTYP="P",SDFN=+SDY
  1. I SDY["SC(" S SDAMTYP="C",SDCLN=+SDY
  1. ; prepare to queue the letter if the user so desires
  1. N %ZIS,POP,ZTDESC,ZTRTN,ZTSAVE
  1. S %ZIS("B")="",POP=0,%ZIS="MQ" D ^%ZIS Q:POP
  1. I $D(IO("Q")) S ZTRTN="QUE^SDM1A",ZTDESC="PRINT PRE-APPT LETTER",ZTSAVE("*")="" D ^%ZTLOAD,HOME^%ZIS K IO("Q") Q
  1. D QUE ; print right away without getting into the queue
  1. D HOME^%ZIS
  1. Q
  1. ;
  1. QUE ; execute whether by queue or immediate print request
  1. U IO
  1. N SDFIRST S SDFIRST=1 ; Flag to determine first page SD*650
  1. D PRT^SDLT,WRAPP^SDLT
  1. ; if there are x-ray, lab, or ekg appts, print them too
  1. S SDATA=$G(^DPT(DFN,"S",SDX,0))
  1. I $D(SDATA) F B=3,4,5 D
  1. . S SDCL=$S(B=3:"LAB",B=4:"XRAY",1:"EKG")
  1. . S SDX=$P($G(SDATA),U,B)
  1. . S SC=SDCL Q:$G(SDX)="" D FORM^SDLT
  1. ;
  1. D REST^SDLT
  1. D ^%ZISC
  1. Q ; SD*5.3*622 - end of changes
  1. ;
  1. HXR W !," Enter YES to have previous XRAY results sent to the clinic" G XR
  1. Q
  1. CS S SDCS=+$P(^SC(+SC,0),"^",7) I $S('$D(^DIC(40.7,SDCS,0)):1,'$P(^(0),"^",3):0,1:$P(^(0),"^",3)'>DT) W !!,*7,"** WARNING - CLINIC HAS AN INVALID OR INACTIVE STOP CODE!!!",!!
  1. S SDCS=+$P(^SC(+SC,0),"^",18) I $S('SDCS:0,'$D(^DIC(40.7,SDCS,0)):1,'$P(^(0),"^",3):0,1:$P(^(0),"^",3)'>DT) W !!,*7,"** WARNING - CLINIC HAS AN INVALID OR INACTIVE CREDIT STOP CODE!!!",!!
  1. K SDCS Q
  1. STATUS(SDCL,SDINP,SDT) ; -- determine status for NEW appts
  1. Q $S(SDINP]"":SDINP,$$CHK(.SDCL,.SDT):"NT",1:"")
  1. CHK(SDCL,SDT) ; -- should appt be NT'ed
  1. ; -- non-count clinic check := don't NT appt
  1. ; -- appt update executed := need to NT appt
  1. ; -- otherwise := don't NT appt
  1. Q $S($P($G(^SC(SDCL,0)),U,17)="Y":0,$D(^SDD(409.65,"AUPD",$P(SDT,"."))):1,1:0)
  1. EVT ; -- separate tag if need to NEW vars
  1. D MAKE^SDAMEVT(DFN,SD,SC,SDY,0)
  1. Q
  1. REQ(SDT) ; -- which is required check in(CI) or out(CO)
  1. Q $S($$REQDT()>SDT:"CI",1:"CO")
  1. REQDT() ; -- co required date
  1. Q $S($P(^DG(43,1,"SCLR"),U,23):$P(^("SCLR"),U,23),1:2931001)
  1. COCMP(DFN,SDT) ; -- date CO completed
  1. Q $P($G(^SCE(+$P($G(^DPT(DFN,"S",SDT,0)),U,20),0)),U,7)
  1. CI(SDCL,SDT,SDDA,SDACT) ; -- ok to update DPT
  1. N C
  1. I '$$CHK(.SDCL,.SDT) G CIQ
  1. I $$REQ(SDT)'="CI" G CIQ
  1. I SDACT="SET",$D(^DPT(+^SC(SDCL,"S",SDT,1,SDDA,0),"S",SDT,0)),$P(^(0),U,2)="NT" S $P(^(0),U,2)=""
  1. I SDACT="KILL" S C=$G(^SC(SDCL,"S",SDT,1,SDDA,"C")) I $D(^DPT(+$G(^(0)),"S",SDT,0)),$P(^(0),U,2)="",'$P(C,U,3) S $P(^(0),U,2)="NT"
  1. CIQ Q
  1. CO(SDCL,SDT,SDDA,SDACT) ; -- ok to update DPT
  1. N DFN,C
  1. I '$$CHK(.SDCL,.SDT) G COQ
  1. I $$REQ(.SDT)'="CO" D G COQ
  1. .I SDACT="SET",$D(^DPT(+^SC(SDCL,"S",SDT,1,SDDA,0),"S",SDT,0)),$P(^(0),U,2)="NT" S $P(^(0),U,2)=""
  1. .I SDACT="KILL" S C=$G(^SC(SDCL,"S",SDT,1,SDDA,"C")) I $D(^DPT(+$G(^(0)),"S",SDT,0)),$P(^(0),U,2)="",'C S $P(^(0),U,2)="NT"
  1. S DFN=+^SC(SDCL,"S",SDT,1,SDDA,0)
  1. D UPD(.DFN,.SDT,$$COCMP(.DFN,.SDT),$S(SDACT="SET":X,1:""))
  1. COQ Q
  1. UPD(DFN,SDT,SDCOCMP,SDCODT) ; -- update status
  1. N Y
  1. I $D(^DPT(DFN,"S",SDT,0)) S Y=$P(^(0),U,2) D
  1. .I 'SDCOCMP!('SDCODT) S:Y="" $P(^DPT(DFN,"S",SDT,0),U,2)="NT" Q
  1. .S:Y="NT" $P(^DPT(DFN,"S",SDT,0),U,2)=""
  1. Q
  1. OE(SDOE,SDACT) ; -- called by x-ref on co completed field(#.07) in ^SCE
  1. N Y S Y=^SCE(SDOE,0)
  1. I $P(Y,U,8)'=1 G OEQ
  1. I $$REQ(+Y)'="CO" G OEQ
  1. I '$$CANT(+$P(Y,U,2),+Y,SDOE),'$$CHK(+$P(Y,U,4),+Y) G OEQ
  1. D UPD(+$P(Y,U,2),+Y,$S(SDACT="SET":X,1:""),$P($G(^SC(+$P(Y,U,4),"S",+Y,1,+$P(Y,U,9),"C")),U,3))
  1. OEQ Q
  1. CONF(SDSRTY,SDSRFU,DFN,SDT,SC) ;Confirm scheduling request type
  1. ;Input: SDSRTY=request type
  1. ;Input: SDSRFU=follow-up indicator
  1. ;Input: DFN=patient ien
  1. ;Input: SDT=appointment date/time
  1. ;Input: SC=clinic ifn
  1. N DIR,DIE,DA,DR,SDX,SDY,X,Y
  1. S DIR(0)="Y",DIR("B")="YES"
  1. S DIR("A")="THIS APPOINTMENT IS MARKED AS '"_SDSRTY(0)_"', IS THIS CORRECT"
  1. W ! D ^DIR Q:$D(DTOUT)!$D(DUOUT)
  1. I 'Y S SDX='SDSRTY,SDX(0)=$$TXRT(.SDX) W !!,"THIS APPOINTMENT HAS NOW BEEN MARKED AS '"_$S('SDSRTY:"",1:"NOT ")_"NEXT AVAILABLE'."
  1. ;S DIR("A")="THIS APPOINTMENT IS DEFINED AS '"_$S(SDSRFU:"FOLLOW-UP",1:"OTHER THAN FOLLOW-UP")_"', OK"
  1. ;W ! D ^DIR Q:$D(DTOUT)!$D(DUOUT)
  1. ;I 'Y S SDY='SDSRFU W " (changed)"
  1. Q:'$D(SDX) S DR=""
  1. I $D(SDX) S DR="25///^S X=$P(SDX,U,2);26///^S X=$$NAVA^SDMANA(SC,SDT,$P(SDX,U,2))"
  1. ;I $D(SDY) S:$L(DR) DR=DR_";" S DR=DR_"26///^S X=SDY"
  1. S DA=SDT,DA(1)=DFN
  1. S DIE="^DPT(DA(1),""S""," D ^DIE
  1. Q
  1. TXRT(SDSRTY) ;Transform request type
  1. ;Input: SDSRTY=variable to return request type (pass by reference)
  1. ;Output: external text for SDSRTY(0)
  1. I SDSRTY S SDSRTY=SDSRTY_U_"N" Q "NEXT AVAILABLE"
  1. S SDSRTY=SDSRTY_U_"O" Q "NOT NEXT AVAILABLE"
  1. CANT(DFN,SDT,SDOE) ;Determine if clinic appt. has been marked "NT"
  1. ;Output: '1' if appt. points to encounter and is marked "NT", otherwise '0'
  1. N SDAPP S SDAPP=$G(^DPT(DFN,"S",SDT,0))
  1. Q:$P(SDAPP,U,20)'=SDOE 0
  1. Q $P(SDAPP,U,2)="NT"
  1. SDGET(SDWLIST) ;build array of wait list entries that are in ^TMP($J,"SDWLPL")
  1. N SDI
  1. K SDWLIST
  1. S SDI="" F S SDI=$O(^TMP($J,"SDWLPL",SDI)) Q:SDI="" D
  1. .S SDWLIST(+$G(^TMP($J,"SDWLPL",SDI)))=""
  1. Q
  1. ; -- Variable doc for above tags
  1. ; SDCL := file 44 ien
  1. ; SDT := appt date/time
  1. ; DFN := file 2 ien
  1. ; SDDA := ^SC(SDCL,"S",SDT,1,SDDA,0)
  1. ; SDACT := current x-ref action 'set' or 'kill'
  1. ; SDCOCMP := check out completed date
  1. ; SDCODT := check out date/time
  1. ; SDOE := Outpatient Encounter ien
  1. ; SDINP := inpatient status ('I' or null)
  1. ; SDINP := inpatient status ('I' or null)
  1. ;
  1. SDWL(SDWLIST) ;determine EWL that was closed for this appointment ;alb/sat SD/627
  1. N SDI
  1. S SDI="" F S SDI=$O(^TMP($J,"SDWLPL",SDI)) Q:SDI="" D
  1. .I $D(SDWLIST(+$G(^TMP($J,"SDWLPL",SDI)))) K SDWLIST(+$G(^TMP($J,"SDWLPL",SDI)))
  1. Q $O(SDWLIST(0))
  1. SDWLA(DFN,SD,SDSC,SDDATE,SDAPTYP,SDECANS) ;add SDEC APPT REQUEST entry ;alb/sat SD/627 ;alb/sat 665 add SDECANS
  1. ;INPUT:
  1. ; DFN
  1. ; SD = appointment date/time in fm format
  1. ; SDSC = clinic code pointer to HOSPITAL LOCATION file
  1. ; SDDATE = desired date of appointment
  1. ; SDAPTYP = pointer to APPOINTMENT TYPE file 409.1
  1. ; SDECANS = service connected condition Y=yes N=no from SDM4 ;alb/sat 665
  1. N SDECINP,SDWLSTAT,SDARIEN,SDWLRET,X
  1. S SDAPTYP=$G(SDAPTYP)
  1. S SDECANS=$G(SDECANS) ;alb/sat 665
  1. ;get clinic location name
  1. K ^TMP("SDEC50",$J,"PCSTGET")
  1. D PCSTGET^SDEC(.SDWLRET,DFN,SDSC)
  1. S SDWLSTAT=$P($P($G(^TMP("SDEC50",$J,"PCSTGET",1)),$C(30),1),U,2)
  1. K ^TMP("SDEC50",$J,"PCSTGET")
  1. ;set appt request entry
  1. S SDECINP(1)=""
  1. S SDECINP(2)=DFN ;patient
  1. S X=$E($$NOW^XLFDT,1,12),SDECINP(3)=$$FMTE^XLFDT(X) ;originating date/time in external format PWC SD*5.3*694 VSE
  1. S SDECINP(4)=DUZ(2) ;institution
  1. S SDECINP(5)="APPOINTMENT" ;wait list type - specific clinic
  1. S SDECINP(6)=SDSC ;clinic
  1. S SDECINP(7)=DUZ ;originating user
  1. S SDECINP(8)="ASAP" ;priority
  1. S SDECINP(9)="PATIENT" ;requested by
  1. S SDECINP(11)=SDDATE ;desired date of appointment
  1. ;S SDECINP(16)=$S(SDWLSTAT="YES":"ESTABLISHED",1:"NEW")
  1. S SDECINP(14)="NO" ;multiple appointment RTC
  1. S SDECINP(15)=0
  1. S SDECINP(16)=0
  1. S:SDECANS'="" SDECINP(18)=$S(SDECANS="Y":"YES",1:0) ;alb/sat 665
  1. S:+SDAPTYP SDECINP(22)=+SDAPTYP ;appointment type
  1. K SDWLRET
  1. S SDWLRET=""
  1. D ARSET1^SDEC(.SDWLRET,.SDECINP)
  1. S SDARIEN=$P($P(SDWLRET,$C(30),2),U,1)
  1. S SDWLRET=""
  1. Q:'$D(^SDEC(409.85,+SDARIEN,0)) ""
  1. ;close appt request entry
  1. K INP
  1. S INP(1)=SDARIEN
  1. S INP(2)="REMOVED/SCHEDULED-ASSIGNED"
  1. S INP(3)=DUZ
  1. ;S INP(4)=$P(SD,".",1) ;SD_53_809 - commenting this code since this is not the correct disposition date
  1. S INP(4)=$$NETTOFM^SDECDATE($P($G(SDECINP(3)),"@"),"N","N") ;SD_53_809 - date of disposition should be the same to the create date
  1. D ARCLOSE1^SDEC(.SDWLRET,.INP)
  1. Q SDARIEN