CRHD8 ; CAIRO/CLC - RETURNS THE TEXTS OF AND ORDER ; 4/22/09 7:21am
;;1.0;CRHD;**2**;Jan 28, 2008;Build 11
;=================================================================
;12/14/2009 BAY/KAM CRHD*1*2 Remedy Call 264207 Correct HOT list
; duplicate patient name print issue
TEXT(ORTX,ORIFN,WIDTH) ; -- Returns text of order ORIFN in ORTX(#)
N CRHD0,CRHD3,CRHD6,CRHDORX,X,Y,CRHDFRST,CRHDI,CRHDJ,CRHDLG,X,CRHDACT
N CRHDTA,XQAID,ORFLG
K ORTX S:'$G(WIDTH) WIDTH=244
S CRHDACT=+$P(ORIFN,";",2),ORIFN=+ORIFN
I CRHDACT<1 S CRHDACT=+$P($G(^OR(100,ORIFN,3)),U,7) S:'CRHDACT CRHDACT=1
S CRHD0=$G(^OR(100,ORIFN,0)),CRHD3=$G(^(3)),CRHD6=$G(^(6)),CRHDORX=$G(^(8,CRHDACT,0))
S ORTX=1,ORTX(1)=""
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
G:$G(ORIGVIEW)>1 T1
S:$P(CRHD0,U,14)=$O(^DIC(9.4,"C","OR",0)) ORTX(1)=">>" ;generic
S X=$$ACTION^ORQ12($P(CRHDORX,U,2)) D:$L(X) ADD^ORQ12
I $P(CRHDORX,U,2)="NW",$P(CRHD3,U,11),'$G(ORIGVIEW) D ; Changed or Renewed
. I $P(CRHD3,U,11)=2 S X="Renew" D ADD^ORQ12 Q
. N CRHDIG,CRHDIGTA S CRHDIG=+$P(CRHD3,U,5) Q:'CRHDIG Q:$P(CRHD3,U,11)'=1
. S X="Change" D ADD^ORQ12 S CRHDI=0
. I $G(IOST)'="P-OTHER" D
. .S CRHDIGTA=$$LASTXT^ORQ12(CRHDIG) ;D:$O(^OR(100,CRHDIG,1,0)) CNV^ORY92(CRHDIG)
. .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
. .S X=" to" D ADD^ORQ12
T1 S CRHDTA=+$P(CRHDORX,U,14),CRHDFRST=+$O(^OR(100,ORIFN,8,CRHDTA,.1,0))
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
Q:$G(ORIGVIEW)>1 ;contents of global only
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
; I $P(CRHD3,U,11)=2 S X="(Renewal)" D ADD^ORQ12
I $P(CRHDORX,U,4)=2 S X="*UNSIGNED*" D ADD^ORQ12
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
I $D(XQAID),$G(ORFLG)=12 S CRHDORX=$G(^OR(100,ORIFN,8,CRHDACT,3)) D
.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
Q
SORT(CRHDRTN,CRHDPLST,CRHDFG,CRHDP) ;SORT PRINT LIST
N VAIN,CRHDV,CRHDV1,CRHDV2,CRHDCT,CRHDDFN,CRHDWARD
N CRHDNAME,CRHDRM,CRHDN,CRHDWR,CRHDW,CRHDFLG,CRHDS,CRHDLG,CRHDLB
K CRHDRTN
I (CRHDP?1N.E)&($E(CRHDP,1)'=1) S CRHDP="1,"_CRHDP
S CRHDP1=$P(CRHDP,"^",1)
S CRHDLG=$P(CRHDP,"^",2)
S CRHDLB=$P(CRHDP,"^",3)
S CRHDV=0
F S CRHDV=$O(CRHDPLST(CRHDV)) Q:'CRHDV D
.S CRHDDFN=+CRHDPLST(CRHDV)
.K CRHDRL,CRHDS
.Q:'CRHDDFN
.S CRHDS=CRHDDFN_"^"_CRHDP1_"^"_CRHDLG_"^"_CRHDLB
.D PATDEMO^CRHDUT2(.CRHDRL,CRHDS)
.S CRHDFLG=CRHDFG
.S CRHDRM=$P($G(CRHDRL),"^",4) ;Room/Bed
.I CRHDRM["RM : " S CRHDRM=$P(CRHDRM,": ",2)
.S CRHDWARD=$P($G(CRHDRL),"^",5) ;Ward Location
.I CRHDWARD["LOC: " S CRHDWARD=$P(CRHDWARD,": ",2)
.S CRHDNAME=$P(^DPT(CRHDDFN,0),"^",1)
.Q:CRHDNAME=""
.I CRHDFLG=1 D
..I (CRHDWARD="") S CRHDWARD="UNK" ;S CRHDFLG=0 Q
..I (CRHDRM="") S CRHDRM="UNK" ;S CRHDFLG=2 Q
..;12/14/09 BAY/KAM CRHD*1*2 Remedy Call 264207 Concatenated CRHDDFN
..; to the next line for subscript
..; uniqueness
..;S CRHDWR(CRHDWARD,CRHDRM,CRHDNAME)=CRHDRL
..S CRHDWR(CRHDWARD,CRHDRM,CRHDNAME_CRHDDFN)=CRHDRL
.I CRHDFLG=2 D
..I CRHDWARD="" S CRHDWARD="UNK" ;S CRHDFLG=0 Q
..;12/14/09 BAY/KAM CRHD*1*2 Remedy Call 264207 Concatenated CRHDDFN
..; to the next line for subscript
..; uniqueness
..;S CRHDW(CRHDWARD,CRHDNAME)=CRHDRL
..S CRHDW(CRHDWARD,CRHDNAME_CRHDDFN)=CRHDRL
.;12/14/2009 BAY/KAM CRHD*1*2 Remedy Call 264207 Concatenated CRHDDFN
.; to the next line for subscript
.; uniqueness
.;I CRHDFLG=0 S CRHDN(CRHDNAME)=CRHDRL
.I CRHDFLG=0 S CRHDN(CRHDNAME_CRHDDFN)=CRHDRL
;
S CRHDCT=0
S CRHDV=0
I CRHDFG=0 D
.F S CRHDV=$O(CRHDN(CRHDV)) Q:CRHDV="" S CRHDCT=CRHDCT+1,CRHDRTN(CRHDCT)=CRHDN(CRHDV)
.K CRHDN
I CRHDFG=1 D
.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)
.K CRHDWR
I CRHDFG=2 D
.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)
.K CRHDW
I '$D(CRHDRTN) D
.S CRHDV=0
.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)
.I $D(CRHDN) F S CRHDV=$O(CRHDN(CRHDV)) Q:CRHDV="" S CRHDCT=CRHDCT+1,CRHDRTN(CRHDCT)=CRHDN(CRHDV)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HCRHD8 5253 printed Nov 22, 2024@17:47:48 Page 2
CRHD8 ; CAIRO/CLC - RETURNS THE TEXTS OF AND ORDER ; 4/22/09 7:21am
+1 ;;1.0;CRHD;**2**;Jan 28, 2008;Build 11
+2 ;=================================================================
+3 ;12/14/2009 BAY/KAM CRHD*1*2 Remedy Call 264207 Correct HOT list
+4 ; duplicate patient name print issue
TEXT(ORTX,ORIFN,WIDTH) ; -- Returns text of order ORIFN in ORTX(#)
+1 NEW CRHD0,CRHD3,CRHD6,CRHDORX,X,Y,CRHDFRST,CRHDI,CRHDJ,CRHDLG,X,CRHDACT
+2 NEW CRHDTA,XQAID,ORFLG
+3 KILL ORTX
if '$GET(WIDTH)
SET WIDTH=244
+4 SET CRHDACT=+$PIECE(ORIFN,";",2)
SET ORIFN=+ORIFN
+5 IF CRHDACT<1
SET CRHDACT=+$PIECE($GET(^OR(100,ORIFN,3)),U,7)
if 'CRHDACT
SET CRHDACT=1
+6 SET CRHD0=$GET(^OR(100,ORIFN,0))
SET CRHD3=$GET(^(3))
SET CRHD6=$GET(^(6))
SET CRHDORX=$GET(^(8,CRHDACT,0))
+7 SET ORTX=1
SET ORTX(1)=""
+8 IF $PIECE($GET(CRHD0),U,11)'=""
IF ($PIECE($GET(^ORD(100.98,$PIECE(CRHD0,U,11),0)),U)="NON-VA MEDICATIONS")
SET X="Non-VA"
DO ADD^ORQ12
+9 if $GET(ORIGVIEW)>1
GOTO T1
+10 ;generic
if $PIECE(CRHD0,U,14)=$ORDER(^DIC(9.4,"C","OR",0))
SET ORTX(1)=">>"
+11 SET X=$$ACTION^ORQ12($PIECE(CRHDORX,U,2))
if $LENGTH(X)
DO ADD^ORQ12
+12 ; Changed or Renewed
IF $PIECE(CRHDORX,U,2)="NW"
IF $PIECE(CRHD3,U,11)
IF '$GET(ORIGVIEW)
Begin DoDot:1
+13 IF $PIECE(CRHD3,U,11)=2
SET X="Renew"
DO ADD^ORQ12
QUIT
+14 NEW CRHDIG,CRHDIGTA
SET CRHDIG=+$PIECE(CRHD3,U,5)
if 'CRHDIG
QUIT
if $PIECE(CRHD3,U,11)'=1
QUIT
+15 SET X="Change"
DO ADD^ORQ12
SET CRHDI=0
+16 IF $GET(IOST)'="P-OTHER"
Begin DoDot:2
+17 ;D:$O(^OR(100,CRHDIG,1,0)) CNV^ORY92(CRHDIG)
SET CRHDIGTA=$$LASTXT^ORQ12(CRHDIG)
+18 FOR
SET CRHDI=$ORDER(^OR(100,CRHDIG,8,CRHDIGTA,.1,CRHDI))
if CRHDI'>0
QUIT
SET X=$GET(^(CRHDI,0))
if $EXTRACT(X,1,3)=">> "
SET X=$EXTRACT(X,4,999)
DO ADD^ORQ12
+19 SET X=" to"
DO ADD^ORQ12
End DoDot:2
End DoDot:1
T1 SET CRHDTA=+$PIECE(CRHDORX,U,14)
SET CRHDFRST=+$ORDER(^OR(100,ORIFN,8,CRHDTA,.1,0))
+1 SET CRHDI=0
FOR
SET CRHDI=$ORDER(^OR(100,ORIFN,8,CRHDTA,.1,CRHDI))
if CRHDI'>0
QUIT
SET X=$GET(^(CRHDI,0))
if (CRHDFRST=CRHDI)&($EXTRACT(X,1,3)=">> ")
SET X=$EXTRACT(X,4,999)
if $LENGTH(X)
DO ADD^ORQ12
+2 ;contents of global only
if $GET(ORIGVIEW)>1
QUIT
+3 ; additional text
SET CRHDLG=$PIECE(CRHD0,U,5)
KILL Y
IF CRHDLG
IF $PIECE(CRHDLG,";",2)["101.41"
IF $DATA(^ORD(101.41,+CRHDLG,9))
XECUTE ^(9)
IF $LENGTH($GET(Y))
SET X=Y
DO ADD^ORQ12
+4 ; I $P(CRHD3,U,11)=2 S X="(Renewal)" D ADD^ORQ12
+5 IF $PIECE(CRHDORX,U,4)=2
SET X="*UNSIGNED*"
DO ADD^ORQ12
+6 ; DC Reason
IF $PIECE(CRHDORX,U,2)="DC"!("^1^13^"[(U_$PIECE(CRHD3,U,3)_U))
IF $LENGTH(CRHD6)
SET X=" <"_$SELECT($LENGTH($PIECE(CRHD6,U,5)):$PIECE(CRHD6,U,5),$PIECE(CRHD6,U,4):$PIECE($GET(^ORD(100.03,+$PIECE(CRHD6,U,4),0)),U),1:"")_">"
if $LENGTH(X)>3
DO ADD^ORQ12
+7 IF $DATA(XQAID)
IF $GET(ORFLG)=12
SET CRHDORX=$GET(^OR(100,ORIFN,8,CRHDACT,3))
Begin DoDot:1
+8 ;Flagged - show in FUP
IF $PIECE(CRHDORX,U)
SET X=" Flagged "_$$DATETIME^ORQ12($PIECE(CRHDORX,U,3))_$SELECT($PIECE(CRHDORX,U,4):" by "_$$NAME^ORQ12($PIECE(CRHDORX,U,4)),1:"")_": "_$PIECE(CRHDORX,U,5)
DO ADD^ORQ12
End DoDot:1
+9 QUIT
SORT(CRHDRTN,CRHDPLST,CRHDFG,CRHDP) ;SORT PRINT LIST
+1 NEW VAIN,CRHDV,CRHDV1,CRHDV2,CRHDCT,CRHDDFN,CRHDWARD
+2 NEW CRHDNAME,CRHDRM,CRHDN,CRHDWR,CRHDW,CRHDFLG,CRHDS,CRHDLG,CRHDLB
+3 KILL CRHDRTN
+4 IF (CRHDP?1N.E)&($EXTRACT(CRHDP,1)'=1)
SET CRHDP="1,"_CRHDP
+5 SET CRHDP1=$PIECE(CRHDP,"^",1)
+6 SET CRHDLG=$PIECE(CRHDP,"^",2)
+7 SET CRHDLB=$PIECE(CRHDP,"^",3)
+8 SET CRHDV=0
+9 FOR
SET CRHDV=$ORDER(CRHDPLST(CRHDV))
if 'CRHDV
QUIT
Begin DoDot:1
+10 SET CRHDDFN=+CRHDPLST(CRHDV)
+11 KILL CRHDRL,CRHDS
+12 if 'CRHDDFN
QUIT
+13 SET CRHDS=CRHDDFN_"^"_CRHDP1_"^"_CRHDLG_"^"_CRHDLB
+14 DO PATDEMO^CRHDUT2(.CRHDRL,CRHDS)
+15 SET CRHDFLG=CRHDFG
+16 ;Room/Bed
SET CRHDRM=$PIECE($GET(CRHDRL),"^",4)
+17 IF CRHDRM["RM : "
SET CRHDRM=$PIECE(CRHDRM,": ",2)
+18 ;Ward Location
SET CRHDWARD=$PIECE($GET(CRHDRL),"^",5)
+19 IF CRHDWARD["LOC: "
SET CRHDWARD=$PIECE(CRHDWARD,": ",2)
+20 SET CRHDNAME=$PIECE(^DPT(CRHDDFN,0),"^",1)
+21 if CRHDNAME=""
QUIT
+22 IF CRHDFLG=1
Begin DoDot:2
+23 ;S CRHDFLG=0 Q
IF (CRHDWARD="")
SET CRHDWARD="UNK"
+24 ;S CRHDFLG=2 Q
IF (CRHDRM="")
SET CRHDRM="UNK"
+25 ;12/14/09 BAY/KAM CRHD*1*2 Remedy Call 264207 Concatenated CRHDDFN
+26 ; to the next line for subscript
+27 ; uniqueness
+28 ;S CRHDWR(CRHDWARD,CRHDRM,CRHDNAME)=CRHDRL
+29 SET CRHDWR(CRHDWARD,CRHDRM,CRHDNAME_CRHDDFN)=CRHDRL
End DoDot:2
+30 IF CRHDFLG=2
Begin DoDot:2
+31 ;S CRHDFLG=0 Q
IF CRHDWARD=""
SET CRHDWARD="UNK"
+32 ;12/14/09 BAY/KAM CRHD*1*2 Remedy Call 264207 Concatenated CRHDDFN
+33 ; to the next line for subscript
+34 ; uniqueness
+35 ;S CRHDW(CRHDWARD,CRHDNAME)=CRHDRL
+36 SET CRHDW(CRHDWARD,CRHDNAME_CRHDDFN)=CRHDRL
End DoDot:2
+37 ;12/14/2009 BAY/KAM CRHD*1*2 Remedy Call 264207 Concatenated CRHDDFN
+38 ; to the next line for subscript
+39 ; uniqueness
+40 ;I CRHDFLG=0 S CRHDN(CRHDNAME)=CRHDRL
+41 IF CRHDFLG=0
SET CRHDN(CRHDNAME_CRHDDFN)=CRHDRL
End DoDot:1
+42 ;
+43 SET CRHDCT=0
+44 SET CRHDV=0
+45 IF CRHDFG=0
Begin DoDot:1
+46 FOR
SET CRHDV=$ORDER(CRHDN(CRHDV))
if CRHDV=""
QUIT
SET CRHDCT=CRHDCT+1
SET CRHDRTN(CRHDCT)=CRHDN(CRHDV)
+47 KILL CRHDN
End DoDot:1
+48 IF CRHDFG=1
Begin DoDot:1
+49 FOR
SET CRHDV=$ORDER(CRHDWR(CRHDV))
if CRHDV=""
QUIT
SET CRHDV1=""
FOR
SET CRHDV1=$ORDER(CRHDWR(CRHDV,CRHDV1))
if CRHDV1=""
QUIT
SET CRHDV2=""
FOR
SET CRHDV2=$ORDER(CRHDWR(CRHDV,CRHDV1,CRHDV2))
if CRHDV2=""
QUIT
SET CRHDCT=CRHDCT+1
SET CRHDRTN(CRHDCT)=CRHDWR(CRHDV,CRHDV1,CRHDV2)
+50 KILL CRHDWR
End DoDot:1
+51 IF CRHDFG=2
Begin DoDot:1
+52 FOR
SET CRHDV=$ORDER(CRHDW(CRHDV))
if CRHDV=""
QUIT
SET CRHDV1=""
FOR
SET CRHDV1=$ORDER(CRHDW(CRHDV,CRHDV1))
if CRHDV1=""
QUIT
SET CRHDCT=CRHDCT+1
SET CRHDRTN(CRHDCT)=CRHDW(CRHDV,CRHDV1)
+53 KILL CRHDW
End DoDot:1
+54 IF '$DATA(CRHDRTN)
Begin DoDot:1
+55 SET CRHDV=0
+56 IF $DATA(CRHDW)
FOR
SET CRHDV=$ORDER(CRHDW(CRHDV))
if CRHDV=""
QUIT
SET CRHDV1=""
FOR
SET CRHDV1=$ORDER(CRHDW(CRHDV,CRHDV1))
if CRHDV1=""
QUIT
SET CRHDCT=CRHDCT+1
SET CRHDRTN(CRHDCT)=CRHDWR(CRHDV,CRHDV1)
+57 IF $DATA(CRHDN)
FOR
SET CRHDV=$ORDER(CRHDN(CRHDV))
if CRHDV=""
QUIT
SET CRHDCT=CRHDCT+1
SET CRHDRTN(CRHDCT)=CRHDN(CRHDV)
End DoDot:1
+58 QUIT
