60 lines
3.0 KiB
Mathematica
60 lines
3.0 KiB
Mathematica
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
|