CRHDAM ; CAIRO/CLC - ;04-Mar-2008 16:00;CLC;CLC
;;1.0;CRHD;****;Jan 28, 2008;Build 19
;=================================================================
;copied from CWCVR0I
PSGI(CRHDY,DFN) ;
N CRHDLST,CRHDAMED,CRHDNUM,CRHDCT,CRHDFG,CRHDDRGN,CRHDSEC,CRHDNUM2,CRHDLSTR,CRHDPFN
K CRHDY,CRHDLST,CRHDDRG
D ACTIVE^ORWPS(.CRHDLST,DFN)
S CRHDLSTR=$O(CRHDLST(999),-1),CRHDFG=1
I '$D(CRHDLST) S CRHDY="" Q CRHDY
S CRHDNUM=0 F S CRHDNUM=$O(CRHDLST(CRHDNUM)) Q:'CRHDNUM!('CRHDFG) D
.Q:$P(CRHDLST(CRHDNUM),U,10)'="ACTIVE"
.I CRHDLST(CRHDNUM)["~OP" Q
.S CRHDSEC=$E($P(CRHDLST(CRHDNUM),U,1),2,999)
.S CRHDDRGN=$P(CRHDLST(CRHDNUM),U,3)
.S CRHDPFN=+$P(CRHDLST(CRHDNUM),"^",2)
.S CRHDNUM2=CRHDNUM F S CRHDNUM2=$O(CRHDLST(CRHDNUM2)) Q:$G(CRHDLST(+CRHDNUM2))["~"!('CRHDNUM2) D
..I $L($G(CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)))+$L(CRHDLST(CRHDNUM2))<80 S CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)=$G(CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN))_$$STRIP(CRHDLST(CRHDNUM2)," ")_" "
..E S CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)=$$STR($G(CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN))_" "_CRHDLST(CRHDNUM2),80)
..I CRHDNUM2=CRHDLSTR S CRHDFG=0
. S CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)=DFN_"^"_CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)_"^^^"_CRHDPFN_$S($P(CRHDLST(CRHDNUM),"^",2)["U":"|5",1:"|IV")
. S:CRHDFG CRHDNUM=CRHDNUM2-1
S CRHDY(2)="0^<==UNIT DOSE==>",CRHDCT=2
S CRHDSEC=""
F CRHDSEC="UD","CP","IV" S CRHDFG=0,CRHDDRG="" F S CRHDDRG=$O(CRHDAMED(CRHDSEC,CRHDDRG)) Q:CRHDDRG="" D
. S CRHDNUM=0 F S CRHDNUM=$O(CRHDAMED(CRHDSEC,CRHDDRG,CRHDNUM)) Q:'CRHDNUM D
.. I (CRHDSEC="UD"!(CRHDSEC="CP"))&'CRHDFG S CRHDY(CRHDCT)="0^<==UNIT DOSE==>",CRHDFG=1,CRHDCT=CRHDCT+1
.. I CRHDSEC="IV"&('CRHDFG) S CRHDY(CRHDCT)="0^<==IV DOSE==>",CRHDFG=1,CRHDCT=CRHDCT+1
.. S CRHDY(CRHDCT)=CRHDAMED(CRHDSEC,CRHDDRG,CRHDNUM),CRHDCT=CRHDCT+1
S CRHDY(-9900)=CRHDCT-2
Q $O(CRHDY(2))
STR(CRHDSTR,CRHDLEN) ;
N CRHDX,CRHDCHAR,CRHDK
S CRHDX=""
I $L(CRHDSTR)>CRHDLEN S CRHDX=$E(CRHDSTR,1,CRHDLEN) D
.F CRHDK=132:-1 S CRHDCHAR=$E(CRHDX,CRHDK) Q:CRHDCHAR=" " S CRHDX=$E(CRHDX,1,CRHDK-1)
.S CRHDX=CRHDX_"..."
I $L(CRHDSTR)<CRHDLEN S CRHDX=$E(CRHDSTR,1,CRHDLEN)
Q CRHDX
STRIP(CRHDSTR,CRHDSTRP) ;
F Q:$E(CRHDSTR,1)'=CRHDSTRP S CRHDSTR=$E(CRHDSTR,2,$L(CRHDSTR))
Q CRHDSTR
OUTPT(CRHDY,CRHDDFN) ;get outpatient active meds
N CRHDLST,CRHDAMED,CRHDNUM,CRHDCT,CRHDFG,CRHDDRGN,CRHDSEC,CRHDNUM2,CRHDLSTR,CRHDPFN
K CRHDY,CRHDLST
D ACTIVE^ORWPS(.CRHDLST,CRHDDFN)
S CRHDLSTR=$O(CRHDLST(999),-1),CRHDFG=1
I '$D(CRHDLST) S CRHDY="" Q CRHDY
S CRHDNUM=0 F S CRHDNUM=$O(CRHDLST(CRHDNUM)) Q:'CRHDNUM!('CRHDFG) D
.Q:$P(CRHDLST(CRHDNUM),U,10)'="ACTIVE"
.I CRHDLST(CRHDNUM)'["~OP" Q
.S CRHDSEC=$E($P(CRHDLST(CRHDNUM),U,1),2,999)
.S CRHDDRGN=$P(CRHDLST(CRHDNUM),U,3)
.S CRHDPFN=+$P(CRHDLST(CRHDNUM),"^",2)
.S CRHDNUM2=CRHDNUM F S CRHDNUM2=$O(CRHDLST(CRHDNUM2)) Q:$G(CRHDLST(+CRHDNUM2))["~"!('CRHDNUM2) D
..I $L($G(CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)))+$L(CRHDLST(CRHDNUM2))<80 S CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)=$G(CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN))_$$STRIP(CRHDLST(CRHDNUM2)," ")_" "
..E S CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)=$$STR(CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)_" "_CRHDLST(CRHDNUM2),80)
..I CRHDNUM2=CRHDLSTR S CRHDFG=0
. S CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)=CRHDDFN_"^"_CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)_"^^^"_CRHDPFN_$S($P(CRHDLST(CRHDNUM),"^",2)["U":"|5",1:"|IV")
. S:CRHDFG CRHDNUM=CRHDNUM2-1
S CRHDCT=1
;S CRHDY(2)="0^<==OUTPATIENT MEDS==>",CRHDCT=2
S CRHDSEC="OP"
S CRHDFG=0,CRHDDRG="" F S CRHDDRG=$O(CRHDAMED(CRHDSEC,CRHDDRG)) Q:CRHDDRG="" D
. S CRHDNUM=0 F S CRHDNUM=$O(CRHDAMED(CRHDSEC,CRHDDRG,CRHDNUM)) Q:'CRHDNUM D
.. I 'CRHDFG S CRHDY(CRHDCT)="0^<==OUTPATIENT MEDS==>",CRHDFG=1,CRHDCT=CRHDCT+1
.. S CRHDY(CRHDCT)=CRHDAMED(CRHDSEC,CRHDDRG,CRHDNUM),CRHDCT=CRHDCT+1
S CRHDY(-9900)=CRHDCT-2,$P(CRHDY(1),"^",1)=CRHDCT-2
Q $O(CRHDY(1))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HCRHDAM 3887 printed Apr 09, 2024@21:40:10 Page 2
CRHDAM ; CAIRO/CLC - ;04-Mar-2008 16:00;CLC;CLC
+1 ;;1.0;CRHD;****;Jan 28, 2008;Build 19
+2 ;=================================================================
+3 ;copied from CWCVR0I
PSGI(CRHDY,DFN) ;
+1 NEW CRHDLST,CRHDAMED,CRHDNUM,CRHDCT,CRHDFG,CRHDDRGN,CRHDSEC,CRHDNUM2,CRHDLSTR,CRHDPFN
+2 KILL CRHDY,CRHDLST,CRHDDRG
+3 DO ACTIVE^ORWPS(.CRHDLST,DFN)
+4 SET CRHDLSTR=$ORDER(CRHDLST(999),-1)
SET CRHDFG=1
+5 IF '$DATA(CRHDLST)
SET CRHDY=""
QUIT CRHDY
+6 SET CRHDNUM=0
FOR
SET CRHDNUM=$ORDER(CRHDLST(CRHDNUM))
if 'CRHDNUM!('CRHDFG)
QUIT
Begin DoDot:1
+7 if $PIECE(CRHDLST(CRHDNUM),U,10)'="ACTIVE"
QUIT
+8 IF CRHDLST(CRHDNUM)["~OP"
QUIT
+9 SET CRHDSEC=$EXTRACT($PIECE(CRHDLST(CRHDNUM),U,1),2,999)
+10 SET CRHDDRGN=$PIECE(CRHDLST(CRHDNUM),U,3)
+11 SET CRHDPFN=+$PIECE(CRHDLST(CRHDNUM),"^",2)
+12 SET CRHDNUM2=CRHDNUM
FOR
SET CRHDNUM2=$ORDER(CRHDLST(CRHDNUM2))
if $GET(CRHDLST(+CRHDNUM2))["~"!('CRHDNUM2)
QUIT
Begin DoDot:2
+13 IF $LENGTH($GET(CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)))+$LENGTH(CRHDLST(CRHDNUM2))<80
SET CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)=$GET(CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN))_$$STRIP(CRHDLST(CRHDNUM2)," ")_" "
+14 IF '$TEST
SET CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)=$$STR($GET(CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN))_" "_CRHDLST(CRHDNUM2),80)
+15 IF CRHDNUM2=CRHDLSTR
SET CRHDFG=0
End DoDot:2
+16 SET CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)=DFN_"^"_CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)_"^^^"_CRHDPFN_$SELECT($PIECE(CRHDLST(CRHDNUM),"^",2)["U":"|5",1:"|IV")
+17 if CRHDFG
SET CRHDNUM=CRHDNUM2-1
End DoDot:1
+18 SET CRHDY(2)="0^<==UNIT DOSE==>"
SET CRHDCT=2
+19 SET CRHDSEC=""
+20 FOR CRHDSEC="UD","CP","IV"
SET CRHDFG=0
SET CRHDDRG=""
FOR
SET CRHDDRG=$ORDER(CRHDAMED(CRHDSEC,CRHDDRG))
if CRHDDRG=""
QUIT
Begin DoDot:1
+21 SET CRHDNUM=0
FOR
SET CRHDNUM=$ORDER(CRHDAMED(CRHDSEC,CRHDDRG,CRHDNUM))
if 'CRHDNUM
QUIT
Begin DoDot:2
+22 IF (CRHDSEC="UD"!(CRHDSEC="CP"))&'CRHDFG
SET CRHDY(CRHDCT)="0^<==UNIT DOSE==>"
SET CRHDFG=1
SET CRHDCT=CRHDCT+1
+23 IF CRHDSEC="IV"&('CRHDFG)
SET CRHDY(CRHDCT)="0^<==IV DOSE==>"
SET CRHDFG=1
SET CRHDCT=CRHDCT+1
+24 SET CRHDY(CRHDCT)=CRHDAMED(CRHDSEC,CRHDDRG,CRHDNUM)
SET CRHDCT=CRHDCT+1
End DoDot:2
End DoDot:1
+25 SET CRHDY(-9900)=CRHDCT-2
+26 QUIT $ORDER(CRHDY(2))
STR(CRHDSTR,CRHDLEN) ;
+1 NEW CRHDX,CRHDCHAR,CRHDK
+2 SET CRHDX=""
+3 IF $LENGTH(CRHDSTR)>CRHDLEN
SET CRHDX=$EXTRACT(CRHDSTR,1,CRHDLEN)
Begin DoDot:1
+4 FOR CRHDK=132:-1
SET CRHDCHAR=$EXTRACT(CRHDX,CRHDK)
if CRHDCHAR=" "
QUIT
SET CRHDX=$EXTRACT(CRHDX,1,CRHDK-1)
+5 SET CRHDX=CRHDX_"..."
End DoDot:1
+6 IF $LENGTH(CRHDSTR)<CRHDLEN
SET CRHDX=$EXTRACT(CRHDSTR,1,CRHDLEN)
+7 QUIT CRHDX
STRIP(CRHDSTR,CRHDSTRP) ;
+1 FOR
if $EXTRACT(CRHDSTR,1)'=CRHDSTRP
QUIT
SET CRHDSTR=$EXTRACT(CRHDSTR,2,$LENGTH(CRHDSTR))
+2 QUIT CRHDSTR
OUTPT(CRHDY,CRHDDFN) ;get outpatient active meds
+1 NEW CRHDLST,CRHDAMED,CRHDNUM,CRHDCT,CRHDFG,CRHDDRGN,CRHDSEC,CRHDNUM2,CRHDLSTR,CRHDPFN
+2 KILL CRHDY,CRHDLST
+3 DO ACTIVE^ORWPS(.CRHDLST,CRHDDFN)
+4 SET CRHDLSTR=$ORDER(CRHDLST(999),-1)
SET CRHDFG=1
+5 IF '$DATA(CRHDLST)
SET CRHDY=""
QUIT CRHDY
+6 SET CRHDNUM=0
FOR
SET CRHDNUM=$ORDER(CRHDLST(CRHDNUM))
if 'CRHDNUM!('CRHDFG)
QUIT
Begin DoDot:1
+7 if $PIECE(CRHDLST(CRHDNUM),U,10)'="ACTIVE"
QUIT
+8 IF CRHDLST(CRHDNUM)'["~OP"
QUIT
+9 SET CRHDSEC=$EXTRACT($PIECE(CRHDLST(CRHDNUM),U,1),2,999)
+10 SET CRHDDRGN=$PIECE(CRHDLST(CRHDNUM),U,3)
+11 SET CRHDPFN=+$PIECE(CRHDLST(CRHDNUM),"^",2)
+12 SET CRHDNUM2=CRHDNUM
FOR
SET CRHDNUM2=$ORDER(CRHDLST(CRHDNUM2))
if $GET(CRHDLST(+CRHDNUM2))["~"!('CRHDNUM2)
QUIT
Begin DoDot:2
+13 IF $LENGTH($GET(CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)))+$LENGTH(CRHDLST(CRHDNUM2))<80
SET CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)=$GET(CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN))_$$STRIP(CRHDLST(CRHDNUM2)," ")_" "
+14 IF '$TEST
SET CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)=$$STR(CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)_" "_CRHDLST(CRHDNUM2),80)
+15 IF CRHDNUM2=CRHDLSTR
SET CRHDFG=0
End DoDot:2
+16 SET CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)=CRHDDFN_"^"_CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)_"^^^"_CRHDPFN_$SELECT($PIECE(CRHDLST(CRHDNUM),"^",2)["U":"|5",1:"|IV")
+17 if CRHDFG
SET CRHDNUM=CRHDNUM2-1
End DoDot:1
+18 SET CRHDCT=1
+19 ;S CRHDY(2)="0^<==OUTPATIENT MEDS==>",CRHDCT=2
+20 SET CRHDSEC="OP"
+21 SET CRHDFG=0
SET CRHDDRG=""
FOR
SET CRHDDRG=$ORDER(CRHDAMED(CRHDSEC,CRHDDRG))
if CRHDDRG=""
QUIT
Begin DoDot:1
+22 SET CRHDNUM=0
FOR
SET CRHDNUM=$ORDER(CRHDAMED(CRHDSEC,CRHDDRG,CRHDNUM))
if 'CRHDNUM
QUIT
Begin DoDot:2
+23 IF 'CRHDFG
SET CRHDY(CRHDCT)="0^<==OUTPATIENT MEDS==>"
SET CRHDFG=1
SET CRHDCT=CRHDCT+1
+24 SET CRHDY(CRHDCT)=CRHDAMED(CRHDSEC,CRHDDRG,CRHDNUM)
SET CRHDCT=CRHDCT+1
End DoDot:2
End DoDot:1
+25 SET CRHDY(-9900)=CRHDCT-2
SET $PIECE(CRHDY(1),"^",1)=CRHDCT-2
+26 QUIT $ORDER(CRHDY(1))
