source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDROUT2.m@ 1590

Last change on this file since 1590 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.5 KB
Line 
1SDROUT2 ;BSN/GRR - PRINT ROUTING SLIPS HEADING ; 4/24/01 3:10pm
2 ;;5.3;Scheduling;**28,377**;Aug 13, 1993
3HED W !,@IOF,"*** FACILITY: ",$S($D(^DG(40.8,+DIV,0)):$P(^(0),"^"),1:$P($$SITE^VASITE,U,2)) S P=P+1
4 I ORDER=2 W !,"*** CLINIC: ",$P(^SC(+SC,0),"^")
5 I ORDER=3 W !,"*** PHYSICAL LOCATION: "_I
6 I $D(^DPT(J,.321)) F SDX1=1,2,3 I $P(^(.321),"^",SDX1)["Y" Q
7 ;I W ?45,"*** EXPOSURE SURVEY ***",!
8 ;I $D(^DPT(J,.321)) F SDX1=1,2,3 I $P(^(.321),"^",SDX1)=""!($P(^(.321),"^",SDX1)["U") W ?45,"*** UPDATE SURVEY DATA ***" Q
9 ;I '$D(^DPT(J,.321)) W ?45,"*** UPDATE SURVEY DATA ***"
10 I P'>1 S SDZ="",$P(SDZ,"* ",13)="" D WCAT K SDZ
11 W !,"PAGE ",P,?10,"OUTPATIENT ROUTING SLIP"
12 I $D(^DPT(J,.36)),$P(^DPT(J,.36),"^",1)]""
13 W ?45,"*** ",$S($T:$P(^DIC(8,+^DPT(J,.36),0),"^",1),1:"ELIG NOT SPECIFIED")," ***"
14 S Y=^DPT(J,0),NAME=$P(Y,"^",1),SSN=$P(Y,"^",9)
15 W !!,NAME,?54,"APPOINTMENT DATE"
16 W !,$E(SSN,1,3),"-",$E(SSN,4,5),"-",$E(SSN,6,10),?58,APDATE
17 I $D(^DPT(J,.1)) W !!,"*** INPATIENT ***",!,"LOCATED ON WARD: ",$P(^DPT(J,.1),"^",1),! G OVR
18 S ADDR=$S($D(^DPT(J,.11)):^DPT(J,.11),1:"")
19 F LL=1:1:3 W:$P(ADDR,"^",LL)]"" !,$P(ADDR,"^",LL)
20 W !,$S($P(ADDR,"^",4)]"":$P(ADDR,"^",4),1:"")," ",$S($P(ADDR,"^",5)]"":$P(^DIC(5,+$P(ADDR,"^",5),0),"^",1),1:"")," ",$S($P(ADDR,"^",6)]"":$P(ADDR,"^",6),1:"")
21 W !!,"PSA: UNKNOWN"
22OVR W !
23 N I S DFN=J D DIS
24 N DGINSDT S DGINSDT=SDATE
25 D INS^DGRPDB,KVAR^VADPT S J=DFN
26 W ! Q
27WCAT S DGMT=$$LST^DGMTCOU1(J,"",3) Q:DGMT']"" S SDVA=$P(DGMT,U,3) I SDVA']"" Q ;Q:$S('$D(^DG(41.3,+J,0)):1,$P(^(0),"^",2)']"":1,1:0)
28 S SDVA=$S($P(DGMT,U,4)="R":"REQUIRES MEANS TEST",$P(DGMT,U,4)="N":"MEANS TEST NOT REQUIRED",1:SDVA)
29 D KVAR^VADATE I $P(DGMT,U,2)]"",$P(DGMT,U,4)'="R",$P(DGMT,U,4)'="N" S VADAT("W")=$P(DGMT,U,2) D ^VADATE ;$N(^DG(41.3,+J,2,0))>0 S VADAT("W")=9999999-$N(^DG(41.3,J,2,0)) D ^VADATE
30 W !?27,SDZ,!?27,$S($P(DGMT,U,5)=1:SDVA,1:"PHARMACY CO-PAY: "_SDVA) I $D(VADATE("E")) W !?27,"LAST TEST: ",VADATE("E")
31 W !?27,SDZ K VADAT,VADATE,SDVA Q
32HD W !,?11,"**CURRENT APPOINTMENTS**",!!,?3,"TIME",?11,"CLINIC",?45,"LOCATION",!
33 Q
34SCCOND ; - text on routing sheet for determining if care for sc condition.
35 S SDSCCOND=""
36 W !!?11,"List diagnosis ________________________________________________"
37 W !!?11,"List any procedures performed during this clinic visit ________",!!?11,"_______________________________________________________________"
38 D CL(J)
39 W ! Q
40 ;
41CL(DFN) ;Classification
42 N SDCLY,SDCTI,SDCTIS,SDCTS
43 D CL^SDCO21(DFN,DT,"",.SDCLY) G CLQ:'$D(SDCLY)
44 S SDCTIS=$$SEQ^SDCO21
45 W !
46 F SDCTS=1:1 S SDCTI=+$P(SDCTIS,",",SDCTS) Q:'SDCTI I $D(SDCLY(SDCTI)) D
47 .W !,$P($G(^SD(409.41,SDCTI,0)),"^",2),"? "
48 .W "__Yes __No"
49CLQ Q
50 ;
51DIS ;rated disabilities
52 ; -- Pharmacy is allowed to call this tag via a special agreement
53 ; with MAS. MAS should notify pharmacy developers of any
54 ; changes that may impact PS* code. (5/91 - MJK/BOK)
55 ;
56 I '$D(VAEL) D ELIG^VADPT S DGKVAR=1
57 W:'+VAEL(3) !!,"Service Connected: NO" W:+VAEL(3) !!," SC Percent: ",$P(VAEL(3),"^",2)_"%"
58 W !," Disabilities: " I 'VAEL(4),$S('$D(^DG(391,+VAEL(6),0)):1,$P(^(0),"^",2):0,1:1) W "NOT A VETERAN" G DISQ
59 S I3=0 F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I D DIS1
60 I 'I3 W $S('$O(^DPT(DFN,.372,0)):"NONE STATED",1:"NO SC DISABILITIES LISTED")
61DISQ I $D(DGKVAR) D KVAR^VADPT K DGKVAR,I1,I2,I3
62 Q
63DIS1 S I1=^DPT(DFN,.372,I,0) I $P(I1,"^",3) S I2=$S($D(^DIC(31,+I1,0)):^(0),1:""),I2=$S($P(I2,"^",4)]"":$P(I2,"^",4),1:$P(I2,"^")) W !,I2,?48,$J($P(I1,"^",2),4),"% - ",$S($P(I1,"^",3):"SERVICE CONNECTED",1:"") S I3=I3+1
64 Q
Note: See TracBrowser for help on using the repository browser.