source: WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSMV1.m@ 1710

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

initial load of WorldVistAEHR

File size: 2.7 KB
RevLine 
[613]1YSMV1 ;SLC/DKG,SLC/TGA-MOVE CN,MSG CONTINUED ;11/16/90 08:51 ;
2 ;;5.01;MENTAL HEALTH;;Dec 30, 1994
3 ;
4DTS ; Called by routine YSMV
5 S (YSIDT,K)=0 W !!?10,"PREVIOUS ",YSTL,"(S)",!
6NIDT ;
7 F S YSIDT=$O(^PTX(YSDFN,YSTY,YSIDT)) Q:'YSIDT S YSUSR=0 D
8 .F S YSUSR=$O(^PTX(YSDFN,YSTY,YSIDT,1,YSUSR)) Q:'YSUSR S YSCD=0 D
9 ..F S YSCD=$O(^PTX(YSDFN,YSTY,YSIDT,1,YSUSR,1,YSCD)) Q:'YSCD D
10 ...S K=K+1,YSA(K)=YSTY_U_YSIDT_U_YSUSR_U_YSCD,YSDTM=^(YSCD,0),Y=$P(YSDTM,"."),YSHM=$P(YSDTM,".",2) D ENDD^YSUTL,ENHM^YSUTL ; The naked reference to ^(YSCD,0) was defined in the FOR loop on the previous line.
11 ...W !?8,$J(K,3)," ",YSDT(1)_" at "_YSTM
12SEL ;
13 I K=1 W ! R " OK? N// ",A:DTIME S YSTOUT='$T,YSUOUT=A["^" S YSQT=YSTOUT I $S(YSTOUT:1,"Nn^"[A:1,1:0) K YSTY Q
14 Q:K<1 G:K>1 SEL1 I "Yy"'[A W !?5," Please enter ""Y"" or ""N"". ""Y"" will move the note, ""N"" will leave it alone",$C(7) G SEL
15 S YSKTY=1,YSTY=$P(YSA(1),U),YSIDT=$P(YSA(1),U,2),YSUSR=$P(YSA(1),U,3),YSCD=$P(YSA(1),U,4) Q
16SEL1 ;
17 W !!?3,"Select ",YSTL," NUMBER: " R A:DTIME S YSTOUT='$T,YSUOUT=A["^" G:YSTOUT!YSUOUT!(A="") FIN^YSMV G:A>0&(A'>K) SET I A<1!(A>(K)) W $C(7),!!?3,"NUMBER OUT OF RANGE!! ",! G SEL1
18SET ;
19 S YSTY=$P(YSA(A),U),YSIDT=$P(YSA(A),U,2),YSUSR=$P(YSA(A),U,3),YSCD=$P(YSA(A),U,4) Q
20 ;
21CLG ; Called by routine YSMV
22 I $G(YSKTY) K ^PTX(YSDFN,YSTY),YSKTY Q
23 Q:'$D(^PTX(YSDFN,YSTY))
24 S (YSHCD,YSCDT,YSHUS,YSUST)=0
25HCD ;
26 F S YSHCD=$O(^PTX(YSDFN,YSTY,YSIDT,1,YSUSR,1,YSHCD)) Q:'YSHCD S YSCDT=YSCDT+1
27 I YSCDT>1 K YSHCD,YSCDT,YSHUS,YSUST,^PTX(YSDFN,YSTY,YSIDT,1,YSUSR,1,YSCD) Q
28 K YSHCD,YSCDT F S YSHUS=$O(^PTX(YSDFN,YSTY,YSIDT,1,YSHUS)) Q:'YSHUS S YSUST=YSUST+1
29 I YSUST>1 K YSHUS,YSUST,^PTX(YSDFN,YSTY,YSIDT,1,YSUSR) Q
30 ;
31SETV ; Called by routine YSMV
32 ; Move of Crisis Notes/Messages into Progress Note File (^GMR(121)).
33 S YSNOTE=$S("CN"[YSTY:"CRISIS NOTE","MS"[YSTY:"MESSAGE",1:"") Q:YSNOTE="" S YSNTE=1 W !!?18,"Moving ",YSNOTE," now.",!
34 S YSDTPN=$P(^PTX(YSDFN,YSTY,YSIDT,1,YSUSR,1,YSCD,0),U),DIC="^GMR(121,",DIC(0)="L",DLAYGO=121,X="""N""" D ^DIC Q:Y'>0
35 S DA=+Y,DIE=DIC,DR=".02////"_YSDFN_";.03///"_YSDTPN_";.05////"_YSUSR_";.06///^S X=""Y"";1////"_YSNTE_";2////"_YSUSR_";3////"_YSUSR_";4///NOW;4.1////"_DUZ D ^DIE
36 S DR="200///NOW",DR(2,121.05)=".01///NOW;.02////"_DUZ_";.03////"_$S("CN"[YSTY:22,1:1)_";.04////"_DUZ D ^DIE
37 S %X="^PTX(YSDFN,YSTY,YSIDT,1,YSUSR,1,YSCD,1,",%Y="^GMR(121,DA,10," D %XY^%RCR
38 W !!?18,"*** MOVE COMPLETED ***",! K YSHUS,YSUST,YSDTPN,YSNTE,YSNOTE K ^PTX(YSDFN,YSTY,YSIDT,1,YSUSR,1,YSCD)
39 ;
40FCK ; Called by routine YSPTX
41 ; Attempts to clear file entries for patient (^PTX).
42 I '$O(^PTX(YSDFN,YSTY,YSIDT,1,YSUSR,1,0)) K ^PTX(YSDFN,YSTY,YSIDT)
43 I '$O(^PTX(YSDFN,YSTY,0)) K ^PTX(YSDFN,YSTY)
44 I $O(^PTX(YSDFN,0))="" S DIK="^PTX(",DA=YSDFN D ^DIK
45 Q
Note: See TracBrowser for help on using the repository browser.