source: WorldVistAEHR/trunk/r/SOCIAL_WORK-SOW-SWBH-SWFG/SOWKDB.m@ 1650

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

initial load of WorldVistAEHR
File size: 4.7 KB
Line 
1SOWKDB ;B'HAM ISC/SAB,DLR - ROUTINE TO PRODUCE DATA BASE ASSESSMENT PROFILE ; 23 Feb 94 / 12:23 PM
2 ;;3.0;Social Work;**17,23,63**;27 Apr 93
3 ;External reference to ^DGPM supported by DBIA 419
4 ;
5 K DIC S DIC="^SOWK(655.2,",DIC(0)="AEQMZ",DIC("A")="Select Patient: " D ^DIC G:"^"[X CL G:Y<0 SOWKDB S (DFN,DA)=+Y K DIC
6EN K ZTSK,%ZIS,IOP S SOWKION=ION,%ZIS="QM" D ^%ZIS K %ZIS I POP S IOP=SOWKION D ^%ZIS K IOP,SOWKION,DIC,DA,DFN,Y,X G CL
7 K SOWKION I $D(IO("Q")) K IO("Q") S ZTRTN="ENQ^SOWKDB",ZTDESC="Data Base Assessment Profile" F G="Y(0)","DA","DFN","Y(0,0)" S:$D(@G) ZTSAVE(G)=""
8 I D ^%ZTLOAD I '$D(ZTSK) W:$E(IOST)'["C" @IOF D ^%ZISC K ZTDESC,DFN,ZTRTN,ZTSAVE,DIC,POP,G,X,Y,DA Q
9 I $D(ZTSK) W:$E(IOST)'["C" @IOF D ^%ZISC K DA,DFN,X,Y,ZTSAVE,DIC,POP,ZTSK,ZTRTN W !!,"Task Queued to Print",!! Q
10ENQ K ^TMP($J) S DIWL=10,DIWR=75,DIWF="WN",(VARRAY("DEM"),VARRAY("INP"),VARRAY("ADD"),VARRAY("OPD"),VARRAY("MB"),VARRAY("ELIG"),VARRAY("SVC"))="" D SEL^VADPT,PID^VADPT6
11 S ADM=+VAIN(7),G=$S(ADM:9999999.9999999-ADM,1:0)
12 S G=+$O(^DGPM("ATID1",DFN,G)),L=+$O(^DGPM("ATID1",DFN,G,0)) S PRD=$S(L:$P(^DGPM(L,0),"^"),1:"NONE"),ADM=$S(ADM:$P(VAIN(7),"^",2),PRD:"DISCHARGED",1:"UNAVAILABLE")
13 I PRD S Y=PRD X ^DD("DD") S PRD=Y
14 S Y=DT X ^DD("DD") S PG=0 U IO D HDR^SOWKDB1
15 W !!?23,"SOCIAL WORK DATA BASE/ASSESSMENT",!,"Date Printed: "_Y,!,"Source of Referral: "_$P(^SOWK(655.2,DFN,0),"^",21)
16 W !,"Source of Information: "_$S($D(^SOWK(655.2,DFN,18)):$P(^SOWK(655.2,DFN,18),"^"),1:"UNSPECIFIED")
17 S Y=$P(^SOWK(655.2,DFN,0),"^",24) X ^DD("DD") W !,"Referral Date: "_Y,!!,"I.",?5,"Demographic",!?5,"1. Date of Admission: "_ADM,!?5,"2. Date of Previous Admission: "_PRD D CHK G:$G(SWX)["^" CL W !?5,"3. Veteran's Home Address:"
18 W:VAPA(1)]"" !?9,VAPA(1)_" "_VAPA(2)_" "_VAPA(3)_" "_VAPA(4)_", "_$P(VAPA(5),"^",2)_" "_VAPA(6) W:VAPA(1)']"" " PATIENT ADDRESS UNAVAILABLE"
19 D CHK G:$G(SWX)["^" CL W !?5,"4. Veteran's Telephone: HOME #: "_VAPA(8) S VAOA("A")=5 D OAD^VADPT D CHK G:$G(SWX)["^" CL W ?57," WORK #: "_VAOA(8) K VAOA
20 D OAD^VADPT D CHK G:$G(SWX)["^" CL W !?5,"5. Next-of-kin: "_$S(VAOA(9)]"":VAOA(9)_" / "_VAOA(10),1:"UNSPECIFIED"),!?9,"ADDRESS:"
21 W:VAOA(1)]"" VAOA(1)_" "_VAOA(2)_" "_VAOA(3),!?9,VAOA(4)_", "_$P(VAOA(5),"^",2)_" "_VAOA(6) D CHK G:$G(SWX)["^" CL W !?8," HOME #: "_VAOA(8),?38 K VAOA S VAOA("A")=6 D OAD^VADPT D CHK G:$G(SWX)["^" CL W "WORK #: "_VAOA(8)
22 D CHK G:$G(SWX)["^" CL W !?5,"6. Veteran's date of birth: "_$P(VADM(3),"^",2),!?5,"7. Veteran's place of birth: " W $S(VAPD(1)]"":VAPD(1)_", "_$P(VAPD(2),"^",2),1:"UNSPECIFIED") S ST=$S(+VAPD(7):$P(VAPD(7),"^",2),1:"UNSPECIFIED")
23 D CHK G:$G(SWX)["^" CL W !?5,"8. Veteran's sex: "_$P(VADM(5),"^",2)
24 ;--------- ethnicity/race retrieval and display
25 K ERT,SEQ
26 S (ERT,SEQ)="" ;ERT=ethnicity race type;display multiple for both
27 I $D(VADM(11)) I VADM(11)>0 S SEQ=SEQ+1,ERT(SEQ)="" D
28 . F I=1:1 Q:'$D(VADM(11,I)) I $TR($P(VADM(11,I),"^",2),"")'="" D
29 .. ;length of race or ethnicity; plus 25 characters for field label; plus length of data to be added to the field; minus 2 char for comma and space; up to 80 characters.
30 .. I ($L(ERT(SEQ))+25+$L($P(VADM(11,I),"^",2))-2)'>80 D Q
31 ... S ERT(SEQ)=ERT(SEQ)_", "_$P(VADM(11,I),"^",2)
32 .. I ($L(ERT(SEQ))+25+$L($P(VADM(11,I),"^",2))-2)>80 D
33 ... S ERT(SEQ)=ERT(SEQ)_",",SEQ=SEQ+1,ERT(SEQ)=""
34 .. S ERT(SEQ)=ERT(SEQ)_", "_$P(VADM(11,I),"^",2)
35 S:'$D(ERT(1)) ERT(1)=", UNANSWERED"
36 W !?5,"9. Veteran's ethnicity: "_$E(ERT(1),3,999)
37 I SEQ>1 F I=2:1:SEQ W !?30,$E(ERT(I),3,999)
38 K ERT S (ERT,SEQ)=""
39 I $D(VADM(12)) I VADM(12)>0 S SEQ=SEQ+1,ERT(SEQ)="" D
40 . F I=1:1:VADM(12) Q:'$D(VADM(12,I)) I $TR($P(VADM(12,I),"^",2),"")'="" D
41 .. I ($L(ERT(SEQ))+25+$L($P(VADM(12,I),"^",2))-2)'>80 D Q
42 ... S ERT(SEQ)=ERT(SEQ)_", "_$P(VADM(12,I),"^",2)
43 .. I ($L(ERT(SEQ))+25+$L($P(VADM(12,I),"^",2))-2)>80 D
44 ... S ERT(SEQ)=ERT(SEQ)_",",SEQ=SEQ+1,ERT(SEQ)=""
45 .. S ERT(SEQ)=ERT(SEQ)_", "_$P(VADM(12,I),"^",2)
46 S:'$D(ERT(1)) ERT(1)=", UNANSWERED"
47 W !?5,"10. Veteran's race: "_$E(ERT(1),3,999)
48 I SEQ>1 F I=2:1:SEQ W !?25,$E(ERT(I),3,999)
49 K ERT,SEQ
50 D CHK G:$G(SWX)["^" CL W !?4,"11. Veteran's religious preference: "_$P(VADM(9),"^",2),!!,"II. Employment/Financial",!?5,"1. Veteran's employment status: "_ST
51 D ^SOWKDB1
52CL W:$E(IOST)'["C" @IOF D ^%ZISC K SWX,SWXX,C,DIC,DIWL,DIWR,DIWF,X,DA,DFN,Y S:$D(ZTQUEUED) ZTREQ="@"
53 K %I,ADM,E,G,L,PG,PRD,Q,ST,TI,W D KVA^VADPT
54 Q
55TR W "Veteran's Name: "_VADM(1),!,"ID#: "_VA("PID"),!,"WARD NO.: "_$P(VAIN(4),"^",2),!,"BED-SECTION: "_$P(VAIN(5),"^")
56 W ?30,$P(^VA(200,$P(^SOWK(655.2,DFN,0),"^",3),20),"^",2)_", Social Worker",!!!!?25,"Social Work Service Reports and Summaries",!?25,"10-9034 VAF VICE 10-1349",!
57 Q
58CHK I $E(IOST)["C",$Y+5>IOSL R !!,"PRESS RETURN TO CONTINUE or '^' TO EXIT: ",SWX:DTIME W @IOF S:SWX["^"!'$T SWXX=1 Q
59 Q:$E(IOST)["C"
60 I ($Y+15)>IOSL W !! D TR,HDR^SOWKDB1
61 Q
Note: See TracBrowser for help on using the repository browser.