source: WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCUP001.m@ 619

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

initial load of WorldVistAEHR
File size: 5.7 KB
Line 
1YSCUP001 ;DALISC/LJA - Pt Move Utils: UPDATE Logic ;8/31/94 11:45
2 ;;5.01;MENTAL HEALTH;**2,11,20,29**;Dec 30, 1994
3 ;
4UPDATE(MHNO,MOVNO) ; Using MH Inpt from ^TMP("YSPM",$J, AND YSMH data...
5 ; !!!!!!!!!!!!!!!!!! Programmer!!! No QUITting !!!!!!!!!!!!!!!!!!!
6 N MHIEN,MOVE,TIEN,WIEN,YSMH0,YSMH7
7 ;
8 ; Set "main" variables...
9 S YSACTS=1
10 S MHIEN=+$G(^TMP("YSMH",$J,+MHNO,0))
11 I MHIEN'>0 D QUIT ;->
12 . I '$D(ZTQUEUED),'$G(DGQUIET) W !,"Missing MH array entry..."
13 S YSMH0=$P($G(^TMP("YSMH",$J,+MHNO,0)),"~",2,99)
14 S YSMH7=$G(^TMP("YSMH",$J,+MHNO,7))
15 S MOVE=$G(^TMP("YSPM",$J,+MOVNO))
16 I YSMH0']""!(YSMH7']"")!(MOVE']"") D QUIT ;->
17 . I '$D(ZTQUEUED),'$G(DGQUIET) W !,"Missing required update variables..."
18 ;
19 ; ************************** Update XTMP ***************************
20 S X=$G(^XTMP($G(YSXTMP),"PRE0-UPD",+MHIEN)) S:X']"" ^XTMP(YSXTMP,"PRE0-UPD",+MHIEN)=$G(^YSG("INP",+MHIEN,0))
21 S X=$G(^XTMP($G(YSXTMP),"PRE7-UPD",+MHIEN)) S:X']"" ^XTMP(YSXTMP,"PRE7-UPD",+MHIEN)=$G(^YSG("INP",+MHIEN,7))
22 ;
23 ; ************************* AIN AOUT AWC CP ************************
24 ; Kill AOUT, AWC, and CP xrefs...
25 ; They will be rebuilt later, if appropriate.
26 K ^YSG("INP","AIN",9999999-$P(YSMH0,U,3),+MHIEN)
27 K ^YSG("INP","AOUT",9999999-$P(YSMH7,U,2),+MHIEN)
28 K ^YSG("INP","AWC",+$P(YSMH7,U),+$P(YSMH7,U,4),+MHIEN)
29 K ^YSG("INP","CP",+YSDFN)
30 ;
31 ; NEVER TRANSFERRED & this is NOT a DISCHARGE, Clear p(2)
32 I $G(YSLTRSF)']"",$P(MOVE,U,4)'=3 D
33 . S $P(YSMH7,U,2)=""
34 . S X=+$P(YSMH7,U,3) S:X>0 $P(YSMH7,U,3)=+X_"~"
35 ;
36 ; If First to MH movement's Date is valid, reset UNIT ENTRY DATE
37 I +$P(YSFMTMH,U,6)?7N.E S $P(YSMH0,U,3)=+$P(YSFMTMH,U,6)
38 ;
39 ; If First to MH movement's IEN is valid, reset ADMISSION POINTER p(1)
40 I +$P(YSFMTMH,U,5)>0 D
41 . S X=$P(YSMH7,U,3),$P(X,"~")=+$P(YSFMTMH,U,5),$P(YSMH7,U,3)=X
42 ;
43 ; If Last Movement out of MH ward Date is valid, reset DC/Trsf Date
44 I +$P(YSLMOMH,U,6)?7N.E S $P(YSMH7,U,2)=+$P(YSMH7,U,2)
45 ;
46 ; If Last Movement out of MH ward IEN is valid, reset ADMISSION POINTER p(2)
47 I +$P(YSLMOMH,U,5)>0 D
48 . S X=$P(YSMH7,U,3),$P(X,"~",2)=+$P(YSLMOMH,U,5),$P(YSMH7,U,3)=X
49 ;
50 ; ***** Patient is on MH ward, and is being DISCHARGED...
51 I +MOVE>0,$P(MOVE,U,4)=3 D
52 . S $P(YSMH7,U,2)=$P(MOVE,U,6) ;Discharge Date
53 . S $P(YSMH7,U,4)="" ;Remove team
54 . S X=$P(YSMH7,U,3),$P(YSMH7,U,3)=+X_"~"_$P(MOVE,U,5) ;Admit/DC Pointer
55 ;
56 ; ***** Patient is on MH ward, is is NOT being DISCHARGED *****
57 I +MOVE>0,$P(MOVE,U,4)'=3 D
58 .
59 . ; Update Ward and Team on ^(7)
60 . S X=+$P(MOVE,U,2),$P(YSMH7,U)=$S(X>0:+X,1:"")
61 . S X=+$P(MOVE,U,3),$P(YSMH7,U,4)=$S(X>0:+X,1:"")
62 . S X=+$P(MOVE,U,3),$P(YSMH0,U,4)=$S(X>0:+X,1:"")
63 . D TEAMHX
64 .
65 . ; Admit~DC/Transfer p(3)
66 . ; If pt is on a MH ward, p(3)'s 2nd piece should ALWAYS be null...
67 . ; (Strip off dc/Tfr movement.)
68 . S X=$P(YSMH7,U,3) S $P(YSMH7,U,3)=$S(+X>0:+X_"~",1:"~")
69 .
70 . ; If pt is on a MH ward, p(2) should never be filled in...
71 . S $P(YSMH7,U,2)=""
72 ;
73 ; ************ Patient is NOT on a MH ward ************
74 I +MOVE'>0,$P(MOVE,U,4)>0 D
75 . S $P(YSMH7,U,4)=""
76 .
77 . ; ==> No DC/Trf Date p(2)...
78 . ; Movement is a DC/Transfer, &
79 . ; DC/Trf Date available, so ... <==
80 . I $P(YSMH7,U,2)']"",23[$P(MOVE,U,4),$P(MOVE,U,6)?7N.E S $P(YSMH7,U,2)=$P(MOVE,U,6)
81 .
82 . ; Check whether Movement Off MH ward Date/Time has been edited.
83 . ; If so, reset Date/Time...
84 . D
85 . . QUIT:$P(YSMH7,U,2)']"" ;-> Not transfer out or DC recorded yet...
86 . . QUIT:$L(YSLMOMH,"~")'=2 ;-> No Last Move off MH Ward recorded...
87 . . QUIT:$P(YSMH7,U,2)=$P(YSLMOMH,U,6) ;-> No change of DC/Trsf Date...
88 . . S $P(YSMH7,U,2)=$P(YSLMOMH,U,6)
89 .
90 . ; Admit/DC-Tfr IENs
91 . S YSX=+$P(YSMH7,U,3) ; Strip DC/Transfer movement
92 . S YSY=+$P($P(YSMH7,U,3),"~",2) ;DC/Transfer Movement...
93 . S YSY=+$S(+$P(YSLMOMH,U,5)<1:+$P(MOVE,U,5),$P(YSLMOMH,U,5)'=$P(MOVE,U,5):+$P(YSLMOMH,U,5),1:+$P(MOVE,U,5))
94 . S $P(YSMH7,U,3)=+YSX_"~"_YSY
95 ;
96 ; First move to MH ward Date/Time edited?
97 S YSMHDT=+$P($G(YSFMTMH),U,6) ;Date/Time of 1st to MH move...
98 I YSMHDT?7N.E&(+YSMH0'=+YSMHDT) S $P(YSMH0,U,3)=+YSMHDT
99 ;
100 ; 0 node sets...
101 S ^YSG("INP",+MHIEN,0)=YSMH0
102 ;
103 ; ^XTMP sets...
104 S ^XTMP(YSXTMP,"POST0-UPD",+MHIEN)=YSMH0
105 S ^XTMP(YSXTMP,"POST7-UPD",+MHIEN)=YSMH7
106 ;
107 ; 7 node sets...
108 S ^YSG("INP",+MHIEN,7)=YSMH7
109 ;
110 ; Xref SETS...
111 ;
112 ; Active Inpatient?
113 I $P(YSMH7,U)>0&($P(YSMH7,U,4)>0) D
114 . S ^YSG("INP","CP",+YSDFN,+MHIEN)=""
115 . S ^YSG("INP","AWC",+$P(YSMH7,U),+$P(YSMH7,U,4),+MHIEN)=""
116 ;
117 ; Discharged or Transferred?
118 I $P(YSMH7,U,2)]"" D
119 . S ^YSG("INP","AOUT",9999999-$P(YSMH7,U,2),+MHIEN)=""
120 ;
121 ; Into MH ward AIN xref...
122 S X=+$P(YSMH0,U,3) I X?7N.E D
123 . S ^YSG("INP","AIN",9999999-X,+MHIEN)=""
124 ; !!!!!!!!!!!!!!!!! Programmer!!! You can QUIT now !!!!!!!!!!!!!!!!!
125 ;
126 QUIT
127 ;
128TEAMHX ; Update the multiple field PAST TEAMS
129 ;
130 S:'$D(^YSG("INP",+MHIEN,6,0)) ^YSG("INP",+MHIEN,6,0)="^618.419P^0^0"
131 L +^YSG("INP",+MHIEN,6):999999 Q:$T
132 S YSN=$P(^YSG("INP",+MHIEN,6,0),U,3)+1
133 I (YSN>1),$D(^YSG("INP",+MHIEN,6,YSN-1)),(X=+^YSG("INP",+MHIEN,6,YSN-1,0)) S X2=^YSG("INP",+MHIEN,6,YSN-1,0),W1=+^YSG("INP",+MHIEN,7),^YSG("INP","AST",9999999-$P(X2,U,2),W1,X,+MHIEN)="" L -^YSG("INP",+MHIEN,6,0) Q
134 S ^YSG("INP",+MHIEN,6,0)=$P(^YSG("INP",+MHIEN,6,0),U,1,2)_U_YSN_U_($P(^YSG("INP",+MHIEN,6,0),U,4)+1) L -^YSG("INP",+MHIEN,6)
135 S W1=+^YSG("INP",+MHIEN,7),YSU=X,X="NOW",%DT="T" D ^%DT S X=YSU,YSNOW=9999999-Y,^YSG("INP","AST",YSNOW,W1,X,+MHIEN)="" K YSU,YSNOW
136 S ^YSG("INP",+MHIEN,6,YSN,0)=X_U_Y_U_DUZ,^YSG("INP",+MHIEN,6,"B",X,YSN)=""
137 Q:'$D(^YSG("SUB",X,1))
138 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
139 S ^YSG("CEN",W1,"ROT")=YSTM8_X
140 ;
141 QUIT
142 ;
143EOR ;YSCUP001 - Pt Move Utils: UPDATE Logic ;8/31/94 11:45
Note: See TracBrowser for help on using the repository browser.