source: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/CRHDAM.m@ 1764

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

initial load of FOIAVistA 6/30/08 version

File size: 3.7 KB
Line 
1CRHDAM ; CAIRO/CLC - ;04-Mar-2008 16:00;CLC;CLC
2 ;;1.0;CRHD;****;Jan 28, 2008;Build 19
3 ;=================================================================
4 ;copied from CWCVR0I
5PSGI(CRHDY,DFN) ;
6 N CRHDLST,CRHDAMED,CRHDNUM,CRHDCT,CRHDFG,CRHDDRGN,CRHDSEC,CRHDNUM2,CRHDLSTR,CRHDPFN
7 K CRHDY,CRHDLST,CRHDDRG
8 D ACTIVE^ORWPS(.CRHDLST,DFN)
9 S CRHDLSTR=$O(CRHDLST(999),-1),CRHDFG=1
10 I '$D(CRHDLST) S CRHDY="" Q CRHDY
11 S CRHDNUM=0 F S CRHDNUM=$O(CRHDLST(CRHDNUM)) Q:'CRHDNUM!('CRHDFG) D
12 .Q:$P(CRHDLST(CRHDNUM),U,10)'="ACTIVE"
13 .I CRHDLST(CRHDNUM)["~OP" Q
14 .S CRHDSEC=$E($P(CRHDLST(CRHDNUM),U,1),2,999)
15 .S CRHDDRGN=$P(CRHDLST(CRHDNUM),U,3)
16 .S CRHDPFN=+$P(CRHDLST(CRHDNUM),"^",2)
17 .S CRHDNUM2=CRHDNUM F S CRHDNUM2=$O(CRHDLST(CRHDNUM2)) Q:$G(CRHDLST(+CRHDNUM2))["~"!('CRHDNUM2) D
18 ..I $L($G(CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)))+$L(CRHDLST(CRHDNUM2))<80 S CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)=$G(CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN))_$$STRIP(CRHDLST(CRHDNUM2)," ")_" "
19 ..E S CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)=$$STR($G(CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN))_" "_CRHDLST(CRHDNUM2),80)
20 ..I CRHDNUM2=CRHDLSTR S CRHDFG=0
21 . S CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)=DFN_"^"_CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)_"^^^"_CRHDPFN_$S($P(CRHDLST(CRHDNUM),"^",2)["U":"|5",1:"|IV")
22 . S:CRHDFG CRHDNUM=CRHDNUM2-1
23 S CRHDY(2)="0^<==UNIT DOSE==>",CRHDCT=2
24 S CRHDSEC=""
25 F CRHDSEC="UD","CP","IV" S CRHDFG=0,CRHDDRG="" F S CRHDDRG=$O(CRHDAMED(CRHDSEC,CRHDDRG)) Q:CRHDDRG="" D
26 . S CRHDNUM=0 F S CRHDNUM=$O(CRHDAMED(CRHDSEC,CRHDDRG,CRHDNUM)) Q:'CRHDNUM D
27 .. I (CRHDSEC="UD"!(CRHDSEC="CP"))&'CRHDFG S CRHDY(CRHDCT)="0^<==UNIT DOSE==>",CRHDFG=1,CRHDCT=CRHDCT+1
28 .. I CRHDSEC="IV"&('CRHDFG) S CRHDY(CRHDCT)="0^<==IV DOSE==>",CRHDFG=1,CRHDCT=CRHDCT+1
29 .. S CRHDY(CRHDCT)=CRHDAMED(CRHDSEC,CRHDDRG,CRHDNUM),CRHDCT=CRHDCT+1
30 S CRHDY(-9900)=CRHDCT-2
31 Q $O(CRHDY(2))
32STR(CRHDSTR,CRHDLEN) ;
33 N CRHDX,CRHDCHAR,CRHDK
34 S CRHDX=""
35 I $L(CRHDSTR)>CRHDLEN S CRHDX=$E(CRHDSTR,1,CRHDLEN) D
36 .F CRHDK=132:-1 S CRHDCHAR=$E(CRHDX,CRHDK) Q:CRHDCHAR=" " S CRHDX=$E(CRHDX,1,CRHDK-1)
37 .S CRHDX=CRHDX_"..."
38 I $L(CRHDSTR)<CRHDLEN S CRHDX=$E(CRHDSTR,1,CRHDLEN)
39 Q CRHDX
40STRIP(CRHDSTR,CRHDSTRP) ;
41 F Q:$E(CRHDSTR,1)'=CRHDSTRP S CRHDSTR=$E(CRHDSTR,2,$L(CRHDSTR))
42 Q CRHDSTR
43OUTPT(CRHDY,CRHDDFN) ;get outpatient active meds
44 N CRHDLST,CRHDAMED,CRHDNUM,CRHDCT,CRHDFG,CRHDDRGN,CRHDSEC,CRHDNUM2,CRHDLSTR,CRHDPFN
45 K CRHDY,CRHDLST
46 D ACTIVE^ORWPS(.CRHDLST,CRHDDFN)
47 S CRHDLSTR=$O(CRHDLST(999),-1),CRHDFG=1
48 I '$D(CRHDLST) S CRHDY="" Q CRHDY
49 S CRHDNUM=0 F S CRHDNUM=$O(CRHDLST(CRHDNUM)) Q:'CRHDNUM!('CRHDFG) D
50 .Q:$P(CRHDLST(CRHDNUM),U,10)'="ACTIVE"
51 .I CRHDLST(CRHDNUM)'["~OP" Q
52 .S CRHDSEC=$E($P(CRHDLST(CRHDNUM),U,1),2,999)
53 .S CRHDDRGN=$P(CRHDLST(CRHDNUM),U,3)
54 .S CRHDPFN=+$P(CRHDLST(CRHDNUM),"^",2)
55 .S CRHDNUM2=CRHDNUM F S CRHDNUM2=$O(CRHDLST(CRHDNUM2)) Q:$G(CRHDLST(+CRHDNUM2))["~"!('CRHDNUM2) D
56 ..I $L($G(CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)))+$L(CRHDLST(CRHDNUM2))<80 S CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)=$G(CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN))_$$STRIP(CRHDLST(CRHDNUM2)," ")_" "
57 ..E S CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)=$$STR(CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)_" "_CRHDLST(CRHDNUM2),80)
58 ..I CRHDNUM2=CRHDLSTR S CRHDFG=0
59 . S CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)=CRHDDFN_"^"_CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)_"^^^"_CRHDPFN_$S($P(CRHDLST(CRHDNUM),"^",2)["U":"|5",1:"|IV")
60 . S:CRHDFG CRHDNUM=CRHDNUM2-1
61 S CRHDCT=1
62 ;S CRHDY(2)="0^<==OUTPATIENT MEDS==>",CRHDCT=2
63 S CRHDSEC="OP"
64 S CRHDFG=0,CRHDDRG="" F S CRHDDRG=$O(CRHDAMED(CRHDSEC,CRHDDRG)) Q:CRHDDRG="" D
65 . S CRHDNUM=0 F S CRHDNUM=$O(CRHDAMED(CRHDSEC,CRHDDRG,CRHDNUM)) Q:'CRHDNUM D
66 .. I 'CRHDFG S CRHDY(CRHDCT)="0^<==OUTPATIENT MEDS==>",CRHDFG=1,CRHDCT=CRHDCT+1
67 .. S CRHDY(CRHDCT)=CRHDAMED(CRHDSEC,CRHDDRG,CRHDNUM),CRHDCT=CRHDCT+1
68 S CRHDY(-9900)=CRHDCT-2,$P(CRHDY(1),"^",1)=CRHDCT-2
69 Q $O(CRHDY(1))
Note: See TracBrowser for help on using the repository browser.