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

ASDROUT0.m

Go to the documentation of this file. 
  1. ASDROUT0 ; IHS/ADC/PDW/ENM - ROUTING SLIPS PRINT ;  [ 11/13/2002  9:31 AM ]
  1.  ;;5.0;IHS SCHEDULING;**8**;MAR 25, 1999
  1.  ;rewrite of VA rtn SDROUT0
  1.  ;  need to use non-namespaced variables for calls to other VA rtns
  1.  ;IHS/ITSC/KMS, 13-Nov-2002 - Patch 8 - Cache' compliancy
  1.  ;
  1. GOT ;EP; -- SUBRTN to set up ^utility sort of patient appts
  1.  S DFN=$P(^SC(SC,"S",GDATE,1,L,0),U)
  1.  S POP=1 D CKP Q:POP
  1.  S NAME=$P(^DPT(DFN,0),U)
  1.  S TDO=$$HRN^ASDUT(DFN),TDO=$P(TDO,"-",3)_$P(TDO,"-",2)
  1.  D ^SDROUT1
  1.  I ORDER=1 D TDO Q
  1.  I ORDER=2 D CLO Q
  1.  I ORDER=3 D PCO Q
  1.  D NMO Q
  1.  ;
  1. TDO ; -- sort by terminal digit
  1.  D COL
  1.  S ^TMP("SDRS",$J," "_TDO,DFN,GDATE,SC)=$S(V:"** COLLATERAL **",1:"") Q
  1.  ;
  1. CLO ; -- sort by clinic
  1.  D COL S SCN=$S($D(^SC(SC,0)):$P(^(0),U),1:SC)
  1.  S ^TMP("SDRS",$J,"A",SCN," "_TDO,DFN)=SC_$S(V:"^** COLLATERAL **",1:"")
  1.  S ^TMP("SDRS",$J,"B",DFN,GDATE)=SC K V Q
  1.  ;
  1. PCO ; -- sort by principal clinic
  1.  NEW SCZ S SCZ=$P($G(^SC(SC,"SL")),U,5),SCZ=$S(+SCZ:SCZ,1:SC)
  1.  D COL S SCN=$S($D(^SC(SCZ,0)):$P(^(0),U),1:SCZ)
  1.  S ^TMP("SDRS",$J,"A",SCN," "_TDO,DFN)=SC_$S(V:"^** COLLATERAL **",1:"")
  1.  S ^TMP("SDRS",$J,"B",DFN,GDATE)=SC K V Q
  1.  ;
  1. NMO ; -- sort by name
  1.  D COL
  1.  S ^TMP("SDRS",$J,NAME,DFN,GDATE,SC)=$S(V:"** COLLATERAL **",1:"") K V Q
  1.  ;
  1. COL ; -- ??
  1.  S V=0 I $P(^SC(SC,"S",GDATE,1,L,0),U,10)]"" D
  1.  . S V=$P(^SC(SC,"S",GDATE,1,L,0),U,10)
  1.  . S V=$S($D(^DIC(8,+V,0)):$P(^(0),U,9)=13,1:0)
  1.  Q
  1.  ;
  1. CKP ; -- check to see if rs should be printed for patient
  1.  I SDREP D CKP1 Q
  1.  I $S('$D(^DPT(DFN,"S",GDATE,0)):1,$P(^(0),U,2)["C":1,1:0) S POP=1 Q
  1.  I $S($D(SDI1):1,SDX["ALL":1,SDIQ=1:1,$P(^DPT(DFN,"S",GDATE,0),U,6)'["Y":1,1:0) S POP=0 Q
  1.  I $P(^DPT(DFN,"S",GDATE,0),U,6)="Y",$$NEW1 S POP=0 Q
  1.  Q
  1.  ;
  1. CKP1 ; -- check if rs should be included in reprint
  1.  I $S('$D(^DPT(DFN,"S",GDATE,0)):1,$P(^(0),U,2)["C":1,1:0) S POP=1 Q
  1.  I SDX["ALL" S POP=0 Q
  1.  I $P(^DPT(DFN,"S",GDATE,0),U,13)']""!($P(^(0),U,13)=SDSTART) S POP=0,$P(^(0),U,13)=SDSTART Q
  1.  S POP=1 Q
  1.  ;
  1.  ;
  1.  ;
  1. GO ;EP; called to print r slips
  1.  S SDCNT=0 D GO1
  1.  I ORDER=2!(ORDER=3) D CLIN Q
  1.  ;
  1.  ; term digit or name order
  1.  F  S I=$O(^TMP("SDRS",$J,I)) Q:I=""  D
  1.  . S J=0 F  S J=$O(^TMP("SDRS",$J,I,J)) Q:J=""  D
  1.  .. S P=0,SDZ=0
  1.  .. D PRINT(I,J),CNT Q:$D(SDZMK)  ;one rs for chart room or mk appt
  1.  .. I $D(SDZCV) D PRINT(I,J):$$RS2 D OTHER Q  ;walk-in visit
  1.  .. I $$RS2 S K=0 F  S K=$O(^TMP("SDRS",$J,I,J,K)) Q:K=""  D
  1.  ... S L=0 F  S L=$O(^TMP("SDRS",$J,I,J,K,L)) Q:L=""  D
  1.  .... D PRINT(I,J),CNT ;one rs for each appt
  1.  .. D OTHER
  1.  D END^SDROUT1
  1.  Q
  1.  ;
  1. GO1 ; -- SUBRTN to initialize sort
  1.  S I=0 Q:'SDREP!(SDX'["ALL")!(SDSTART="0000")
  1.  I SDSTART?4N D  Q  ;term digit
  1.  . S SDZ=(SDSTART-1)/10000,SDZ=$P(SDZ,".",2)
  1.  . S SDZ=SDZ_$E("0000",1,4-$L(SDZ)),I=" "_SDZ K SDZ
  1.  ;
  1.  I '$D(^TMP("SDRS",$J,SDSTART)) S I=SDSTART Q
  1.  S SDZ=$A($E(SDSTART,$L(SDSTART)))
  1.  S I=$E(SDSTART,1,$L(SDSTART)-1)_$C(SDZ-1) K SDZ
  1.  Q
  1.  ;
  1. CLIN ; -- SUBRTN to print by clinic
  1.  F  S I=$O(^TMP("SDRS",$J,"A",I)) Q:I=""  D
  1.  . S SDTD=0 F  S SDTD=$O(^TMP("SDRS",$J,"A",I,SDTD)) Q:SDTD=""  D
  1.  .. S J=0 F  S J=$O(^TMP("SDRS",$J,"A",I,SDTD,J)) Q:J=""  D
  1.  ... I ^TMP("SDRS",$J,"A",I,SDTD,J) D
  1.  .... S SC=+^TMP("SDRS",$J,"A",I,SDTD,J),P=0
  1.  .... D PRINT2(I,J) D CNT D:$$RS2 PRINT2(I,J) D OTHER
  1.  W:IOF]"" !,@IOF D END^SDROUT1
  1.  Q
  1.  ;
  1. PRINT2(I,J) ; -- SUBRTN to print rs by clinic
  1.  NEW K,L
  1.  I SDCNT>0 W @IOF
  1.  D HED^SDROUT2,HD^SDROUT2 S K=0
  1.  F  S K=$O(^TMP("SDRS",$J,"B",J,K)) D:K="" FUT  Q:K=""  D
  1.  . S (SDZ,L)=^TMP("SDRS",$J,"B",J,K) D LIN,X1
  1.  Q
  1.  ;
  1. PRINT(I,J) ; -- SUBRTN to print a routing slip based on patient ifn J
  1.  NEW K,L
  1.  I SDCNT>0 W @IOF
  1.  D HED^SDROUT2,HD^SDROUT2
  1.  S K=0 F  S K=$O(^TMP("SDRS",$J,I,J,K)) D:K="" FUT Q:K=""  D
  1.  . S L=0 F  S L=$O(^TMP("SDRS",$J,I,J,K,L)) Q:L=""  D LIN,X
  1.  Q
  1.  ;
  1. LIN ; -- SUBRTN to print individual appointments
  1.  S X=K D TM W !,$J(X,8)
  1.  I $D(^SC(L,0)) D
  1.  . W ?11,$P(^SC(L,0),U)
  1.  . D LOC W:$$SHORT^ASDROUT2 !?11 W:'$$SHORT^ASDROUT2 ?42
  1.  . W SDLOC K SDLOC
  1.  . D:$D(^DPT(J,"S",K,0)) SETP(J,K)
  1.  . W:'$D(^DPT(J,"S",K,0)) ?70,"*DELETED*"
  1.  . D SCCOND^SDROUT2
  1.  W:'$D(^SC(L,0)) ?11,L
  1.  ;
  1.  NEW X S X=0 F  S X=$O(^SC(L,"S",K,1,X)) Q:'X  D
  1.  . Q:$P(^SC(L,"S",K,1,X,0),U)'=J
  1.  . W:$P(^SC(L,"S",K,1,X,0),U,4)'="" !,?11,$P(^(0),U,4)
  1.  D:$Y>(IOSL-5) HED^SDROUT2
  1.  Q
  1.  ;
  1. X ; -- SUBRTN to print extra info
  1.  I $P(^TMP("SDRS",$J,I,J,K,L),U)]"" W !,?4,$P(^(L),U) Q
  1.  I $D(^DPT(+J,.36)),$D(^DIC(8,+^DPT(+J,.36),0)),$P(^(0),U,9)=13 W !,?4,"** COLLATERAL **"
  1.  Q
  1.  ;
  1. X1 ; -- SUBRTN to print extra info
  1.  I $P(^TMP("SDRS",$J,"A",I,SDTD,J),U,2)]"" W !,?4,$P(^(J),U,2) Q
  1.  I $D(^DPT(+J,.36)),$D(^DIC(8,+^DPT(+J,.36),0)),$P(^(0),U,9)=13 W !,?4,"** COLLATERAL **"
  1.  Q
  1.  ;
  1.  ;
  1. LOC ; -- SUBRTN to return location
  1.  S SDLOC=$P(^SC(L,0),U,11)
  1.  I SDLOC']"",$D(^DIC(4,+^DD("SITE",1),"DIV")),^("DIV")="Y" D
  1.  . S SDLOC=$S($P(^SC(L,0),U,15)=DIV:"",$D(^DG(40.8,+$P(^SC(L,0),U,15),0)):$P(^(0),U,1),1:"")
  1.  Q
  1.  ;
  1. FUT ;EP -- SUBRTN to print future appts
  1.  I $$SHORT^ASDROUT2 D DATE Q  ;short form
  1.  I $O(^DPT(J,"S",SDATE_".9"))>0 D
  1.  . I $Y>(IOSL-5) D HED^SDROUT2
  1.  . D HED2
  1.  . F M=SDATE_".9":0 S M=$O(^DPT(J,"S",M)) Q:M=""  D
  1.  .. I $Y>(IOSL-5) D HED^SDROUT2,HED2
  1.  .. I $S($P(^DPT(J,"S",M,0),U,2)']"":1,$P(^(0),U,2)="I":1,1:0) D LIN2
  1.  ;
  1. DATE I SDREP,SDX'["ALL" D  Q
  1.  . W !!,"DATE PRINTED  : " S Y=SDSTART D DTS^SDUTL
  1.  . W Y,!,"DATE REPRINTED: ",PRDATE
  1.  W !!,"DATE PRINTED: ",PRDATE
  1.  W !,"Requested by: ",$P($G(^VA(200,+$G(DUZ),0)),U)
  1.  Q
  1.  ;
  1. LIN2 ; -- SUBRTN to print future appts line
  1.  D LIN2^SDROUT1
  1.  S L=+^DPT(J,"S",M,0),X=M D TM S Y=M D DTS^SDUTL
  1.  W !,Y,?11,$J(X,8),?20,$P(^SC(L,0),U,1) D LOC W ?52,SDLOC K SDLOC
  1.  I $P($G(^SC(L,9999999)),U,7)]"" W !?13,$P(^(9999999),U,7)
  1.  Q
  1.  ;
  1. HED2 ;EP -- SUBRTN to print future appt heading
  1.  W !!,?9,"**FUTURE APPOINTMENTS**"
  1.  W !!,"  DATE",?11,"TIME",?21,"CLINIC",?55,"LOCATION",!
  1.  Q
  1.  ;
  1. TM ; -- SUBRTN for printable time
  1.  I $P(X,".",2)']"" S X1=""
  1.  S X=$E($P(X,".",2)_"0000",1,4),%=X>1159 S:X>1259 X=X-1200 S X=X\100_":"_$E(X#100+100,2,3)_" "_$E("AP",%+1)_"M"
  1.  Q
  1.  ;
  1. SETP(J,K) ; -- called to set date printed
  1.  NEW DIE,DA,DR,END
  1.  Q:J<1  Q:K<1
  1.  S DIE="^DPT("_J_",""S"",",DA=K\1,DA(1)=J,END=DA+.2400
  1.  F  S DA=$O(^DPT(J,"S",DA)) Q:DA=""!(DA>END)  D
  1.  . Q:$P(^DPT(J,"S",DA,0),U,2)["C"
  1.  . S DR="8///Y" S:$P(^DPT(J,"S",DA,0),U,13)="" DR=DR_";8.5///"_DT
  1.  . D ^DIE
  1.  Q
  1.  ;
  1. OTHER ; -- calls other forms
  1.  ; searhc/maw these all get set up in the clinic setup option
  1.  Q:$P($G(^DG(40.8,$$DIV,"IHS")),U,4)'=1  ;others not print with rs
  1.  D EF ;   encounter form 
  1.  D HS ;   health summary
  1.  D MP ;   med profile 
  1.  D AIU ;  address/insurance update 
  1.  Q
  1.  ;
  1. EF ; -- encounter form
  1.  Q:$G(SDZEF)  Q:'$$ONE(J,5)  W @IOF D EF^ASDFORM(SC,J,SDATE) Q
  1.  ;
  1. HS ; -- health summary
  1.  ;IHS/ITSC/KMS, 13-Nov-2002  Added extra space " " after QUIT for Cache' compliance - KMS
  1.  ;I $G(SDZHS) Q ;searhc/maw removed form feed
  1.  I $G(SDZHS) Q  ;searhc/maw removed form feed
  1.  ;I $G(SDZHS) W @IOF Q
  1.  ;IHS/ITSC/KMS, 13-Nov-2002 Added extra space " " after QUIT for Cache' compliance - KMS
  1.  ;I '$$ONE(J,1) Q ;searhc/maw removed form feed
  1.  I '$$ONE(J,1) Q  ;searhc/maw removed form feed
  1.  ;I '$$ONE(J,1) W @IOF Q
  1.  D HS^ASDFORM(J,$P($$ONE(J,1),U,2)) Q
  1.  ;
  1. MP ; -- med profile
  1.  Q:$G(SDZMP)  Q:'$$ONE(J,3)  D MP^ASDFORM(J) Q
  1.  ;
  1. AIU ; -- insurance update
  1.  Q:$G(SDZAI)  Q:'$$ONE(J,4)  D AIU^ASDFORM(J) Q
  1.  ;
  1. NEW1() ; -- returns 1 if patient has new appt on same day
  1.  NEW X,Y
  1.  S Y=0,X=GDATE\1
  1.  F  S X=$O(^DPT(DFN,"S",X)) Q:X=""  Q:X>(GDATE+.2400)  Q:Y=1  D
  1.  . Q:$P(^DPT(DFN,"S",X,0),U,2)["C"
  1.  . I $P(^DPT(DFN,"S",X,0),U,13)=""!($P(^(0),U,13)=SDSTART) S Y=1
  1.  Q Y
  1.  ;
  1. ONE(DFN,FORM) ; -- returns 1 if at least one  clinic for pat wants form
  1.  NEW X,Y,Z
  1.  S Y=0,X=SDATE\1
  1.  F  S X=$O(^DPT(DFN,"S",X)) Q:X=""  Q:X>(SDATE+.2400)  Q:Y=1  D
  1.  . S Z=$P($G(^DPT(DFN,"S",X,0)),U) Q:Z=""  Q:$P(^(0),U,2)["C"
  1.  . I $P($G(^SC(Z,9999999)),U,FORM)="Y" S Y=1
  1.  . I FORM=1,$$HSTYP^ASDUT(Z,DFN)="" S Y=0
  1.  . I FORM=1,Y=1 S Y=1_U_$$HSTYP^ASDUT(Z,DFN)
  1.  Q Y
  1.  ;
  1. CNT ; -- increment # of routing slips printed
  1.  S SDCNT=SDCNT+1 Q
  1.  ;
  1. RS2() ; -- returns 1 if want >1 rs
  1.  Q $P($G(^DG(40.8,$$DIV,"IHS")),U,3)
  1.  ;
  1. DIV() ; -- returns division ien
  1.  Q $O(^DG(40.8,"C",DUZ(2),0))