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

ASDF.m

Go to the documentation of this file. 
  1. ASDF ; IHS/ADC/PDW/ENM - IHS FILE ROOM LIST CALLS ;  [ 03/25/1999  11:48 AM ]
  1.  ;;5.0;IHS SCHEDULING;;MAR 25, 1999
  1.  ;
  1.  ; IHS/HQW/KML 2/19/97  replace ^UTILITY with ^TMP per SAC 2.3.2.5
  1.  ; -- select date
  1.  S %DT="AXE",%DT("A")="LIST APPOINTMENTS FOR WHAT DATE: "
  1.  D ^%DT K %DT("A") G QUIT:Y<0 S SDDT=Y
  1.  ;
  1. A ; -- select clinic
  1.  S DIV=""
  1.  D ASK2^SDDIV G:Y<0 QUIT S VAUTNI=1 D CLINIC^VAUTOMA G:Y<0 QUIT
  1.  ;
  1.  ; -- sort by
  1.  W ! K DIR S DIR(0)="SA^T:TERMINAL DIGIT;N:NAME;H:HRCN;P:PRIN CLINIC"
  1.  S DIR("A",1)="ENTER 'N' TO PRINT BY PATIENT NAME ORDER"
  1.  S DIR("A",2)="ENTER 'H' TO PRINT BY HRCN ORDER"
  1.  S DIR("A",3)="ENTER 'P' TO PRINT BY PRINCIPLE CLINIC ORDER"
  1.  S DIR("A")="FILE ROOM LIST ORDER:  ",DIR("B")="TERMINAL DIGIT"
  1.  D ^DIR K DIR G QUIT:$D(DIRUT)
  1.  S ANS=Y
  1.  ;
  1.  ; -- select device
  1.  S DGVAR="VAUTD#^VAUTC#^DIV^ANS^SDDT",PGM="START^SDF"
  1.  D ZIS^DGUTQ G QUIT:POP
  1.  I '$D(IO("Q")) D START^SDF I IOST["C-" D PRTOPT^ASDVAR
  1.  Q
  1.  ;
  1. CLIN ;EP; called by SDF for selected clinics
  1.  S A=0 F  S A=$O(VAUTC(A)) Q:A=""  D
  1.  . S C=VAUTC(A)
  1.  . I $D(^SC(C,0)),$S('$D(^SC(C,"I")):1,+^("I")=0:1,+^("I")>SDDT:1,+$P(^("I"),"^",2)'>SDDT&(+$P(^("I"),"^",2)'=0):1,1:0) D AHEAD^SDF
  1.  G LST^SDF
  1.  ;
  1.  ;
  1. C ;EP; called by SDF for IHS version of subrtn
  1.  ; to handle additional types of sorts
  1.  NEW ASDP
  1.  S DA=$S(ANS="N":$P(^DPT(+X,0),U),ANS="H":$$HR(+X),1:$$TD(+X))
  1.  S X=$P(X_"^^^^^",U,1,5)
  1.  S ASDP=$S(ANS="P":$$P,1:$P(^SC(C,0),U))
  1.  I $D(^DPT(+X,"S",D,0)) D
  1.  . S SDAPTT=$P(^DPT(+X,"S",D,0),U,16)
  1.  . I $P(^DPT(+X,"S",D,0),U,2)["C"!($P(^SC(C,SC,D,1,P,0),U,9)="C") S X=X_"^***CANCELLED!***"
  1.  S ^TMP($J,ASDP," "_DA,+X,D)=C_U_X
  1.  S $P(^TMP($J,ASDP," "_DA,+X,D),U,8)=$S($D(^DPT(+X,.1)):^(.1),1:"")
  1.  I $D(^DPT(+X,.36)),$D(^DIC(8,+^DPT(+X,.36),0)),$P(^(0),U,9)=13 D  Q
  1.  . S $P(^TMP($J,ASDP," "_DA,+X,D),U,9)="** COLLATERAL **"
  1.  I SC="S",$P(^SC(C,SC,D,1,P,0),U,10)]"" D
  1.  . S V=$P(^SC(C,SC,D,1,P,0),U,10),V=$S($D(^DIC(8,+V,0)):$P(^(0),U,9)=13,1:0)
  1.  . I V S $P(^TMP($J,ASD," "_DA,+X,D),U,9)="** COLLATERAL **"
  1.  S $P(^TMP($J,ASDP," "_DA,+X,D),U,10)=$S('$D(SDAPTT):"",$D(^SD(409.1,+SDAPTT,0)):$P(^(0),U,4),1:"")
  1.  K V Q
  1.  ;
  1. O ;EP; called by SDF for IHS version of subrtn
  1.  D:SDHED!($Y+2>IOSL) WHED S Y=^TMP($J,SC,DA,X,C) N DFN S DFN=X
  1.  W !?3,$$HRCN^ASDUT,?12,$E($P(D,U,1),1,23),?37,$$DOB($P(D,U,3))
  1.  I ANS="P" W ?57,$P($G(^SC(+Y,0)),U,2) ;indiv clinic
  1.  W ?62,"at " S T=$P(C,".",2)_"000" I T W $E(T,1,2),":",$E(T,3,4),!
  1.  I $P(Y,U,8)]"" W ?48,"** WARD: ",$P(Y,U,8)," **"
  1.  I $P(Y,U,7)]"" W !,?4,$P(Y,U,7)
  1.  I $P(Y,U,9)]"" W !,?4,$P(Y,U,9)
  1.  Q
  1.  ;
  1. WHED S SDHED=0 W !,@IOF,!?16,$$CONF^ASDUT
  1.  W !?9,"FILE ROOM LIST FOR APPOINTMENTS "
  1.  S Y=SDDT D DT^DIQ W !,?30-($L(SC)\2),SC,?55,"PRINTED: "
  1.  S Y=DT D DT^DIQ W !!
  1.  Q
  1.  ;
  1. QUIT ;
  1.  K VAUTC,VAUTD,DGJ,%,%DT,A,AA,ALL,ANS,C,CC,D,DA,DIV,DTOUT,I,P,PGM
  1.  K POP,SC,SDAPTT,SDDT,SDHED,SDSCN,T,VAL,VAR,X,Y,Z,^TMP($J)
  1.  Q
  1.  ;
  1. P() ; -- principle clinic
  1.  Q $S($P($G(^SC(+C,"SL")),U,5):$P(^SC(+$P($G(^SC(+C,"SL")),U,5),0),U),1:$P(^SC(C,0),U))
  1.  ;
  1. DOB(Y) ; -- date of birth
  1.  Q "DOB: "_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)
  1.  ;
  1. HR(DFN) ; -- health record number
  1.  Q $$HRCN^ASDUT
  1.  ;
  1. TD(X,Y) ; -- terminal digit
  1.  S Y=$$HRN^ASDUT(+X) Q $P(Y,"-",3)_$P(Y,"-",2)