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

SDAMWI1.m

Go to the documentation of this file. 
  1. SDAMWI1 ;ALB/MJK - Walk-Ins (cont.) ; 31 Dec 99  6:30 PM
  1.  ;;5.3;Scheduling;**94,167,206,168,1006,1009,1010,1012,1015,1016**;Aug 13, 1993;Build 20
  1.  ;IHS/ANMC/LJF 7/06/2000 added call to IHS routing slip code
  1.  ;                       hard set of date appt made now includes time
  1.  ;            11/29/2000 added call to enter other info
  1.  ;            11/01/2001 added default to routing slip question
  1.  ;IHS/OIT/LJF  09/21/2006 PATCH 1006 don't ask to print RS if not checked in
  1.  ;cmi/anch/maw  04/07/2008 PATCH 1009 requirement 61 added check of default prompt for printing routing slips
  1.  ;cmi/anch/maw  05/04/2009 PATCH 1010 added check of default prompt if no DIV
  1.  ;cmi/flag/maw  06/17/2010 PATCH 1012 added setting of date appointment made xref for walkins RQMT147
  1.  ;ihs/cmi/maw 10/23/2012 PATCH 1016 added call to BSDMMU in MAKE for BMW software
  1.  ;
  1. MAKE(DFN,SDCL,SDT) ; -- set globals for appt
  1.  ;    input:     DFN ; SDCL := clinic# ; SDT := appt d/t
  1.  ; returned: success := 1
  1.  ;
  1.  N SD,SDINP,SC,DA,DIK
  1.  S SC=SDCL,X=SDT,SDINP=$$INP^SDAM2(DFN,SDT)
  1.  S SD=SDT D EN1^SDM3
  1.  S:'$D(^DPT(DFN,"S",0)) ^(0)="^2.98P^^"
  1.  ;S ^DPT(DFN,"S",SDT,0)=SC_"^"_$$STATUS^SDM1A(SC,SDINP,SDT)_"^^^^^4^^^^^^^^^"_SDAPTYP_"^^^"_DT_"^^^^^"_$G(SDXSCAT)_"^W^0"
  1.  ;S ^DPT(DFN,"S",SDT,0)=SC_"^"_$$STATUS^SDM1A(SC,SDINP,SDT)_"^^^^^4^^^^^^^^^"_SDAPTYP_"^^^"_$$NOW^XLFDT_"^^^^^"_$G(SDXSCAT)_"^W^0"   ;IHS/ANMC/LJF 7/06/2000
  1.  D SDM^BSDMMU(4,"",DFN,SD,SC,SDINP,SDAPTYP,"",$G(SDXSCAT),"W",0,"","",.BSDER)  ;ihs/cmi/maw 10/23/2012 to call UPDATE^DIE
  1.  I $G(BSDER)]"" W !,"Error making appointment in file 2.98" Q  ;ihs/cmi/maw 10/23/2012 patch 1016 for GUI Scheduling
  1.  ;xref DATE APPT. MADE field
  1.  D
  1.  .N DIV
  1.  .S DA=SDT,DA(1)=DFN,DIK="^DPT(DA(1),""S"",",DIK(1)=20 D EN1^DIK
  1.  .Q
  1.  ;F I=1:1 I '$D(^SC(SC,"S",SDT,1,I)) S:'$D(^(0)) ^(0)="^44.003PA^^" S ^(I,0)=DFN_"^"_SDSL_"^^^^"_DUZ_"^"_DT,^SC(SC,"S",SDT,0)=SDT,SDDA=I D RT,EVT,DUAL,ROUT(DFN) Q
  1.  ;F I=1:1 I '$D(^SC(SC,"S",SDT,1,I)) S:'$D(^(0)) ^(0)="^44.003PA^^" S ^(I,0)=DFN_"^"_SDSL_"^^^^"_DUZ_"^"_$$NOW^XLFDT,^SC(SC,"S",SDT,0)=SDT,SDDA=I S X=$$OI^BSDAM(SC,SDT,I,DFN) D RT,EVT,DUAL,ROUT(DFN) Q   ;IHS/ANMC/LJF 7/06/2000;11/29/2000
  1.  ;cmi/maw PATCH1012 RQMT147 begin mods
  1.  F I=1:1 I '$D(^SC(SC,"S",SDT,1,I)) S:'$D(^(0)) ^(0)="^44.003PA^^" S ^(I,0)=DFN_"^"_SDSL_"^^^^"_DUZ_"^"_$$NOW^XLFDT,^SC(SC,"S",SDT,0)=SDT,SDDA=I S X=$$OI^BSDAM(SC,SDT,I,DFN) D RT,EVT,DUAL,ROUT(DFN),XREFC($S($G(SC):SC,1:$G(SDCL)),SDT,SDDA) Q
  1.  ;cmi/maw PATCH1012 RQMT147 end mods
  1.  ;update availability grid
  1.  N HSI,SDDIF,SI,SL,STARTDAY,STR,SDNOT,X,SB,Y,S,I,ST,SS,SM
  1.  S SD=SDT,SC=SDCL
  1.  I '$D(^SC(SC,"ST",$P(SD,"."),1)) Q 1
  1.   S SL=^SC(+SC,"SL"),X=$P(SL,U,3),STARTDAY=$S($L(X):X,1:8),SB=STARTDAY-1/100,X=$P(SL,U,6),HSI=$S(X=1:X,X:X,1:4),SI=$S(X="":4,X<3:4,X:X,1:4),STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz",SDDIF=$S(HSI<3:8/HSI,1:2) K Y
  1. SC L +^SC(SC,"ST",$P(SD,"."),1):5 G:'$T SC S S=^SC(SC,"ST",$P(SD,"."),1) S I=SD#1-SB*100,ST=I#1*SI\.6+($P(I,".")*SI),SS=SL*HSI/60*SDDIF+ST+ST G C:(I<1!'$F(S,"["))&(S'["CAN")
  1.  S SM=0
  1.  I SM<7 S %=$F(S,"[",SS-1) S:'%!($P(SL,"^",6)<3) %=999 I $F(S,"]",SS)'<%!(SDDIF=2&$E(S,ST+ST+1,SS-1)["[") S SM=7
  1. SP I ST+ST>$L(S) S S=S_"  " G SP
  1.  S SDNOT=1 F I=ST+ST:SDDIF:SS-SDDIF S ST=$E(S,I+1) S:ST="" ST=" " S Y=$E(STR,$F(STR,ST)-2) G C:S["CAN"!(ST="X"&($D(^SC(+SC,"ST",$P(SD,"."),"CAN")))),C:Y="" S:Y'?1NL&(SM<6) SM=6 S ST=$E(S,I+2,999) S:ST="" ST=" " S S=$E(S,1,I)_Y_ST
  1.  S ^SC(+SC,"ST",$P(SD,"."),1)=S
  1. C L -^SC(+SC,"ST",$P(SD,"."),1)
  1.  Q 1
  1.  ;
  1. RT ; -- request record
  1.  S SDRT="A",SDTTM=SDT,SDPL=I,SDSC=SC D RT^SDUTL
  1.  Q
  1.  ;
  1. ROUT(DFN) ; -- print routing slip
  1.  ;
  1.  ;IHS/OIT/LJF 09/21/2006 PATCH 1006 don't ask if not checked in
  1.  I '$$CI^BSDU2(DFN,SC,SDT) Q
  1.  ;
  1.  ;IHS/ANMC/LJF 7/06/2000; 11/01/2001; 1/03/2002 IHS lines added
  1.  ;Q:'$$READ^BDGF("Y","OKAY TO PRINT A ROUTING SLIP IN MEDICAL RECORDS NOW","YES")  ;cmi/maw 4/7/2008 orig line
  1.  N BSDPAR  ;cmi/maw 5/4/2009 patch 1010
  1.  S BSDPAR=$O(^BSDPAR("B",0))  ;cmi/maw 5/4/2009 patch 1010
  1.  I $G(DIV) Q:'$$READ^BDGF("Y","OKAY TO PRINT A ROUTING SLIP IN MEDICAL RECORDS NOW",$S($P($G(^BSDPAR(DIV,0)),U,24):"YES",1:"NO"))  ;cmi/maw 4/7/2008 PATCH 1009
  1.  I '$G(DIV) Q:'$$READ^BDGF("Y","OKAY TO PRINT A ROUTING SLIP IN MEDICAL RECORDS NOW",$S($P($G(^BSDPAR(BSDPAR,0)),U,24):"YES",1:"NO"))  ;cmi/maw 5/4/2009 patch 1010
  1.  K IOP S (SDX,SDSTART,ORDER,SDREP)=""
  1.  D WISD^BSDROUT(DFN,SDT,"WI",$G(BSDDEV))
  1.  Q
  1.  ;IHS/ANMC/LJF end of IHS mods
  1.  ;
  1.  S DIR("A")="DO YOU WANT TO PRINT A ROUTING SLIP NOW",DIR(0)="Y"
  1.  W ! D ^DIR K DIR G ROUTQ:$D(DIRUT)!(Y=0)
  1.  K IOP S (SDX,SDSTART,ORDER,SDREP)="" D EN^SDROUT1
  1. ROUTQ Q
  1.  ;
  1. DUAL ; -- ask elig if pt has more than one
  1.  I $O(VAEL(1,0))>0 S SDEMP="" D ELIG^SDM4:"369"[SDAPTYP S SDEMP=$S(SDDECOD:SDDECOD,1:SDEMP) I +SDEMP S $P(^SC(SC,"S",SDT,1,I,0),"^",10)=+SDEMP K SDEMP
  1.  Q
  1.  ;
  1. EVT ; -- separate if need to NEW vars
  1.  N I,DIV D MAKE^SDAMEVT(DFN,SDT,SDCL,SDDA,0)
  1.  Q
  1.  ;
  1. XREFC(C,D,N) ;-- set the date appointment made cross reference patch 1012
  1.  D XREFC^BSDDAM(C,D,N)
  1.  Q