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

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

initial load of FOIAVistA 6/30/08 version

File size: 3.0 KB
Line 
1YSCEN5 ;ALB/ASF-CENSUS HX ;4/3/90 10:45 ;
2 ;;5.01;MENTAL HEALTH;;Dec 30, 1994
31 ; Called by MENU option YSCENPAHX
4 ;
5 D IN S YSFL6=0,Q3=0 D ^YSLRP G:YSDFN<1 END S YSDFN9=YSDFN
6 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)
7 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
8 K IOP S %ZIS="Q" D ^%ZIS G:POP END
9 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
10SQ ;
11 U IO S Q3=0 D EN^YSCEN54
12 S W4=0 F S W4=$O(^YSG("INP","C",YSDFN,W4)) Q:'W4 S ^UTILITY($J,9999999-W4)=""
13 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
14 G END0
15 ;
162 ; Called by routine YSCEN55
17 D ZZ^YSCEN54
18 Q
19WAIT ;
20 Q:Q3 D:IOST?1"C-".E WAIT^YSCEN1 Q
21CK ; Called by routine YSCEN54
22 ;
23 W:$D(^YSG("INP","CP",YSDFN)) !?(IOM-44)\2,"*** CURRENTLY A MENTAL HEALTH INPATIENT ***" Q
24HDD ;
25 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,","
26 W ! Q
27END0 ;
28 D KILL^%ZTLOAD
29END ; Called by routine YSCEN52
30 ;
31 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
32 K PTI,ZZ,VA D KVAR^VADPT Q
33CROSS ;
34 S:'$D(^YSG("INP",DA,6,0)) ^YSG("INP",DA,6,0)="^618.419P^0^0"
35 L +^YSG("INP",DA,6) S N=$P(^YSG("INP",DA,6,0),U,3)+1
36 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
37 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)
38 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
39 S ^YSG("INP",DA,6,N,0)=X_U_Y_U_DUZ,^YSG("INP",DA,6,"B",X,N)=""
40 Q:'$D(^YSG("SUB",X,1))
41 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
42 S ^YSG("CEN",W1,"ROT")=YSTM8_X
43 Q
44IN ;
45 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
46ENTRY ;
47 S YSW1=+^YSG("INP",DA,7),G=^YSG("INP",DA,0)
48 I $P(G,U,2) S ^YSG("INP","CP",$P(G,U,2),DA)=""
49 I $P(G,U,5) S ^YSG("INP","AC",$P(G,U,5),DA)=""
50 I $P(G,U,6) S ^YSG("INP","ACP",$P(G,U,6),DA)=""
51 I $P(G,U,7) S ^YSG("INP","ACR",$P(G,U,7),DA)=""
52 S ^YSG("INP","AWC",YSW1,X,DA)="" Q
53LEAVE ;
54 S YSW1=+^YSG("INP",DA,7),G=^YSG("INP",DA,0)
55 I $P(G,U,2) K ^YSG("INP","CP",$P(G,U,2),DA)
56 I $P(G,U,5) K ^YSG("INP","AC",$P(G,U,5),DA)
57 I $P(G,U,6) K ^YSG("INP","ACP",$P(G,U,6),DA)
58 I $P(G,U,7) K ^YSG("INP","ACR",$P(G,U,7),DA)
59 K ^YSG("INP","AWC",YSW1,X,DA) Q
Note: See TracBrowser for help on using the repository browser.