SDM1A ;SF/GFT,ALB/TMP - MAKE APPOINTMENT ; 8/18/05 12:57pm ; 6/22/09 6:16pm
;;5.3;PIMS;**26,94,155,206,168,223,241,263,327,478,446,1005,1012,1013,1014,1015,1016**;JUN 30, 2012;Build 20
;IHS/ANMC/LJF 07/06/2000 hard set of date appt made now includes time
; 12/13/2000 added clear display of appt just made
; 06/22/2001 added call to create xref on date appt made
;IHS/OIT/LJF 12/30/2005 PATCH 1005 enhanced OTHER INFO help text
; 01/06/2006 PATCH 1005 fixed code so OTHER INFO always set correctly
;cmi/flag/maw 05/14/2010 PATCH 1012 RQMT129, increased length of OTHER INFO
;ihs/cmi/maw 02/02/2012 patch 1014, changed set of appointment mode to silent fileman call
;
OK I $D(SDMLT) D ^SDM4 Q:X="^"!(SDMADE=2)
;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
S ^SC(SC,"ST",$P(SD,"."),1)=S
D SDM^BSDMMU("","",DFN,SD,SC,"","","","","","","","",.BSDER) ;ihs/cmi/maw 02/12/2012 to call UPDATE^DIE
S ^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
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
I SM S ^("OB")="O" ;NAKED REFERENCE - ^SC(IFN,"S",Date,1,SDY,"OB")
I $D(^SC(SC,"RAD")),^("RAD")="Y"!(^("RAD")=1) S ^SC("ARAD",SC,SD,DFN)=""
S SDINP=$$INP^SDAM2(DFN,SD)
;-- added sub-category
S COV=3,SDYC="",COV=$S(COLLAT=1:1,1:3),SDYC=$S(COLLAT=7:1,1:"")
S:SD<DT SDSRTY="W"
I $G(BSDSRFU) S SDSRFU=1 ;cmi/maw 6/8/2010 PATCH 1012 followup indicator
;
;ihs/cmi/maw 02/02/2012 patch 1014 direct set no longer used
;S ^DPT(DFN,"S",SD,0)=SC_"^"_$$STATUS(SC,SDINP,SD)_"^^^^^"_COV_"^^^^"_SDYC_"^^^^^"_SDAPTYP_U_$G(SD17)_"^^"_DT_"^^^^^"_$G(SDXSCAT)_U_$P($G(SDSRTY),U,2)_U_$$NAVA^SDMANA(SC,SD,$P($G(SDSRTY),U,2)) ;IHS/ANMC/LJF 7/06/2000
;S ^DPT(DFN,"S",SD,0)=SC_"^"_$$STATUS(SC,SDINP,SD)_"^^^^^"_COV_"^^^^"_SDYC_"^^^^^"_SDAPTYP_U_$G(SD17)_"^^"_$$NOW^XLFDT_"^^^^^"_$G(SDXSCAT)_U_$P($G(SDSRTY),U,2)_U_$$NAVA^SDMANA(SC,SD,$P($G(SDSRTY),U,2)) ;IHS/ANMC/LJF 7/06/2000
;
;S ^DPT(DFN,"S",SD,1)=$G(SDDATE)_U_$G(SDSRFU)
D SDM^BSDMMU(COV,SDYC,DFN,SD,SC,SDINP,SDAPTYP,$G(SD17),$G(SDXSCAT),$P($G(SDSRTY),U,2),$$NAVA^SDMANA(SC,SD,$P($G(SDSRTY),U,2)),$G(SDDATE),$G(SDSRFU),.BSDER)
I $G(BSDER)]"" D Q
. W !,"Error making appointment in file 2.98" ;ihs/cmi/maw 2/2/2012 patch 1014 for GUI Scheduling
. S MAW="S $ZE=""SDM1A FAILED APPT CALL S1+14"" D ^ZTER" X MAW K MAW
;ihs/cmi/maw 02/02/2012 following commented lines no longer used patch 1014
;xref DATE APPT. MADE field
;D
;.N DIV,DA,DIK
;.S DA=SD,DA(1)=DFN,DIK="^DPT(DA(1),""S"",",DIK(1)=20 D EN1^DIK
;.Q
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
;xref DATE APPT. MADE field
;D
;.N DIV,DA,DIK
;.S DA=SD,DA(1)=DFN,DIK="^DPT(DA(1),""S"",",DIK(1)=20 D EN1^DIK
;.Q
K:$D(^DPT(DFN,"S",SD,"R")) ^("R") K:$D(^DPT("ASDCN",SC,SD,DFN)) ^(DFN)
S SDRT="A",SDTTM=SD,SDPL=SDY,SDSC=SC D RT^SDUTL
;
;W !," ",+SL,"-MINUTE APPOINTMENT MADE" K SDINP ;IHS/ANMC/LJF 12/13/2000
D APPT^BSDU2(DFN,SC,SD,+SL) K SDINP ;IHS/ANMC/LJF 12/13/2000
D XREFC^BSDDAM(SC,SD,SDY) ;ihs/cmi/maw 07/19/2011 patch 1013 doesn't look like this is set if OTHER INFO set to NO
;confirm request type & follow-up indicator
I $D(SDSRTY(0)) D CONF(.SDSRTY,.SDSRFU,DFN,SD,SC) W !
I $P(SD,".")'>DT,$D(^DPT(DFN,.321)) D EN1^SDM3
;Wait List SD*5.3*263
;I '$D(SDWLLIST) D ^SDWLR ;replaced with sd/372, see below
EWLCHK ;check if patient has any open EWL entries (SD/372)
;get appointment
K ^TMP($J,"SDAMA301"),^TMP($J,"APPT")
D APPT^SDWLEVAL(DFN,SD,SC)
Q:'$D(^TMP($J,"APPT"))
N SDEV D EN^SDWLEVAL(DFN,.SDEV) I SDEV,$L(SDEV(1))>0 D
.K ^TMP("SDWLPL",$J),^TMP($J,"SDWLPL")
.D INIT^SDWLPL(DFN,"M")
.Q:'$D(^TMP($J,"SDWLPL"))
.D LIST^SDWLPL("M",DFN)
.F Q:'$D(^TMP($J,"SDWLPL")) N SDR D ANSW^SDWLEVAL(1,.SDR) I 'SDR D LIST^SDWLPL("M",DFN) D
..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",!
;CREATE 120 FLAG IF APPLICABLE; appt created
FLG N SDST S SDST=$G(^TMP($J,"APPT",1)) I +SDST>0 D
.Q ; sd/446
.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
.S X=SDT D H^%DTC S SDT1=%H
.S X=SDDES D H^%DTC S SDDES1=%H
.I SDT1-SDDES1>120 N SD120,SD120A S SD120=1,SD120A=1 D
..; CREATE ewl eN SDPR S SDPR=$S(SDDES=DT:"A",1:"F") entry with 120 flag
..N SDPR S SDPR=$S(SDDES=DT:"A",1:"F") ;10
..N SDWLIN S SDWLIN=+$P(SDST,U,15) ;2
..N SDWLSCPR S SDWLSCPR=0 I +$P(SDST,U,10)=11 S SDWLSCPR=1 ;15
..N SC,SDWLSCL S SC=+$P(SDST,U,2) D
...I $D(^SDWL(409.32,"B",SC)) S SDWLSCL=$O(^SDWL(409.32,"B",SC,"")) Q ;8
...;create 409.32 entry
...N DA,DIC S DIC(0)="LX",X=SC,DIC="^SDWL(409.32," D FILE^DICN
...S SDWLSCL=DA
...S DIE="^SDWL(409.32,"
...S DR=".02////^S X=SDWLIN" D ^DIE
...S DR="1////^S X=DT"
...S DR=DR_";2////^S X=DUZ"
...D ^DIE S SDPAR=1
..N DA S DIC(0)="LX",(X,SDWLDFN)=+$P(SDST,U,4),X=SDWLDFN,DIC="^SDWL(409.3," D FILE^DICN
..F L +^SDWL(409.3,DA):5 Q:$T D
...I '$T W !,"Unable to acquire a lock on the Wait List file" Q
..; Update EWL variables.
..S SDWLDA=DA D EN^SDWLE11 ; get enrollee both SDWLDA and SDWLDFN have to be
..N SDWLCM S SDWLCM=" > 120 days; appt created"
..N SDWLSCPG S SDWLSCPG=$S($P($G(^DPT(SDWLDFN,.3)),U,1)="Y":$P(^(.3),U,2),1:"")
..S DR="1////^S X=DT"
..S DR=DR_";2////^S X=SDWLIN"
..S DR=DR_";4////^S X=4"
..S DR=DR_";8////^S X=SDWLSCL"
..S DR=DR_";9////^S X=DUZ"
..S DR=DR_";10////^S X=SDPR"
..S DR=DR_";11////^S X=2" ; by patient for this entry to avoid asking for provider
..S DR=DR_";14////^S X=SDWLSCPG"
..S DR=DR_";15////^S X=SDWLSCPR"
..S DR=DR_";22////^S X=SDDES"
..S DR=DR_";23////^S X=""O"""
..S DR=DR_";25////^S X=SDWLCM"
..S DR=DR_";36////^S X=SD120"
..S DR=DR_";39////^S X=SD120A"
..S DIE="^SDWL(409.3,"
..D ^DIE
..L -^SDWL(409.3,DA)
..D MESS^SDWL120(SDWLDFN,SC,SDT,SDPAR)
;continue appointment entry process
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
I '(%-1) D ORDY^SDM3
OTHER R !," OTHER INFO: ",D:DTIME I D["^" W !,*7,"'^' not allowed - hit return if no 'OTHER INFO' is to be entered" G OTHER
S TMPD=D I $L(D)>150 D MSG^SDMM G OTHER ;SD/478
;I $L(D)>150 D MSG^SDMM G OTHER ;cmi/maw 05/14/2010 PATCH 1012 RQMT129 inclreased length of OTHER INFO orig line
S TMPD=D I $L(D)>155 D MSG^SDMM G OTHER ;cmi/maw 05/14/2010 PATCH 1012 RQMT129 inclreased length of OTHER INFO
;
;IHS/OIT/LJF 12/30/2005 PATCH 1005 enhanced help text and removed old MSM restriction on global length
;I D]"",D?."?"!(D'?.ANP) W " ENTER LAB, SCAN, ETC." G OTHER
I D]"",D?."?"!(D'?.ANP) W !!,"Enter the Reason for the Appointment. May be up to 155 characters long (no semi-colons or colons).",! G OTHER
;I $L(^SC(SC,"S",SD,1,SDY,0))+$L(D)+$L(DT)+$S($D(DUZ):$L(DUZ),1:0)>250 D MSG^SDMM G OTHER
;
;IHS/OIT/LJF 01/06/2006 PATCH 1005 naked reference not always set correctly
;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) ;IHS/ANMC/LJF 7/06/2000
;S $P(^(0),"^",4)=D,$P(^(0),U,6,7)=$S($D(DUZ):DUZ,1:"")_U_$$NOW^XLFDT D XREFC^BSDDAM(SC,SD,SDY) ;IHS/ANMC/LJF 7/06/2000; 6/22/2001
S $P(^SC(SC,"S",SD,1,SDY,0),"^",4)=D,$P(^(0),U,6,7)=$S($D(DUZ):DUZ,1:"")_U_$$NOW^XLFDT D XREFC^BSDDAM(SC,SD,SDY) ;IHS/OIT/LJF 01/06/2006 PATCH 1005
;
D:$D(TMP) LINK^SDCNSLT(SC,SDY,SD,CNSLTLNK) ;SD/478
D:$D(TMP) EDITCS^SDCNSLT(SD,TMPD,TMPYCLNC,CNSLTLNK) ;SD/478
K TMP ;SD/478
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)=""
SDMM S SDEMP=0 I COLLAT=7 S:SDEC'=SDCOL SDEMP=SDCOL G OV
D ELIG^VADPT I $O(VAEL(1,0))>0 D ELIG^SDM4:"369"[SDAPTYP S SDEMP=$S(SDDECOD:SDDECOD,1:SDEMP)
OV Q:$D(SDZM) K SDQ1,SDEC,SDCOL I +SDEMP S $P(^SC(SC,"S",SD,1,SDY,0),"^",10)=+SDEMP
S SDMADE=1 D EVT Q
HXR W !," Enter YES to have previous XRAY results sent to the clinic" G XR
Q
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!!!",!!
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!!!",!!
K SDCS Q
STATUS(SDCL,SDINP,SDT) ; -- determine status for NEW appts
Q $S(SDINP]"":SDINP,$$CHK(.SDCL,.SDT):"NT",1:"")
CHK(SDCL,SDT) ; -- should appt be NT'ed
; -- non-count clinic check := don't NT appt
; -- appt update executed := need to NT appt
; -- otherwise := don't NT appt
Q $S($P($G(^SC(SDCL,0)),U,17)="Y":0,$D(^SDD(409.65,"AUPD",$P(SDT,"."))):1,1:0)
EVT ; -- separate tag if need to NEW vars
D MAKE^SDAMEVT(DFN,SD,SC,SDY,0)
Q
REQ(SDT) ; -- which is required check in(CI) or out(CO)
Q $S($$REQDT()>SDT:"CI",1:"CO")
REQDT() ; -- co required date
Q $S($P(^DG(43,1,"SCLR"),U,23):$P(^("SCLR"),U,23),1:2931001)
COCMP(DFN,SDT) ; -- date CO completed
Q $P($G(^SCE(+$P($G(^DPT(DFN,"S",SDT,0)),U,20),0)),U,7)
CI(SDCL,SDT,SDDA,SDACT) ; -- ok to update DPT
N C
I '$$CHK(.SDCL,.SDT) G CIQ
I $$REQ(SDT)'="CI" G CIQ
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)=""
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"
CIQ Q
CO(SDCL,SDT,SDDA,SDACT) ; -- ok to update DPT
N DFN,C
I '$$CHK(.SDCL,.SDT) G COQ
I $$REQ(.SDT)'="CO" D G COQ
.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)=""
.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"
S DFN=+^SC(SDCL,"S",SDT,1,SDDA,0)
D UPD(.DFN,.SDT,$$COCMP(.DFN,.SDT),$S(SDACT="SET":X,1:""))
COQ Q
UPD(DFN,SDT,SDCOCMP,SDCODT) ; -- update status
N Y
I $D(^DPT(DFN,"S",SDT,0)) S Y=$P(^(0),U,2) D
.I 'SDCOCMP!('SDCODT) S:Y="" $P(^DPT(DFN,"S",SDT,0),U,2)="NT" Q
.S:Y="NT" $P(^DPT(DFN,"S",SDT,0),U,2)=""
Q
OE(SDOE,SDACT) ; -- called by x-ref on co completed field(#.07) in ^SCE
N Y S Y=^SCE(SDOE,0)
I $P(Y,U,8)'=1 G OEQ
I $$REQ(+Y)'="CO" G OEQ
I '$$CANT(+$P(Y,U,2),+Y,SDOE),'$$CHK(+$P(Y,U,4),+Y) G OEQ
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))
OEQ Q
CONF(SDSRTY,SDSRFU,DFN,SDT,SC) ;Confirm scheduling request type
;Input: SDSRTY=request type
;Input: SDSRFU=follow-up indicator
;Input: DFN=patient ien
;Input: SDT=appointment date/time
;Input: SC=clinic ifn
N DIR,DIE,DA,DR,SDX,SDY,X,Y
S DIR(0)="Y",DIR("B")="YES"
S DIR("A")="THIS APPOINTMENT IS MARKED AS '"_SDSRTY(0)_"', IS THIS CORRECT"
W ! D ^DIR Q:$D(DTOUT)!$D(DUOUT)
I 'Y S SDX='SDSRTY,SDX(0)=$$TXRT(.SDX) W !!,"THIS APPOINTMENT HAS NOW BEEN MARKED AS '"_$S('SDSRTY:"",1:"NOT ")_"NEXT AVAILABLE'."
;S DIR("A")="THIS APPOINTMENT IS DEFINED AS '"_$S(SDSRFU:"FOLLOW-UP",1:"OTHER THAN FOLLOW-UP")_"', OK"
;W ! D ^DIR Q:$D(DTOUT)!$D(DUOUT)
;I 'Y S SDY='SDSRFU W " (changed)"
Q:'$D(SDX) S DR=""
I $D(SDX) S DR="25///^S X=$P(SDX,U,2);26///^S X=$$NAVA^SDMANA(SC,SDT,$P(SDX,U,2))"
;I $D(SDY) S:$L(DR) DR=DR_";" S DR=DR_"26///^S X=SDY"
S DA=SDT,DA(1)=DFN
S DIE="^DPT(DA(1),""S""," D ^DIE
Q
TXRT(SDSRTY) ;Transform request type
;Input: SDSRTY=variable to return request type (pass by reference)
;Output: external text for SDSRTY(0)
I SDSRTY S SDSRTY=SDSRTY_U_"N" Q "NEXT AVAILABLE"
S SDSRTY=SDSRTY_U_"O" Q "NOT NEXT AVAILABLE"
CANT(DFN,SDT,SDOE) ;Determine if clinic appt. has been marked "NT"
;Output: '1' if appt. points to encounter and is marked "NT", otherwise '0'
N SDAPP S SDAPP=$G(^DPT(DFN,"S",SDT,0))
Q:$P(SDAPP,U,20)'=SDOE 0
Q $P(SDAPP,U,2)="NT"
; -- Variable doc for above tags
; SDCL := file 44 ien
; SDT := appt date/time
; DFN := file 2 ien
; SDDA := ^SC(SDCL,"S",SDT,1,SDDA,0)
; SDACT := current x-ref action 'set' or 'kill'
; SDCOCMP := check out completed date
; SDCODT := check out date/time
; SDOE := Outpatient Encounter ien
; SDINP := inpatient status ('I' or null)
; SDINP := inpatient status ('I' or null)
SDM1A ;SF/GFT,ALB/TMP - MAKE APPOINTMENT ; 8/18/05 12:57pm ; 6/22/09 6:16pm
+1 ;;5.3;PIMS;**26,94,155,206,168,223,241,263,327,478,446,1005,1012,1013,1014,1015,1016**;JUN 30, 2012;Build 20
+2 ;IHS/ANMC/LJF 07/06/2000 hard set of date appt made now includes time
+3 ; 12/13/2000 added clear display of appt just made
+4 ; 06/22/2001 added call to create xref on date appt made
+5 ;IHS/OIT/LJF 12/30/2005 PATCH 1005 enhanced OTHER INFO help text
+6 ; 01/06/2006 PATCH 1005 fixed code so OTHER INFO always set correctly
+7 ;cmi/flag/maw 05/14/2010 PATCH 1012 RQMT129, increased length of OTHER INFO
+8 ;ihs/cmi/maw 02/02/2012 patch 1014, changed set of appointment mode to silent fileman call
+9 ;
OK IF $DATA(SDMLT)
DO ^SDM4
IF X="^"!(SDMADE=2)
QUIT
+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
+2 SET ^SC(SC,"ST",$PIECE(SD,"."),1)=S
+3 ;ihs/cmi/maw 02/12/2012 to call UPDATE^DIE
DO SDM^BSDMMU("","",DFN,SD,SC,"","","","","","","","",.BSDER)
+4 SET ^SC(SC,"S",SD,0)=SD
IF '$DATA(^DPT(DFN,"S",0))
SET ^(0)="^2.98P^^"
IF '$DATA(^SC(SC,"S",0))
SET ^(0)="^44.001DA^^"
LOCK
S1 LOCK +^SC(SC,"S",SD,1):$GET(DILOCKTM,5)
IF '$TEST
WRITE "Another user is editing this record. Trying again.",!
IF '$TEST
GOTO S1
FOR SDY=1:1
IF '$DATA(^SC(SC,"S",SD,1,SDY))
IF '$DATA(^(0))
SET ^(0)="^44.003PA^^"
SET ^(SDY,0)=DFN_U_(+SL)_"^^^^"_$GET(DUZ)_U_DT
LOCK -^SC(SC,"S",SD,1)
QUIT
+1 ;NAKED REFERENCE - ^SC(IFN,"S",Date,1,SDY,"OB")
IF SM
SET ^("OB")="O"
+2 IF $DATA(^SC(SC,"RAD"))
IF ^("RAD")="Y"!(^("RAD")=1)
SET ^SC("ARAD",SC,SD,DFN)=""
+3 SET SDINP=$$INP^SDAM2(DFN,SD)
+4 ;-- added sub-category
+5 SET COV=3
SET SDYC=""
SET COV=$SELECT(COLLAT=1:1,1:3)
SET SDYC=$SELECT(COLLAT=7:1,1:"")
+6 IF SD<DT
SET SDSRTY="W"
+7 ;cmi/maw 6/8/2010 PATCH 1012 followup indicator
IF $GET(BSDSRFU)
SET SDSRFU=1
+8 ;
+9 ;ihs/cmi/maw 02/02/2012 patch 1014 direct set no longer used
+10 ;S ^DPT(DFN,"S",SD,0)=SC_"^"_$$STATUS(SC,SDINP,SD)_"^^^^^"_COV_"^^^^"_SDYC_"^^^^^"_SDAPTYP_U_$G(SD17)_"^^"_DT_"^^^^^"_$G(SDXSCAT)_U_$P($G(SDSRTY),U,2)_U_$$NAVA^SDMANA(SC,SD,$P($G(SDSRTY),U,2)) ;IHS/ANMC/LJF 7/06/2000
+11 ;S ^DPT(DFN,"S",SD,0)=SC_"^"_$$STATUS(SC,SDINP,SD)_"^^^^^"_COV_"^^^^"_SDYC_"^^^^^"_SDAPTYP_U_$G(SD17)_"^^"_$$NOW^XLFDT_"^^^^^"_$G(SDXSCAT)_U_$P($G(SDSRTY),U,2)_U_$$NAVA^SDMANA(SC,SD,$P($G(SDSRTY),U,2)) ;IHS/ANMC/LJF 7/06/2000
+12 ;
+13 ;S ^DPT(DFN,"S",SD,1)=$G(SDDATE)_U_$G(SDSRFU)
+14 DO SDM^BSDMMU(COV,SDYC,DFN,SD,SC,SDINP,SDAPTYP,$GET(SD17),$GET(SDXSCAT),$PIECE($GET(SDSRTY),U,2),$$NAVA^SDMANA(SC,SD,$PIECE($GET(SDSRTY),U,2)),$GET(SDDATE),$GET(SDSRFU),.BSDER)
+15 IF $GET(BSDER)]""
Begin DoDot:1
+16 ;ihs/cmi/maw 2/2/2012 patch 1014 for GUI Scheduling
WRITE !,"Error making appointment in file 2.98"
+17 SET MAW="S $ZE=""SDM1A FAILED APPT CALL S1+14"" D ^ZTER"
XECUTE MAW
KILL MAW
End DoDot:1
QUIT
+18 ;ihs/cmi/maw 02/02/2012 following commented lines no longer used patch 1014
+19 ;xref DATE APPT. MADE field
+20 ;D
+21 ;.N DIV,DA,DIK
+22 ;.S DA=SD,DA(1)=DFN,DIK="^DPT(DA(1),""S"",",DIK(1)=20 D EN1^DIK
+23 ;.Q
+24 ;SD/478 MULTI CLINIC OPTION SELECTED
IF $DATA(SDMULT)
SET SDCLNCND=^SC(SC,0)
SET STPCOD=$PIECE(SDCLNCND,U,7)
SET TMPYCLNC=SC_U_$PIECE(SDCLNCND,U)
DO A^SDCNSLT
+25 ;xref DATE APPT. MADE field
+26 ;D
+27 ;.N DIV,DA,DIK
+28 ;.S DA=SD,DA(1)=DFN,DIK="^DPT(DA(1),""S"",",DIK(1)=20 D EN1^DIK
+29 ;.Q
+30 IF $DATA(^DPT(DFN,"S",SD,"R"))
KILL ^("R")
IF $DATA(^DPT("ASDCN",SC,SD,DFN))
KILL ^(DFN)
+31 SET SDRT="A"
SET SDTTM=SD
SET SDPL=SDY
SET SDSC=SC
DO RT^SDUTL
+32 ;
+33 ;W !," ",+SL,"-MINUTE APPOINTMENT MADE" K SDINP ;IHS/ANMC/LJF 12/13/2000
+34 ;IHS/ANMC/LJF 12/13/2000
DO APPT^BSDU2(DFN,SC,SD,+SL)
KILL SDINP
+35 ;ihs/cmi/maw 07/19/2011 patch 1013 doesn't look like this is set if OTHER INFO set to NO
DO XREFC^BSDDAM(SC,SD,SDY)
+36 ;confirm request type & follow-up indicator
+37 IF $DATA(SDSRTY(0))
DO CONF(.SDSRTY,.SDSRFU,DFN,SD,SC)
WRITE !
+38 IF $PIECE(SD,".")'>DT
IF $DATA(^DPT(DFN,.321))
DO EN1^SDM3
+39 ;Wait List SD*5.3*263
+40 ;I '$D(SDWLLIST) D ^SDWLR ;replaced with sd/372, see below
EWLCHK ;check if patient has any open EWL entries (SD/372)
+1 ;get appointment
+2 KILL ^TMP($JOB,"SDAMA301"),^TMP($JOB,"APPT")
+3 DO APPT^SDWLEVAL(DFN,SD,SC)
+4 IF '$DATA(^TMP($JOB,"APPT"))
QUIT
+5 NEW SDEV
DO EN^SDWLEVAL(DFN,.SDEV)
IF SDEV
IF $LENGTH(SDEV(1))>0
Begin DoDot:1
+6 KILL ^TMP("SDWLPL",$JOB),^TMP($JOB,"SDWLPL")
+7 DO INIT^SDWLPL(DFN,"M")
+8 IF '$DATA(^TMP($JOB,"SDWLPL"))
QUIT
+9 DO LIST^SDWLPL("M",DFN)
+10 FOR
IF '$DATA(^TMP($JOB,"SDWLPL"))
QUIT
NEW SDR
DO ANSW^SDWLEVAL(1,.SDR)
IF 'SDR
DO LIST^SDWLPL("M",DFN)
Begin DoDot:2
+11 FOR
NEW SDR
DO ANSW^SDWLEVAL(0,.SDR)
IF '$DATA(^TMP($JOB,"SDWLPL"))
QUIT
IF 'SDR
WRITE !,"MUST ENTER A REASON NOT TO DISPOSITION MATCHED EWL ENTRY",!
End DoDot:2
End DoDot:1
+12 ;CREATE 120 FLAG IF APPLICABLE; appt created
FLG NEW SDST
SET SDST=$GET(^TMP($JOB,"APPT",1))
IF +SDST>0
Begin DoDot:1
+1 ; sd/446
QUIT
+2 ; today's date if no desired date
NEW SDT,SDDES,SDPAR,SDDES1,SDT1
SET SDPAR=0
SET SDT=+SDST
SET SDDES=$PIECE(SDST,U,17)
IF SDDES=""
SET SDDES=DT
+3 SET X=SDT
DO H^%DTC
SET SDT1=%H
+4 SET X=SDDES
DO H^%DTC
SET SDDES1=%H
+5 IF SDT1-SDDES1>120
NEW SD120,SD120A
SET SD120=1
SET SD120A=1
Begin DoDot:2
+6 ; CREATE ewl eN SDPR S SDPR=$S(SDDES=DT:"A",1:"F") entry with 120 flag
+7 ;10
NEW SDPR
SET SDPR=$SELECT(SDDES=DT:"A",1:"F")
+8 ;2
NEW SDWLIN
SET SDWLIN=+$PIECE(SDST,U,15)
+9 ;15
NEW SDWLSCPR
SET SDWLSCPR=0
IF +$PIECE(SDST,U,10)=11
SET SDWLSCPR=1
+10 NEW SC,SDWLSCL
SET SC=+$PIECE(SDST,U,2)
Begin DoDot:3
+11 ;8
IF $DATA(^SDWL(409.32,"B",SC))
SET SDWLSCL=$ORDER(^SDWL(409.32,"B",SC,""))
QUIT
+12 ;create 409.32 entry
+13 NEW DA,DIC
SET DIC(0)="LX"
SET X=SC
SET DIC="^SDWL(409.32,"
DO FILE^DICN
+14 SET SDWLSCL=DA
+15 SET DIE="^SDWL(409.32,"
+16 SET DR=".02////^S X=SDWLIN"
DO ^DIE
+17 SET DR="1////^S X=DT"
+18 SET DR=DR_";2////^S X=DUZ"
+19 DO ^DIE
SET SDPAR=1
End DoDot:3
+20 NEW DA
SET DIC(0)="LX"
SET (X,SDWLDFN)=+$PIECE(SDST,U,4)
SET X=SDWLDFN
SET DIC="^SDWL(409.3,"
DO FILE^DICN
+21 FOR
LOCK +^SDWL(409.3,DA):5
IF $TEST
QUIT
Begin DoDot:3
+22 IF '$TEST
WRITE !,"Unable to acquire a lock on the Wait List file"
QUIT
End DoDot:3
+23 ; Update EWL variables.
+24 ; get enrollee both SDWLDA and SDWLDFN have to be
SET SDWLDA=DA
DO EN^SDWLE11
+25 NEW SDWLCM
SET SDWLCM=" > 120 days; appt created"
+26 NEW SDWLSCPG
SET SDWLSCPG=$SELECT($PIECE($GET(^DPT(SDWLDFN,.3)),U,1)="Y":$PIECE(^(.3),U,2),1:"")
+27 SET DR="1////^S X=DT"
+28 SET DR=DR_";2////^S X=SDWLIN"
+29 SET DR=DR_";4////^S X=4"
+30 SET DR=DR_";8////^S X=SDWLSCL"
+31 SET DR=DR_";9////^S X=DUZ"
+32 SET DR=DR_";10////^S X=SDPR"
+33 ; by patient for this entry to avoid asking for provider
SET DR=DR_";11////^S X=2"
+34 SET DR=DR_";14////^S X=SDWLSCPG"
+35 SET DR=DR_";15////^S X=SDWLSCPR"
+36 SET DR=DR_";22////^S X=SDDES"
+37 SET DR=DR_";23////^S X=""O"""
+38 SET DR=DR_";25////^S X=SDWLCM"
+39 SET DR=DR_";36////^S X=SD120"
+40 SET DR=DR_";39////^S X=SD120A"
+41 SET DIE="^SDWL(409.3,"
+42 DO ^DIE
+43 LOCK -^SDWL(409.3,DA)
+44 DO MESS^SDWL120(SDWLDFN,SC,SDT,SDPAR)
End DoDot:2
End DoDot:1
+45 ;continue appointment entry process
ORD SET %=2
WRITE !,"WANT PATIENT NOTIFIED OF LAB,X-RAY, OR EKG STOPS"
DO YN^DICN
IF '%
WRITE !," Enter YES to notify patient on appt. letter of LAB, X-RAY, or EKG stops"
GOTO ORD
+1 IF '(%-1)
DO ORDY^SDM3
OTHER READ !," OTHER INFO: ",D:DTIME
IF D["^"
WRITE !,*7,"'^' not allowed - hit return if no 'OTHER INFO' is to be entered"
GOTO OTHER
+1 ;SD/478
SET TMPD=D
IF $LENGTH(D)>150
DO MSG^SDMM
GOTO OTHER
+2 ;I $L(D)>150 D MSG^SDMM G OTHER ;cmi/maw 05/14/2010 PATCH 1012 RQMT129 inclreased length of OTHER INFO orig line
+3 ;cmi/maw 05/14/2010 PATCH 1012 RQMT129 inclreased length of OTHER INFO
SET TMPD=D
IF $LENGTH(D)>155
DO MSG^SDMM
GOTO OTHER
+4 ;
+5 ;IHS/OIT/LJF 12/30/2005 PATCH 1005 enhanced help text and removed old MSM restriction on global length
+6 ;I D]"",D?."?"!(D'?.ANP) W " ENTER LAB, SCAN, ETC." G OTHER
+7 IF D]""
IF D?."?"!(D'?.ANP)
WRITE !!,"Enter the Reason for the Appointment. May be up to 155 characters long (no semi-colons or colons).",!
GOTO OTHER
+8 ;I $L(^SC(SC,"S",SD,1,SDY,0))+$L(D)+$L(DT)+$S($D(DUZ):$L(DUZ),1:0)>250 D MSG^SDMM G OTHER
+9 ;
+10 ;IHS/OIT/LJF 01/06/2006 PATCH 1005 naked reference not always set correctly
+11 ;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) ;IHS/ANMC/LJF 7/06/2000
+12 ;S $P(^(0),"^",4)=D,$P(^(0),U,6,7)=$S($D(DUZ):DUZ,1:"")_U_$$NOW^XLFDT D XREFC^BSDDAM(SC,SD,SDY) ;IHS/ANMC/LJF 7/06/2000; 6/22/2001
+13 ;IHS/OIT/LJF 01/06/2006 PATCH 1005
SET $PIECE(^SC(SC,"S",SD,1,SDY,0),"^",4)=D
SET $PIECE(^(0),U,6,7)=$SELECT($DATA(DUZ):DUZ,1:"")_U_$$NOW^XLFDT
DO XREFC^BSDDAM(SC,SD,SDY)
+14 ;
+15 ;SD/478
IF $DATA(TMP)
DO LINK^SDCNSLT(SC,SDY,SD,CNSLTLNK)
+16 ;SD/478
IF $DATA(TMP)
DO EDITCS^SDCNSLT(SD,TMPD,TMPYCLNC,CNSLTLNK)
+17 ;SD/478
KILL TMP
XR IF $SELECT('$DATA(^SC(SC,"RAD")):1,^("RAD")="Y":0,^("RAD")=1:0,1:1)
SET %=2
WRITE !,"WANT PREVIOUS X-RAY RESULTS SENT TO CLINIC"
DO YN^DICN
IF '%
GOTO HXR
IF '(%-1)
SET ^SC("ARAD",SC,SD,DFN)=""
SDMM SET SDEMP=0
IF COLLAT=7
IF SDEC'=SDCOL
SET SDEMP=SDCOL
GOTO OV
+1 DO ELIG^VADPT
IF $ORDER(VAEL(1,0))>0
IF "369"[SDAPTYP
DO ELIG^SDM4
SET SDEMP=$SELECT(SDDECOD:SDDECOD,1:SDEMP)
OV IF $DATA(SDZM)
QUIT
KILL SDQ1,SDEC,SDCOL
IF +SDEMP
SET $PIECE(^SC(SC,"S",SD,1,SDY,0),"^",10)=+SDEMP
+1 SET SDMADE=1
DO EVT
QUIT
HXR WRITE !," Enter YES to have previous XRAY results sent to the clinic"
GOTO XR
+1 QUIT
CS SET SDCS=+$PIECE(^SC(+SC,0),"^",7)
IF $SELECT('$DATA(^DIC(40.7,SDCS,0)):1,'$PIECE(^(0),"^",3):0,1:$PIECE(^(0),"^",3)'>DT)
WRITE !!,*7,"** WARNING - CLINIC HAS AN INVALID OR INACTIVE STOP CODE!!!",!!
+1 SET SDCS=+$PIECE(^SC(+SC,0),"^",18)
IF $SELECT('SDCS:0,'$DATA(^DIC(40.7,SDCS,0)):1,'$PIECE(^(0),"^",3):0,1:$PIECE(^(0),"^",3)'>DT)
WRITE !!,*7,"** WARNING - CLINIC HAS AN INVALID OR INACTIVE CREDIT STOP CODE!!!",!!
+2 KILL SDCS
QUIT
STATUS(SDCL,SDINP,SDT) ; -- determine status for NEW appts
+1 QUIT $SELECT(SDINP]"":SDINP,$$CHK(.SDCL,.SDT):"NT",1:"")
CHK(SDCL,SDT) ; -- should appt be NT'ed
+1 ; -- non-count clinic check := don't NT appt
+2 ; -- appt update executed := need to NT appt
+3 ; -- otherwise := don't NT appt
+4 QUIT $SELECT($PIECE($GET(^SC(SDCL,0)),U,17)="Y":0,$DATA(^SDD(409.65,"AUPD",$PIECE(SDT,"."))):1,1:0)
EVT ; -- separate tag if need to NEW vars
+1 DO MAKE^SDAMEVT(DFN,SD,SC,SDY,0)
+2 QUIT
REQ(SDT) ; -- which is required check in(CI) or out(CO)
+1 QUIT $SELECT($$REQDT()>SDT:"CI",1:"CO")
REQDT() ; -- co required date
+1 QUIT $SELECT($PIECE(^DG(43,1,"SCLR"),U,23):$PIECE(^("SCLR"),U,23),1:2931001)
COCMP(DFN,SDT) ; -- date CO completed
+1 QUIT $PIECE($GET(^SCE(+$PIECE($GET(^DPT(DFN,"S",SDT,0)),U,20),0)),U,7)
CI(SDCL,SDT,SDDA,SDACT) ; -- ok to update DPT
+1 NEW C
+2 IF '$$CHK(.SDCL,.SDT)
GOTO CIQ
+3 IF $$REQ(SDT)'="CI"
GOTO CIQ
+4 IF SDACT="SET"
IF $DATA(^DPT(+^SC(SDCL,"S",SDT,1,SDDA,0),"S",SDT,0))
IF $PIECE(^(0),U,2)="NT"
SET $PIECE(^(0),U,2)=""
+5 IF SDACT="KILL"
SET C=$GET(^SC(SDCL,"S",SDT,1,SDDA,"C"))
IF $DATA(^DPT(+$GET(^(0)),"S",SDT,0))
IF $PIECE(^(0),U,2)=""
IF '$PIECE(C,U,3)
SET $PIECE(^(0),U,2)="NT"
CIQ QUIT
CO(SDCL,SDT,SDDA,SDACT) ; -- ok to update DPT
+1 NEW DFN,C
+2 IF '$$CHK(.SDCL,.SDT)
GOTO COQ
+3 IF $$REQ(.SDT)'="CO"
Begin DoDot:1
+4 IF SDACT="SET"
IF $DATA(^DPT(+^SC(SDCL,"S",SDT,1,SDDA,0),"S",SDT,0))
IF $PIECE(^(0),U,2)="NT"
SET $PIECE(^(0),U,2)=""
+5 IF SDACT="KILL"
SET C=$GET(^SC(SDCL,"S",SDT,1,SDDA,"C"))
IF $DATA(^DPT(+$GET(^(0)),"S",SDT,0))
IF $PIECE(^(0),U,2)=""
IF 'C
SET $PIECE(^(0),U,2)="NT"
End DoDot:1
GOTO COQ
+6 SET DFN=+^SC(SDCL,"S",SDT,1,SDDA,0)
+7 DO UPD(.DFN,.SDT,$$COCMP(.DFN,.SDT),$SELECT(SDACT="SET":X,1:""))
COQ QUIT
UPD(DFN,SDT,SDCOCMP,SDCODT) ; -- update status
+1 NEW Y
+2 IF $DATA(^DPT(DFN,"S",SDT,0))
SET Y=$PIECE(^(0),U,2)
Begin DoDot:1
+3 IF 'SDCOCMP!('SDCODT)
IF Y=""
SET $PIECE(^DPT(DFN,"S",SDT,0),U,2)="NT"
QUIT
+4 IF Y="NT"
SET $PIECE(^DPT(DFN,"S",SDT,0),U,2)=""
End DoDot:1
+5 QUIT
OE(SDOE,SDACT) ; -- called by x-ref on co completed field(#.07) in ^SCE
+1 NEW Y
SET Y=^SCE(SDOE,0)
+2 IF $PIECE(Y,U,8)'=1
GOTO OEQ
+3 IF $$REQ(+Y)'="CO"
GOTO OEQ
+4 IF '$$CANT(+$PIECE(Y,U,2),+Y,SDOE)
IF '$$CHK(+$PIECE(Y,U,4),+Y)
GOTO OEQ
+5 DO UPD(+$PIECE(Y,U,2),+Y,$SELECT(SDACT="SET":X,1:""),$PIECE($GET(^SC(+$PIECE(Y,U,4),"S",+Y,1,+$PIECE(Y,U,9),"C")),U,3))
OEQ QUIT
CONF(SDSRTY,SDSRFU,DFN,SDT,SC) ;Confirm scheduling request type
+1 ;Input: SDSRTY=request type
+2 ;Input: SDSRFU=follow-up indicator
+3 ;Input: DFN=patient ien
+4 ;Input: SDT=appointment date/time
+5 ;Input: SC=clinic ifn
+6 NEW DIR,DIE,DA,DR,SDX,SDY,X,Y
+7 SET DIR(0)="Y"
SET DIR("B")="YES"
+8 SET DIR("A")="THIS APPOINTMENT IS MARKED AS '"_SDSRTY(0)_"', IS THIS CORRECT"
+9 WRITE !
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+10 IF 'Y
SET SDX='SDSRTY
SET SDX(0)=$$TXRT(.SDX)
WRITE !!,"THIS APPOINTMENT HAS NOW BEEN MARKED AS '"_$SELECT('SDSRTY:"",1:"NOT ")_"NEXT AVAILABLE'."
+11 ;S DIR("A")="THIS APPOINTMENT IS DEFINED AS '"_$S(SDSRFU:"FOLLOW-UP",1:"OTHER THAN FOLLOW-UP")_"', OK"
+12 ;W ! D ^DIR Q:$D(DTOUT)!$D(DUOUT)
+13 ;I 'Y S SDY='SDSRFU W " (changed)"
+14 IF '$DATA(SDX)
QUIT
SET DR=""
+15 IF $DATA(SDX)
SET DR="25///^S X=$P(SDX,U,2);26///^S X=$$NAVA^SDMANA(SC,SDT,$P(SDX,U,2))"
+16 ;I $D(SDY) S:$L(DR) DR=DR_";" S DR=DR_"26///^S X=SDY"
+17 SET DA=SDT
SET DA(1)=DFN
+18 SET DIE="^DPT(DA(1),""S"","
DO ^DIE
+19 QUIT
TXRT(SDSRTY) ;Transform request type
+1 ;Input: SDSRTY=variable to return request type (pass by reference)
+2 ;Output: external text for SDSRTY(0)
+3 IF SDSRTY
SET SDSRTY=SDSRTY_U_"N"
QUIT "NEXT AVAILABLE"
+4 SET SDSRTY=SDSRTY_U_"O"
QUIT "NOT NEXT AVAILABLE"
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'
+2 NEW SDAPP
SET SDAPP=$GET(^DPT(DFN,"S",SDT,0))
+3 IF $PIECE(SDAPP,U,20)'=SDOE
QUIT 0
+4 QUIT $PIECE(SDAPP,U,2)="NT"
+5 ; -- Variable doc for above tags
+6 ; SDCL := file 44 ien
+7 ; SDT := appt date/time
+8 ; DFN := file 2 ien
+9 ; SDDA := ^SC(SDCL,"S",SDT,1,SDDA,0)
+10 ; SDACT := current x-ref action 'set' or 'kill'
+11 ; SDCOCMP := check out completed date
+12 ; SDCODT := check out date/time
+13 ; SDOE := Outpatient Encounter ien
+14 ; SDINP := inpatient status ('I' or null)
+15 ; SDINP := inpatient status ('I' or null)
