source: WorldVistAEHR/trunk/r/SOCIAL_WORK-SOW-SWBH-SWFG/SOWKHRM.m@ 861

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

initial load of WorldVistAEHR

File size: 3.0 KB
Line 
1SOWKHRM ;B'HAM ISC/SAB-MANUAL HIGH RISK SCREENING ; 01 Mar 93 / 9:00 AM
2 ;;3.0; Social Work ;**53**;27 Apr 93
3 Q:'$D(^SOWK(650.1,1,0))
4 S (MON,DP,J,SC,HB,AA,OI,C,B,T,INC,MP,SI,PE)=0,SWSITE=^SOWK(650.1,1,0),AGE=$P(SWSITE,"^",4),TI=$P(SWSITE,"^",5)
5 S %DT="",X="T-7" D ^%DT S %DT(0)=Y X ^DD("DD") S %DT("B")=Y
6BEG W !! S %DT="AEXP",%DT("A")="BEGINNING SCREEN DATE: " D ^%DT G:"^"[X CL G:Y<1 BEG S SDATE=Y,WDZ="" W !
7 W !,"This report is formatted for 80 columns and must be sent to a printer.",!
8 K %ZIS,IOP,ZTSK S SOWKION=ION,%ZIS="QM",%ZIS("B")="" D ^%ZIS K %ZIS I POP S IOP=SOWKION D ^%ZIS K IOP,SOWKION G CL
9 I $E(IOST)["C" W *7,!,"PRINTOUT MUST BE SENT TO PRINTER !!",! G BEG
10 K SOWKION I $D(IO("Q")) S ZTDESC="MANUAL HIGH-RISK SCREENING REPORT",ZTRTN="ENQ^SOWKHRM" F G="MON","DP","SWSITE","J","SC","HB","AA","OI","C","B","T","INC","MP","SI","PE","AGE","TI","SDATE","WDZ" S:$D(@G) ZTSAVE(G)=""
11 I K IO("Q") D ^%ZTLOAD W:$D(ZTSK) !!,"Task Queued to Print",! K ZTSK,G G CL Q
12ENQ D KVA^VADPT S WDZ=$O(^DPT("CN",WDZ)) G:WDZ="" CLOS
13 F DFN=0:0 S DFN=$O(^DPT("CN",WDZ,DFN)) G:'DFN ENQ D INP^VADPT I $E(VAIN(7),1,7)'<SDATE,'$D(DFN(DFN,+VAIN(7))) S J=J+1 D CHK S (INC,MP,SI,PE,HB,OI,AA,SC,DP,SR,MON)=0,DFN(DFN,+VAIN(7))=1 K SPS
14CLOS U IO W:J'>0 @IOF,"There were no possible High-Risk patients found for Social Work Service !",!
15CL W:$E(IOST)'["C" @IOF D ^%ZISC K CD,OD,SK,HR,IN,DAT,DTY,SDATE,SWSITE,PRV,H,K,L,IC,HB,OI,OR,R,DD,SC,B,C,CL,%DT,G,A,DS,E,EE,DFN,INC,IOP,%ZIS,MP,P,PE,J,Q,SI,T,W,TI,X,X1,X2,Y,ZD,Z,DP,SR,N,MON D KVA^VADPT
16 K F,AGE,D,S,AA,Z,WDZ,POP D:$D(ZTSK) KILL^%ZTLOAD Q
17CHK D ALL^VADPT I $P(SWSITE,"^",20) S:VADM(4)'<AGE T=T+1,T(T)="AGE "_AGE_" or OLDER - "
18 S SK=0 G:'$P(SWSITE,"^",8) FM
19 I '+VAEL(3),$D(^DPT(DFN,.312)) F L=0:0 S L=$O(^DPT(DFN,.312,L)) Q:'L I '$P(^DPT(DFN,.312,L,0),"^",4)!($P(^(0),"^",4)'<DT) D I SK S T=T+1,T(T)="NSC INSURANCE COVERAGE - "
20 .S IC=$P(^DPT(DFN,.312,L,0),"^") I $D(^DIC(36,IC,0)),$E($P(^DIC(36,IC,0),"^"),1,5)'="MEDIC" S SK=SK+1,IC(SK)=$P(^DIC(36,IC,0),"^")
21FM I $P(SWSITE,"^",9) S:$P(VADM(5),"^")="F" T=T+1,T(T)="FEMALE - "
22 G:'$P(SWSITE,"^",10) ADD F W=0:0 S W=$O(^UTILITY("VAEN",$J,W)) Q:'W I $P(^UTILITY("VAEN",$J,W,"I"),"^",3)="O" S C=C+1
23 I C'<2,VADM(4)'<70 S T=T+1,T(T)="AGE 70 or greater and 2 or more OPT clinics - "
24ADD I $P(SWSITE,"^",11) S:VAPA(1)="GENERAL DELIVERY" T=T+1,T(T)="GENERAL DELIVERY ADDRESS - "
25 I $P(SWSITE,"^",12) S:VAPA(1)']"" T=T+1,T(T)="NO ADDRESS - "
26 I $P(SWSITE,"^",13),+VAPA(9)'<SDATE,+VAPA(10)'>SDATE,VAPA(1)']"" S T=T+1,T(T)="NO TEMPORARY ADDRESS - "
27 I $P(SWSITE,"^",7) F F=0:0 S F=$O(^SOWK(650.1,1,1,F)) Q:'F I ^SOWK(650.1,1,1,F,0)=$P(VAIN(4),"^") S T=T+1,T(T)="HIGH-RISK WARD - "
28 D:'$P(SWSITE,"^",15) RADM^SOWKHRM1 Q:'$P(SWSITE,"^",15) S D=9999999.9999999-(+VAIN(7)),DD=+$O(^DGPM("ATID3",DFN,D)) G:'DD REA S IN=$O(^(DD,0)),DAT=^DGPM(IN,0),DD=$P(DAT,"^"),DTY=$P(DAT,"^",4)
29 S X1=$E(+VAIN(7),1,7),X2=$E($P(DAT,"^"),1,7) D ^%DTC
30 I $P(^DG(405.3,$P(DAT,"^",2),0),"^")="DISCHARGE",$E($P(^DG(405.1,$P(DAT,"^",4),0),"^"),1,3)="IRR",X'>180 S T=T+1,T(T)="IRREGULAR DISCHARGE - "
31REA D ^SOWKHRM1 Q
Note: See TracBrowser for help on using the repository browser.