- CRHDAM ; CAIRO/CLC - ;04-Mar-2008 16:00;CLC;CLC
- ;;1.0;CRHD;**11**;Jan 28, 2008;Build 4
- ; Reference to ACTIVE^ORWPS in ICR #4954
- ;=================================================================
- ;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
- ;CRHD*1*11 do not quit for !('CRHDFG)
- S CRHDNUM=0 F S CRHDNUM=$O(CRHDLST(CRHDNUM)) Q:'CRHDNUM 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)
- ..;CRHD*1*11 Do not try to limit how many records are reviewed
- ..;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&(CRHDNUM2>0) 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 4038 printed Mar 13, 2025@21:42:57 Page 2
- CRHDAM ; CAIRO/CLC - ;04-Mar-2008 16:00;CLC;CLC
- +1 ;;1.0;CRHD;**11**;Jan 28, 2008;Build 4
- +2 ; Reference to ACTIVE^ORWPS in ICR #4954
- +3 ;=================================================================
- +4 ;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 ;CRHD*1*11 do not quit for !('CRHDFG)
- +7 SET CRHDNUM=0
- FOR
- SET CRHDNUM=$ORDER(CRHDLST(CRHDNUM))
- if 'CRHDNUM
- QUIT
- Begin DoDot:1
- +8 if $PIECE(CRHDLST(CRHDNUM),U,10)'="ACTIVE"
- QUIT
- +9 IF CRHDLST(CRHDNUM)["~OP"
- QUIT
- +10 SET CRHDSEC=$EXTRACT($PIECE(CRHDLST(CRHDNUM),U,1),2,999)
- +11 SET CRHDDRGN=$PIECE(CRHDLST(CRHDNUM),U,3)
- +12 SET CRHDPFN=+$PIECE(CRHDLST(CRHDNUM),"^",2)
- +13 SET CRHDNUM2=CRHDNUM
- FOR
- SET CRHDNUM2=$ORDER(CRHDLST(CRHDNUM2))
- if $GET(CRHDLST(+CRHDNUM2))["~"!('CRHDNUM2)
- QUIT
- Begin DoDot:2
- +14 IF $LENGTH($GET(CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)))+$LENGTH(CRHDLST(CRHDNUM2))<80
- SET CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)=$GET(CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN))_$$STRIP(CRHDLST(CRHDNUM2)," ")_" "
- +15 IF '$TEST
- SET CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)=$$STR($GET(CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN))_" "_CRHDLST(CRHDNUM2),80)
- +16 ;CRHD*1*11 Do not try to limit how many records are reviewed
- +17 ;I CRHDNUM2=CRHDLSTR S CRHDFG=0
- End DoDot:2
- +18 SET CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)=DFN_"^"_CRHDAMED(CRHDSEC,CRHDDRGN,CRHDPFN)_"^^^"_CRHDPFN_$SELECT($PIECE(CRHDLST(CRHDNUM),"^",2)["U":"|5",1:"|IV")
- +19 if CRHDFG&(CRHDNUM2>0)
- SET CRHDNUM=CRHDNUM2-1
- End DoDot:1
- +20 SET CRHDY(2)="0^<==UNIT DOSE==>"
- SET CRHDCT=2
- +21 SET CRHDSEC=""
- +22 FOR CRHDSEC="UD","CP","IV"
- SET CRHDFG=0
- SET CRHDDRG=""
- FOR
- SET CRHDDRG=$ORDER(CRHDAMED(CRHDSEC,CRHDDRG))
- if CRHDDRG=""
- QUIT
- Begin DoDot:1
- +23 SET CRHDNUM=0
- FOR
- SET CRHDNUM=$ORDER(CRHDAMED(CRHDSEC,CRHDDRG,CRHDNUM))
- if 'CRHDNUM
- QUIT
- Begin DoDot:2
- +24 IF (CRHDSEC="UD"!(CRHDSEC="CP"))&'CRHDFG
- SET CRHDY(CRHDCT)="0^<==UNIT DOSE==>"
- SET CRHDFG=1
- SET CRHDCT=CRHDCT+1
- +25 IF CRHDSEC="IV"&('CRHDFG)
- SET CRHDY(CRHDCT)="0^<==IV DOSE==>"
- SET CRHDFG=1
- SET CRHDCT=CRHDCT+1
- +26 SET CRHDY(CRHDCT)=CRHDAMED(CRHDSEC,CRHDDRG,CRHDNUM)
- SET CRHDCT=CRHDCT+1
- End DoDot:2
- End DoDot:1
- +27 SET CRHDY(-9900)=CRHDCT-2
- +28 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))
