| [613] | 1 | YSCEN5 ;ALB/ASF-CENSUS HX ;4/3/90 10:45 ;
|
|---|
| 2 | ;;5.01;MENTAL HEALTH;;Dec 30, 1994
|
|---|
| 3 | 1 ; 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
|
|---|
| 10 | SQ ;
|
|---|
| 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 | ;
|
|---|
| 16 | 2 ; Called by routine YSCEN55
|
|---|
| 17 | D ZZ^YSCEN54
|
|---|
| 18 | Q
|
|---|
| 19 | WAIT ;
|
|---|
| 20 | Q:Q3 D:IOST?1"C-".E WAIT^YSCEN1 Q
|
|---|
| 21 | CK ; Called by routine YSCEN54
|
|---|
| 22 | ;
|
|---|
| 23 | W:$D(^YSG("INP","CP",YSDFN)) !?(IOM-44)\2,"*** CURRENTLY A MENTAL HEALTH INPATIENT ***" Q
|
|---|
| 24 | HDD ;
|
|---|
| 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
|
|---|
| 27 | END0 ;
|
|---|
| 28 | D KILL^%ZTLOAD
|
|---|
| 29 | END ; 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
|
|---|
| 33 | CROSS ;
|
|---|
| 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
|
|---|
| 44 | IN ;
|
|---|
| 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
|
|---|
| 46 | ENTRY ;
|
|---|
| 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
|
|---|
| 53 | LEAVE ;
|
|---|
| 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
|
|---|
