SOWKHRM ;B'HAM ISC/SAB-MANUAL HIGH RISK SCREENING ; 01 Mar 93 / 9:00 AM
 ;;3.0; Social Work ;**53**;27 Apr 93
 Q:'$D(^SOWK(650.1,1,0))
 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)
 S %DT="",X="T-7" D ^%DT S %DT(0)=Y X ^DD("DD") S %DT("B")=Y
BEG W !! S %DT="AEXP",%DT("A")="BEGINNING SCREEN DATE: " D ^%DT G:"^"[X CL G:Y<1 BEG S SDATE=Y,WDZ="" W !
 W !,"This report is formatted for 80 columns and must be sent to a printer.",!
 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
 I $E(IOST)["C" W *7,!,"PRINTOUT MUST BE SENT TO PRINTER !!",! G BEG
 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)=""
 I  K IO("Q") D ^%ZTLOAD W:$D(ZTSK) !!,"Task Queued to Print",! K ZTSK,G G CL Q
ENQ D KVA^VADPT S WDZ=$O(^DPT("CN",WDZ)) G:WDZ="" CLOS
 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
CLOS U IO W:J'>0 @IOF,"There were no possible High-Risk patients found for Social Work Service !",!
CL 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
 K F,AGE,D,S,AA,Z,WDZ,POP D:$D(ZTSK) KILL^%ZTLOAD Q
CHK D ALL^VADPT I $P(SWSITE,"^",20) S:VADM(4)'<AGE T=T+1,T(T)="AGE "_AGE_" or OLDER - "
 S SK=0 G:'$P(SWSITE,"^",8) FM
 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 - "
 .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),"^")
FM I $P(SWSITE,"^",9) S:$P(VADM(5),"^")="F" T=T+1,T(T)="FEMALE - "
 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
 I C'<2,VADM(4)'<70 S T=T+1,T(T)="AGE 70 or greater and 2 or more OPT clinics - "
ADD I $P(SWSITE,"^",11) S:VAPA(1)="GENERAL DELIVERY" T=T+1,T(T)="GENERAL DELIVERY ADDRESS - "
 I $P(SWSITE,"^",12) S:VAPA(1)']"" T=T+1,T(T)="NO ADDRESS - "
 I $P(SWSITE,"^",13),+VAPA(9)'<SDATE,+VAPA(10)'>SDATE,VAPA(1)']"" S T=T+1,T(T)="NO TEMPORARY ADDRESS - "
 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 - "
 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)
 S X1=$E(+VAIN(7),1,7),X2=$E($P(DAT,"^"),1,7) D ^%DTC
 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 - "
REA D ^SOWKHRM1 Q