source: FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCEN5.m@ 1607

YSCEN5 ;ALB/ASF-CENSUS HX ;4/3/90  10:45 ;
 ;;5.01;MENTAL HEALTH;;Dec 30, 1994
1 ; Called by MENU option YSCENPAHX
 ;
 D IN S YSFL6=0,Q3=0 D ^YSLRP G:YSDFN<1 END S YSDFN9=YSDFN
 I $D(^YSG("INP","CP",YSDFN)) S DA=$O(^YSG("INP","CP",YSDFN,0)),W1=+^YSG("INP",DA,7),W2=$P(^DIC(42,W1,0),U)
 I '$D(^YSG("INP","C",YSDFN)) W !,"There is no mental health inpatient stay on file for ",$P(^DPT(YSDFN,0),U),$C(7) H 2 G END
 K IOP S %ZIS="Q" D ^%ZIS G:POP END
 I $D(IO("Q")) K IO("Q") S ZTRTN="SQ^YSCEN5",ZTDESC="YS IP HX SQ",(ZTSAVE("YSDFN"),ZTSAVE("W1"),ZTSAVE("YSDFN9"))="" D ^%ZTLOAD W !,$S($D(ZTSK):"QUEUED",1:"Not queued"),$C(7) G END
SQ ;
 U IO S Q3=0 D EN^YSCEN54
 S W4=0 F  S W4=$O(^YSG("INP","C",YSDFN,W4)) Q:'W4  S ^UTILITY($J,9999999-W4)=""
 S (DA,W4,Q3)=0 F YSI=1:1 S W4=$O(^UTILITY($J,W4)) Q:'W4  S (DA,W2)=9999999-W4 D ZZ^YSCEN54,WAIT^YSCEN1 Q:Q3
 G END0
 ;
2 ;  Called by routine YSCEN55
 D ZZ^YSCEN54
 Q
WAIT ;
 Q:Q3  D:IOST?1"C-".E WAIT^YSCEN1 Q
CK ;  Called by routine YSCEN54
 ;
 W:$D(^YSG("INP","CP",YSDFN)) !?(IOM-44)\2,"*** CURRENTLY A MENTAL HEALTH INPATIENT ***" Q
HDD ;
 Q:Q3  S P=P+1 W @IOF,YSTLT,P Q:'YSFL6  W !,"Listing for the following Teams: " S X=0 F  S X=$O(YS(X)) Q:'X  S X1=$P(^YSG("SUB",X,0),U) W:$L(X1)>IOM ! W ?$X+1,X1,","
 W ! Q
END0 ;
 D KILL^%ZTLOAD
END ;  Called by routine YSCEN52
 ;
 K %X,ZTSK,YSEN,DIW,DIWF,DIWL,DIWR,DIWT,DN,G,G1,G2,G3,G6,J,W2,W4,Z,C1,YSI,DIC,I,N,P1,YSSEX,YSFL6,YSTLT,YSAGE,YSDA,YSDFN9,YSDOB,YSSSN,YSBID,W1,X,X6,X8,Y,YSNM,Q3,YSDFN,X7,YSFRM,YSTO,W1,DA,DR,%DT,^UTILITY($J),%ZIS,IOP W !! D ^%ZISC
 K PTI,ZZ,VA D KVAR^VADPT Q
CROSS ;
 S:'$D(^YSG("INP",DA,6,0)) ^YSG("INP",DA,6,0)="^618.419P^0^0"
 L +^YSG("INP",DA,6) S N=$P(^YSG("INP",DA,6,0),U,3)+1
 I (N>1),$D(^YSG("INP",DA,6,N-1)),(X=+^YSG("INP",DA,6,N-1,0)) S X2=^YSG("INP",DA,6,N-1,0),W1=+^YSG("INP",DA,7),^YSG("INP","AST",9999999-$P(X2,U,2),W1,X,DA)="" L -^YSG("INP",DA,6,0) Q
 S ^YSG("INP",DA,6,0)=$P(^YSG("INP",DA,6,0),U,1,2)_U_N_U_($P(^YSG("INP",DA,6,0),U,4)+1) L -^YSG("INP",DA,6)
 S W1=+^YSG("INP",DA,7),YSU=X,X="NOW",%DT="T" D ^%DT S X=YSU,YSNOW=9999999-Y,^YSG("INP","AST",YSNOW,W1,X,DA)="" K YSU,YSNOW
 S ^YSG("INP",DA,6,N,0)=X_U_Y_U_DUZ,^YSG("INP",DA,6,"B",X,N)=""
 Q:'$D(^YSG("SUB",X,1))
 Q:'$P(^YSG("SUB",X,1),U,4)  S YSTM8="" F ZZ=1:1 Q:'$D(^YSG("CEN",W1,"ROT"))  S YSTM7=$P(^YSG("CEN",W1,"ROT"),U,ZZ) Q:YSTM7'?1N.N  S:YSTM7'=X YSTM8=YSTM8_YSTM7_U
 S ^YSG("CEN",W1,"ROT")=YSTM8_X
 Q
IN ;
 S YSTLT="M E N T A L   H E A L T H   I N P A T I E N T   H I S T O R Y" W @IOF,!?IOM-$L(YSTLT)\2,YSTLT,! Q
ENTRY ;
 S YSW1=+^YSG("INP",DA,7),G=^YSG("INP",DA,0)
 I $P(G,U,2) S ^YSG("INP","CP",$P(G,U,2),DA)=""
 I $P(G,U,5) S ^YSG("INP","AC",$P(G,U,5),DA)=""
 I $P(G,U,6) S ^YSG("INP","ACP",$P(G,U,6),DA)=""
 I $P(G,U,7) S ^YSG("INP","ACR",$P(G,U,7),DA)=""
 S ^YSG("INP","AWC",YSW1,X,DA)="" Q
LEAVE ;
 S YSW1=+^YSG("INP",DA,7),G=^YSG("INP",DA,0)
 I $P(G,U,2) K ^YSG("INP","CP",$P(G,U,2),DA)
 I $P(G,U,5) K ^YSG("INP","AC",$P(G,U,5),DA)
 I $P(G,U,6) K ^YSG("INP","ACP",$P(G,U,6),DA)
 I $P(G,U,7) K ^YSG("INP","ACR",$P(G,U,7),DA)
 K ^YSG("INP","AWC",YSW1,X,DA) Q