source: WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSMV.m@ 895

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

initial load of WorldVistAEHR
File size: 3.6 KB
Line 
1YSMV ;SLC/DKG,SLC/TGA-MOVE CNs & MSGs TO PROGRESS NOTES ;4/20/92 09:26 ;
2 ;;5.01;MENTAL HEALTH;;Dec 30, 1994
3 ;
4 ; Called from the top by MENU option YSMOVP
5 ;
6 N C,DFN,K,VA,VADM,VAERR,Y,YSAGE,YSCD,YSDFN,YSDOB,YSDTM,YSHM,YSHR,YSIDT,YSMN,YSNM,YSQT,YSSEX,YSSSN,YSTL,YSTM,YSTY,YSUSR,YSYF,YSFD
7 D ^YSLRP Q:YSDFN<1 I '$G(YSDT(0)) D ENDTM^YSUTL
8 I '$O(^PTX(YSDFN,"CN",0))&'$O(^PTX(YSDFN,"MS",0)) W $C(7),!!?3,"NO CRISIS NOTES OR MESSAGES ON FILE FOR ",YSNM Q
9 W @IOF,!!?3,"MOVE CRISIS NOTE OR MESSAGE FOR ",YSNM," ",YSSEX," AGE ",YSAGE,!
10TY ;
11 W !!?3,"(C)RISIS NOTE or (M)ESSAGE? (C or M): " R A:DTIME S YSTOUT='$T,YSUOUT=A["^" Q:YSTOUT!YSUOUT!(A']"") S A=$TR(A,"cm","CM") I A["?" D G TY
12 .W !!,"Enter either ""C"" to move Crisis notes or ""M"" to move Messages."
13 I "CM"'[A W $C(7)," ?? " G TY
14 S YSTL=$S("C"[A:"CRISIS NOTE","M"[A:"MESSAGE",1:""),YSTY=$S("C"[A:"CN","M"[A:"MS",1:"")
15 I '$O(^PTX(YSDFN,YSTY,0)) W $C(7),!!?3,"NO ",YSTL," ON FILE FOR ",YSNM K YSTY,YSTL G TY
16 D DTS^YSMV1 Q:$G(YSQT) G:'$D(YSTY) TY
17TY1 ;
18 I YSTY="CN" R !!?3,"Move to (P)ROGRESS NOTES or (M)ESSAGES? (P or M) ",YSTTY:DTIME S YSTOUT='$T,YSUOUT=YSTTY["^" Q:YSTOUT!YSUOUT I YSTTY'?1A!("PpMm"'[YSTTY) W " ??",$C(7) G TY1
19 I YSTY'="CN" S YSTTY="P"
20 S %X="^PTX(YSDFN,YSTY,YSIDT,1,YSUSR,1,YSCD,",YSTCD=1 S YSTTY=$S('$D(YSTTY):"PN","Pp"[YSTTY:"PN",1:"MS")
21 S YSPM=$D(^PTX(YSDFN,YSTY,YSIDT,1,YSUSR,1,YSCD,2))
22 S YSYFD=$S(YSTTY="PN":99,1:99.38) F I=.01:.01:.03 S YSYFD(I)=YSYFD+I
23 I YSTTY["PN" D SETV^YSMV1 D FIN Q
24ACD ;
25 I $D(^PTX(YSDFN,YSTTY,YSIDT,1,YSUSR,1,YSTCD)) S YSTCD=YSTCD+1 G ACD
26 S %Y="^PTX(YSDFN,YSTTY,YSIDT,1,YSUSR,1,YSTCD," D %XY^%RCR
27 I YSPM K ^PTX(YSDFN,YSTTY,YSIDT,1,YSUSR,1,YSTCD,2)
28 L +^PTX(YSDFN) I '$D(^PTX(YSDFN,0)) S ^(0)=YSDFN
29 I '$D(^PTX(YSDFN,YSTTY,0)) S ^(0)="^"_YSYFD(.01)_"D^"_YSIDT_U_1
30 E S ^PTX(YSDFN,YSTTY,0)=$P(^(0),U,1,3)_U_($P(^(0),U,4)+1)
31 I '$D(^PTX(YSDFN,YSTTY,YSIDT,0)) S ^(0)=9999999-YSIDT
32 I '$D(^PTX(YSDFN,YSTTY,YSIDT,1,0)) S ^(0)="^"+YSYFD(.02)_"P^"_YSUSR_U_1
33 E S ^PTX(YSDFN,YSTTY,YSIDT,1,0)="^"_YSYFD(.02)_"^"_$S(YSUSR>$P(^(0),U,3):YSUSR,1:$P(^(0),U,3))_U_($P(^(0),U,4)+1)
34 S:'$D(^PTX(YSDFN,YSTTY,YSIDT,1,YSUSR,0)) ^(0)=YSUSR
35 I '$D(^PTX(YSDFN,YSTTY,YSIDT,1,YSUSR,1,0)) S ^(0)="^"_YSYFD(.03)_"^1^1"
36 E S ^PTX(YSDFN,YSTTY,YSIDT,1,YSUSR,1,0)=$P(^(0),U,1,2)_U_($P(^(0),U,3)+1)_U_($P(^(0),U,4)+1)
37 L -^PTX(YSDFN)
38AL ;
39 S YSLN=$P(^PTX(YSDFN,YSTTY,YSIDT,1,YSUSR,1,YSTCD,1,0),U,4)+1,YSTLN=YSLN+2,^PTX(YSDFN,YSTTY,YSIDT,1,YSUSR,1,YSTCD,1,YSLN,0)=" ",YSLN=YSLN+1
40 K YSDT(1),YSDTM,YSHM,YSTM,Y D ENDTM^YSUTL
41 S YSYF="" S:YSTY="CN"&(YSTTY="MS") YSYF=" to a MESSAGE"
42 L +^PTX(YSDFN) S ^PTX(YSDFN,YSTTY,YSIDT,1,YSUSR,1,YSTCD,1,YSLN,0)="Moved from a " S:YSPM ^(0)=^(0)_" " S ^(0)=^(0)_YSTL_YSYF_" on "_YSDT(1)_" at "_YSTM,YSLN=YSLN+1
43 W @IOF,!!?3,YSTL," has been moved. You may add comments!",!! H 1
44 S DIC="^PTX(YSDFN,YSTTY,YSIDT,1,YSUSR,1,YSTCD,1,",^PTX(YSDFN,YSTTY,YSIDT,1,YSUSR,1,YSTCD,1,0)="^^"_YSTLN_U_YSTLN_U_9999999-YSIDT_U,DWPK=1 D EN^DIWE
45 S YSLN=$P(^PTX(YSDFN,YSTTY,YSIDT,1,YSUSR,1,YSTCD,1,0),U,4)+1,^PTX(YSDFN,YSTTY,YSIDT,1,YSUSR,1,YSTCD,1,YSLN,0)=" ",YSLN=YSLN+1
46 S ^PTX(YSDFN,YSTTY,YSIDT,1,YSUSR,1,YSTCD,1,YSLN,0)="Moved (comments) by "_$P(^VA(200,DUZ,0),U)
47 S ^PTX(YSDFN,YSTTY,YSIDT,1,YSUSR,1,YSTCD,1,0)=$P(^PTX(YSDFN,YSTTY,YSIDT,1,YSUSR,1,YSTCD,1,0),U,1,2)_U_YSLN_U_YSLN_U_$P(^PTX(YSDFN,YSTTY,YSIDT,1,YSUSR,1,YSTCD,1,0),U,5,10) L -^PTX(YSDFN)
48 D CLG^YSMV1 K A,YSA,YSCD,DIC,YSDTM,YSHM,YSHR,I,YSIDT,J,K,YSKTY,YSLN,M,YSMN,YSPM,YSTCD,YSTL,YSTLN,YSTM,YSTTY,YSTY,YSUSR,X,Y G TY
49 ;
50FIN ; Called by routine YSMV1
51 K CK,CK1,YSCD,YSTTY,A,YSA,DIC,YSDTM,YSHM,YSHR,I,J,K,YSKTY,YSLN,M,YSMN,YSPM,YSTCD,YSTL,YSTLN,YSTM,YSTY,YSYF,YSUSR,Z,Z1,X,%X,Y,%Y,YSYFD Q
Note: See TracBrowser for help on using the repository browser.