source: FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/CRHD8.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 4.3 KB
Line 
1CRHD8 ; CAIRO/CLC - RETURNS THE TEXTS OF AND ORDER ;21-Mar-2008 10:31;CLC
2 ;;1.0;CRHD;****;Jan 28, 2008;Build 19
3 ;=================================================================
4TEXT(ORTX,ORIFN,WIDTH) ; -- Returns text of order ORIFN in ORTX(#)
5 N CRHD0,CRHD3,CRHD6,CRHDORX,X,Y,CRHDFRST,CRHDI,CRHDJ,CRHDLG,X,CRHDACT
6 N CRHDTA,XQAID,ORFLG
7 K ORTX S:'$G(WIDTH) WIDTH=244
8 S CRHDACT=+$P(ORIFN,";",2),ORIFN=+ORIFN
9 I CRHDACT<1 S CRHDACT=+$P($G(^OR(100,ORIFN,3)),U,7) S:'CRHDACT CRHDACT=1
10 S CRHD0=$G(^OR(100,ORIFN,0)),CRHD3=$G(^(3)),CRHD6=$G(^(6)),CRHDORX=$G(^(8,CRHDACT,0))
11 S ORTX=1,ORTX(1)=""
12 I $P($G(CRHD0),U,11)'="",($P($G(^ORD(100.98,$P(CRHD0,U,11),0)),U)="NON-VA MEDICATIONS") S X="Non-VA" D ADD^ORQ12
13 G:$G(ORIGVIEW)>1 T1
14 S:$P(CRHD0,U,14)=$O(^DIC(9.4,"C","OR",0)) ORTX(1)=">>" ;generic
15 S X=$$ACTION^ORQ12($P(CRHDORX,U,2)) D:$L(X) ADD^ORQ12
16 I $P(CRHDORX,U,2)="NW",$P(CRHD3,U,11),'$G(ORIGVIEW) D ; Changed or Renewed
17 . I $P(CRHD3,U,11)=2 S X="Renew" D ADD^ORQ12 Q
18 . N CRHDIG,CRHDIGTA S CRHDIG=+$P(CRHD3,U,5) Q:'CRHDIG Q:$P(CRHD3,U,11)'=1
19 . S X="Change" D ADD^ORQ12 S CRHDI=0
20 . I $G(IOST)'="P-OTHER" D
21 . .S CRHDIGTA=$$LASTXT^ORQ12(CRHDIG) ;D:$O(^OR(100,CRHDIG,1,0)) CNV^ORY92(CRHDIG)
22 . .F S CRHDI=$O(^OR(100,CRHDIG,8,CRHDIGTA,.1,CRHDI)) Q:CRHDI'>0 S X=$G(^(CRHDI,0)) S:$E(X,1,3)=">> " X=$E(X,4,999) D ADD^ORQ12
23 . .S X=" to" D ADD^ORQ12
24T1 S CRHDTA=+$P(CRHDORX,U,14),CRHDFRST=+$O(^OR(100,ORIFN,8,CRHDTA,.1,0))
25 S CRHDI=0 F S CRHDI=$O(^OR(100,ORIFN,8,CRHDTA,.1,CRHDI)) Q:CRHDI'>0 S X=$G(^(CRHDI,0)) S:(CRHDFRST=CRHDI)&($E(X,1,3)=">> ") X=$E(X,4,999) D:$L(X) ADD^ORQ12
26 Q:$G(ORIGVIEW)>1 ;contents of global only
27 S CRHDLG=$P(CRHD0,U,5) K Y I CRHDLG,$P(CRHDLG,";",2)["101.41",$D(^ORD(101.41,+CRHDLG,9)) X ^(9) I $L($G(Y)) S X=Y D ADD^ORQ12 ; additional text
28 ; I $P(CRHD3,U,11)=2 S X="(Renewal)" D ADD^ORQ12
29 I $P(CRHDORX,U,4)=2 S X="*UNSIGNED*" D ADD^ORQ12
30 I $P(CRHDORX,U,2)="DC"!("^1^13^"[(U_$P(CRHD3,U,3)_U)),$L(CRHD6) S X=" <"_$S($L($P(CRHD6,U,5)):$P(CRHD6,U,5),$P(CRHD6,U,4):$P($G(^ORD(100.03,+$P(CRHD6,U,4),0)),U),1:"")_">" D:$L(X)>3 ADD^ORQ12 ; DC Reason
31 I $D(XQAID),$G(ORFLG)=12 S CRHDORX=$G(^OR(100,ORIFN,8,CRHDACT,3)) D
32 .I $P(CRHDORX,U) S X=" Flagged "_$$DATETIME^ORQ12($P(CRHDORX,U,3))_$S($P(CRHDORX,U,4):" by "_$$NAME^ORQ12($P(CRHDORX,U,4)),1:"")_": "_$P(CRHDORX,U,5) D ADD^ORQ12 ;Flagged - show in FUP
33 Q
34SORT(CRHDRTN,CRHDPLST,CRHDFG,CRHDP) ;SORT PRINT LIST
35 N VAIN,CRHDV,CRHDV1,CRHDV2,CRHDCT,CRHDDFN,CRHDWARD
36 N CRHDNAME,CRHDRM,CRHDN,CRHDWR,CRHDW,CRHDFLG,CRHDS,CRHDLG,CRHDLB
37 K CRHDRTN
38 I (CRHDP?1N.E)&($E(CRHDP,1)'=1) S CRHDP="1,"_CRHDP
39 S CRHDP1=$P(CRHDP,"^",1)
40 S CRHDLG=$P(CRHDP,"^",2)
41 S CRHDLB=$P(CRHDP,"^",3)
42 S CRHDV=0
43 F S CRHDV=$O(CRHDPLST(CRHDV)) Q:'CRHDV D
44 .S CRHDDFN=+CRHDPLST(CRHDV)
45 .K CRHDRL,CRHDS
46 .Q:'CRHDDFN
47 .S CRHDS=CRHDDFN_"^"_CRHDP1_"^"_CRHDLG_"^"_CRHDLB
48 .D PATDEMO^CRHDUT2(.CRHDRL,CRHDS)
49 .S CRHDFLG=CRHDFG
50 .S CRHDRM=$P($G(CRHDRL),"^",4) ;Room/Bed
51 .I CRHDRM["RM : " S CRHDRM=$P(CRHDRM,": ",2)
52 .S CRHDWARD=$P($G(CRHDRL),"^",5) ;Ward Location
53 .I CRHDWARD["LOC: " S CRHDWARD=$P(CRHDWARD,": ",2)
54 .S CRHDNAME=$P(^DPT(CRHDDFN,0),"^",1)
55 .Q:CRHDNAME=""
56 .I CRHDFLG=1 D
57 ..I (CRHDWARD="") S CRHDWARD="UNK" ;S CRHDFLG=0 Q
58 ..I (CRHDRM="") S CRHDRM="UNK" ;S CRHDFLG=2 Q
59 ..S CRHDWR(CRHDWARD,CRHDRM,CRHDNAME)=CRHDRL
60 .I CRHDFLG=2 D
61 ..I CRHDWARD="" S CRHDWARD="UNK" ;S CRHDFLG=0 Q
62 ..S CRHDW(CRHDWARD,CRHDNAME)=CRHDRL
63 .I CRHDFLG=0 S CRHDN(CRHDNAME)=CRHDRL
64 ;
65 S CRHDCT=0
66 S CRHDV=0
67 I CRHDFG=0 D
68 .F S CRHDV=$O(CRHDN(CRHDV)) Q:CRHDV="" S CRHDCT=CRHDCT+1,CRHDRTN(CRHDCT)=CRHDN(CRHDV)
69 .K CRHDN
70 I CRHDFG=1 D
71 .F S CRHDV=$O(CRHDWR(CRHDV)) Q:CRHDV="" S CRHDV1="" F S CRHDV1=$O(CRHDWR(CRHDV,CRHDV1)) Q:CRHDV1="" S CRHDV2="" F S CRHDV2=$O(CRHDWR(CRHDV,CRHDV1,CRHDV2)) Q:CRHDV2="" S CRHDCT=CRHDCT+1,CRHDRTN(CRHDCT)=CRHDWR(CRHDV,CRHDV1,CRHDV2)
72 .K CRHDWR
73 I CRHDFG=2 D
74 .F S CRHDV=$O(CRHDW(CRHDV)) Q:CRHDV="" S CRHDV1="" F S CRHDV1=$O(CRHDW(CRHDV,CRHDV1)) Q:CRHDV1="" S CRHDCT=CRHDCT+1,CRHDRTN(CRHDCT)=CRHDW(CRHDV,CRHDV1)
75 .K CRHDW
76 I '$D(CRHDRTN) D
77 .S CRHDV=0
78 .I $D(CRHDW) F S CRHDV=$O(CRHDW(CRHDV)) Q:CRHDV="" S CRHDV1="" F S CRHDV1=$O(CRHDW(CRHDV,CRHDV1)) Q:CRHDV1="" S CRHDCT=CRHDCT+1,CRHDRTN(CRHDCT)=CRHDWR(CRHDV,CRHDV1)
79 .I $D(CRHDN) F S CRHDV=$O(CRHDN(CRHDV)) Q:CRHDV="" S CRHDCT=CRHDCT+1,CRHDRTN(CRHDCT)=CRHDN(CRHDV)
80 Q
Note: See TracBrowser for help on using the repository browser.