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

ASDM.m

Go to the documentation of this file. 
  1. ASDM ; IHS/ADC/PDW/ENM - IHS CHANGES TO MAKE APPT ;  [ 03/25/1999  11:48 AM ]
  1.  ;;5.0;IHS SCHEDULING;;MAR 25, 1999
  1.  ;
  1. PAT ;EP; called by SDM to ask patient
  1.  Q:$D(ORACTION)  S DFN="" K DIV
  1.  Q:$G(SDPEP)
  1.  S DIC="^DPT(",DIC(0)="AQZME" D ^DIC K DIC Q:X=""  Q:X=U  G PAT:Y<1
  1.  S DFN=+Y
  1.  W !?5,$$FIELDNM(9000001,.14),": ",$$PCP^ASDUT(DFN)
  1.  D ^ASDREG
  1.  Q
  1.  ;
  1. SPEC ;EP; called by SDM1 to print special instructions
  1.  NEW I,IORVON,IORVOFF
  1.  S X="IORVON;IORVOFF" D ENDR^%ZISS
  1.  I $D(^SC(SC,"SI")),$O(^("SI",0)) D
  1.  . W !,*7,?20,IORVON,"**** SPECIAL INSTRUCTIONS ****",IORVOFF,!
  1.  . S I=0 F  S I=$O(^SC(SC,"SI",I)) Q:'I  W IORVON,^(I,0),IORVOFF,!
  1.  Q
  1.  ;
  1. RS ;EP; -- routing slip
  1.  NEW %
  1.  Q:$P($G(^DG(40.8,$$DIV^ASDUT,"IHS")),U)'=1
  1.  S %=2 W !,"WANT TO PRINT AN APPOINTMENT SLIP NOW"
  1.  D YN^DICN I '% W !,"RESPOND YES OR NO" G RS
  1.  I (%-1) W:%<0 " NO" Q
  1.  S DIV="" D DIV^SDUTL I $T D ROUT^SDDIV Q:Y<0
  1.  K IOP S (SDX,SDSTART,ORDER,SDREP,SDZMK)="",(SDZHS,SDZEF,SDZAI,SDZMP)=1
  1.  D EN^SDROUT1
  1.  K SDZHS,SDZEF,SDZAI,SDZMP,SDZMK
  1.  Q
  1.  ;
  1. HS ; -- health summary
  1.  ; -- calling rtn can send % set to default answer
  1.  S SDZHS="" W !,"WANT TO PRINT HEALTH SUMMARY NOW" D YN^DICN
  1.  I '% W !,"RESPOND YES OR NO" G HS
  1.  I (%-1) W:%<0 " NO" S SDZHS=1 Q
  1.  S SDZHS=0
  1.  Q
  1.  ;
  1. PEND ;PEP; called by SDM & AMER1 to display pending appts
  1.  W:$O(^DPT(DFN,"S",DT))'>DT !,"NO PENDING APPOINTMENTS"
  1.  I $O(^DPT(DFN,"S",DT))>DT D
  1.  . S X="Y" W !!?20,"**** PENDING APPOINTMENTS ****",!
  1.  I  F Y=DT:0 S Y=$O(^DPT(DFN,"S",Y)) Q:Y'>0  D
  1.  . I "I"[$P(^DPT(DFN,"S",Y,0),U,2) D
  1.  .. D CHKSO^SDM W:$X>9 ! W ?11 D DT^SDM0 W ?32 S DA=+SSC
  1.  .. W SDLN,$S($D(^SC(DA,0)):$P(^(0),U),1:"DELETED CLINIC ")
  1.  D WARD,NOSHOW Q
  1.  ;
  1. WARD ;EP; called if only inpat status needed
  1.  S SDW=""
  1.  I $D(^DPT(DFN,.1)) S SDW=^(.1) D
  1.  . W !!?10,*7,"*** NOTE - PATIENT IS NOW IN "_SDW_" WARD ***",!
  1.  Q
  1.  ;
  1. NOSHOW ; -- called to print # noshows for patient
  1.  NEW SDATE,SDATE2,X1,X2,X,TOTL,NOCLN,LMT,LMT2,SDPC,PCNT
  1.  Q:'$G(DFN)  Q:'$G(SC)
  1.  S SDPC=$P($G(^SC(+SC,"SL")),U,5) ;princ clinic
  1.  S (TOTL,NOCLN,PCNT)=0
  1.  S LMT=$$VAL^XBDIQ1(40.8,$$DIV^ASDUT,9999999.15)
  1.  S LMT2=$$VAL^XBDIQ1(44,+SC,9999999.6),LMT2=$S(LMT2="":LMT,1:LMT2)
  1.  S X1=DT,X2=-$S(LMT]"":LMT,1:365) D C^%DTC S SDATE=X
  1.  S X1=DT,X2=-LMT2 D C^%DTC S SDATE2=X
  1.  F  S SDATE=$O(^DPT(DFN,"S",SDATE)) Q:'SDATE  D
  1.  . Q:$P(^DPT(DFN,"S",SDATE,0),U,2)'["N"  S TOTL=TOTL+1
  1.  F  S SDATE2=$O(^DPT(DFN,"S",SDATE2)) Q:'SDATE2  D
  1.  . Q:$P(^DPT(DFN,"S",SDATE2,0),U,2)'["N"
  1.  . I +^DPT(DFN,"S",SDATE2,0)=+SC S NOCLN=NOCLN+1
  1.  . I SDPC]"",$D(^SC("AIHSPC",+SDPC,+^DPT(DFN,"S",SDATE2,0))) S PCNT=PCNT+1
  1.  I TOTL>0!(NOCLN>0)!(PCNT>0) D
  1.  . W !!,"Total No-shows (ALL clinics) in last ",LMT\30," months:",?50,TOTL
  1.  . I SDPC]"" W !,"No-shows in principal clinic (last ",LMT2\30," months):",?50,PCNT
  1.  . W !,"No-shows in this clinic (last ",LMT2\30," months):",?50,NOCLN,!
  1.  Q
  1.  ;
  1. EN2 ;EP; called by SDM
  1.  NEW X,SDOK
  1.  S X=0 F  S X=$O(^DPT(DFN,"DE",X)) Q:'X  Q:'$D(^(X,0))  D
  1.  . I ^DPT(DFN,"DE",X,0)-SC=0!'(^(0)-Y) D
  1.  .. S XX=0 F  S XX=$O(^DPT(DFN,"DE",X,1,XX)) Q:XX<1  Q:$D(SDOK)  D
  1.  ... S SDDIS=$P(^DPT(DFN,"DE",X,1,XX,0),U,3) S:'SDDIS SDOK=""
  1.  .. G ^SDM0:'SDDIS
  1.  I '$D(^SC(+Y,0)) S Y=+SC
  1.  S Y=$P(^SC(Y,0),U)
  1.  S SDY=Y
  1.  S X="NOW" S %DT="EXT" D ^%DT S HEY=Y
  1.  S DA=DFN,DR="3///"_SDY,(DIE,DIC)="^DPT(",DP=2
  1.  S DR(2,2.001)=".01///"_SDY_";1///"_HEY
  1.  S DR(3,2.011)=".01///"_HEY_";S DIE(""NO^"")="""";1////O"
  1.  L +^DPT(DFN,"DE"):3 I '$T D  Q
  1.  . W !,*7,"PATIENT ENTRY LOCKED; TRY AGAIN SOON"
  1.  D ^DIE K DR,DP L -^DPT(DFN,"DE")
  1.  G ^SDM0:'$D(Y)
  1.  Q
  1.  ;
  1. QUES1 ;EP; called by SDM1 for date/time help   
  1.  W !?5,"Enter a DATE & TIME for the appointment (ex. 11/2@0930)"
  1.  W !?5,"OR enter ""M"" to see the next month's availability"
  1.  W !?5,"OR enter ""L"" to list appointments for a specific date"
  1.  W !?5,"OR enter ""S"" to see a shortened list of appts for a date"
  1.  W !?5,"OR enter ""B"" to backup to choose another starting date"
  1.  W !?10,"and to see the patient's pending appointments again"
  1.  W !?5,"OR press RETURN to choose another clinic.",!
  1.  Q
  1.  ;
  1. OTHER ;EP -- other info; called by ^SDI
  1.  W ! K DIE,DIC
  1.  S DIE="^SC("_SC_",""S"","_SDPR_",1,",DA=I,DA(1)=SDPR,DA(2)=SC,DR="3T"
  1.  I $D(SDZPL) S DR="3///^S X=SDZPL"
  1.  L +^SC(SC,"S",SDPR):3 I '$T D  G OTHER
  1.  . W !,*7,"APPOINTMENT ENTRY LOCKED; TRY AGAIN"
  1.  D ^DIE L -^SC(SC,"S",SDPR) Q
  1.  ;
  1. LIST(SC,TYPE) ;EP -- list appointments; called by SDM1
  1.  NEW A,ALL,DFN,DIC,I,INC,K,M,PCNT,POP,PT,SD,SD1,SDB,SDCC,SDCP,SDD
  1.  NEW SDEM1,SDDIF,SDDIF1,SDEA,SDEC,SDEDT,SDEM,SDEND,SDFL,SDFS,SDIN
  1.  NEW SDNT,SDOI,SDPD,SDREV,SDT,SDTT,SDX,SDXX,SDZ,VADAT,VADATE,VAUTC
  1.  NEW VAUTD,VAQK,X,Y,Y1,Y2,Z
  1.  S VAUTC=0,VAUTD=0,VAUTC($P(^SC(SC,0),U))=SC,M=1
  1.  S VAUTD(+$O(^DG(40.8,"C",DUZ(2),0)))=$P(^DG(40.8,$O(^(0)),0),U)
  1.  K DIC("S") S %DT("A")="LIST APPOINTMENTS FOR WHICH DATE: ",%DT="AEXF"
  1.  D ^%DT K %DT,% I (X["^")!(Y<0) Q
  1.  I TYPE=1 S SDD=Y D START^SDAL Q
  1.  I TYPE=2 D SHORT^ASDAL(SC,Y) Q
  1.  ;
  1. FIELDNM(F,N) ; -- returns field name from file
  1.  Q $P($G(^DD(F,N,0)),U)