SDM1A.m

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"