PSIVHYP ;BIR/RGY-CALCULATE AND PRINT HYPER ORDERS ;16 DEC 97 / 1:39 PM
;;5.0; INPATIENT MEDICATIONS ;**58,96**;16 DEC 97
;
; Reference to ^PS(55 is supported by DBIA 2191
; Reference to ^PS(52.6 is supported by DBIA# 1231
; Reference to ^PS(52.7 is supported by DBIA# 2173
; Reference to ^PS(50.4 is supported by DBIA 2175
;
K HYPL,HYPA,PSIVPRT S TVOL=0 F Z=52.6,52.7 F DRG=0:0 S DRG=$O(^PS(55,DFN,"IV",+ON,$S(Z=52.6:"AD",1:"SOL"),DRG)) Q:'DRG S DRG=DRG_"^"_^(DRG,0) S:$P(DRG,"^",4)="" $P(DRG,"^",4)="ALL" D DRG
S TVOL=TVOL+.5\1 K EL,DRG,NAD,Z Q
DRG ;
I Z=52.7 S TVOL=TVOL+$P(DRG,"^",3)
NEW ZZ S ZZ=$S(Z=52.6:"AD",1:"SOL")
S NAD=$S('$P(DRG,"^",2):"*",$D(^PS(Z,$P(DRG,"^",2),0)):^(0),1:"*")
I NAD="*" S HYPL(+Z,"*","ALL")=".0001 ***"
I Z=52.6,$S('$D(^PS(52.6,$P(DRG,"^",2),2,0)):1,$P(^(0),"^",4)<1:1,1:0) D ADD Q
F EL=0:0 S EL=$O(^PS(Z,$P(DRG,"^",2),2,EL)) Q:'EL S EL=EL_"^"_^(EL,0) D EL
Q
EL ;
I $S($P(EL,"^",2)="":1,'$D(^PS(50.4,$P(EL,"^",2),0)):1,1:0) S HYPL(Z,"*","ALL")=".0001 ***"_U_$P(EL,U,2) Q
I $P($P($P(EL,"^",3),"/")," ",2)="" S HYPL(50.4,$P(EL,"^",2),"ALL")=".0001 ***"_U_$P(EL,U,2) Q
S ELT=$S($P(NAD,"^",10)!(Z=52.7):$P(DRG,"^",3)/$S(Z=52.7:1,1:$P(NAD,"^",10))*$P(EL,"^",3),1:0)
S HYPL(50.4,$P(EL,"^",2),$P(DRG,"^",4))=$S($D(HYPL(50.4,$P(EL,"^",2),$P(DRG,"^",4))):HYPL(50.4,$P(EL,"^",2),$P(DRG,"^",4)),1:0)+ELT_" "_$P($P($P(EL,"^",3),"/")," ",2)_U_$P(EL,U,2)
;S HYPA(50.4,$P(EL,"^",2),$P(DRG,"^",4))=Z_"^"_+DRG_ZZ
S HYPLRPT($P(EL,U,2),ZZ,+DRG)=""
K ELT Q
ADD S:'$D(HYPL(+Z,+DRG,$P(DRG,"^",4))) HYPL(+Z,+DRG,$P(DRG,"^",4))=0 S HYPL(+Z,+DRG,$P(DRG,"^",4))=HYPL(+Z,+DRG,$P(DRG,"^",4))+$P(DRG,"^",3)_" "_$P($P(DRG,"^",3)," ",2)_U_+DRG_ZZ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVHYP 1701 printed Apr 09, 2024@21:05:54 Page 2
PSIVHYP ;BIR/RGY-CALCULATE AND PRINT HYPER ORDERS ;16 DEC 97 / 1:39 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**58,96**;16 DEC 97
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA 2191
+4 ; Reference to ^PS(52.6 is supported by DBIA# 1231
+5 ; Reference to ^PS(52.7 is supported by DBIA# 2173
+6 ; Reference to ^PS(50.4 is supported by DBIA 2175
+7 ;
+8 KILL HYPL,HYPA,PSIVPRT
SET TVOL=0
FOR Z=52.6,52.7
FOR DRG=0:0
SET DRG=$ORDER(^PS(55,DFN,"IV",+ON,$SELECT(Z=52.6:"AD",1:"SOL"),DRG))
if 'DRG
QUIT
SET DRG=DRG_"^"_^(DRG,0)
if $PIECE(DRG,"^",4)=""
SET $PIECE(DRG,"^",4)="ALL"
DO DRG
+9 SET TVOL=TVOL+.5\1
KILL EL,DRG,NAD,Z
QUIT
DRG ;
+1 IF Z=52.7
SET TVOL=TVOL+$PIECE(DRG,"^",3)
+2 NEW ZZ
SET ZZ=$SELECT(Z=52.6:"AD",1:"SOL")
+3 SET NAD=$SELECT('$PIECE(DRG,"^",2):"*",$DATA(^PS(Z,$PIECE(DRG,"^",2),0)):^(0),1:"*")
+4 IF NAD="*"
SET HYPL(+Z,"*","ALL")=".0001 ***"
+5 IF Z=52.6
IF $SELECT('$DATA(^PS(52.6,$PIECE(DRG,"^",2),2,0)):1,$PIECE(^(0),"^",4)<1:1,1:0)
DO ADD
QUIT
+6 FOR EL=0:0
SET EL=$ORDER(^PS(Z,$PIECE(DRG,"^",2),2,EL))
if 'EL
QUIT
SET EL=EL_"^"_^(EL,0)
DO EL
+7 QUIT
EL ;
+1 IF $SELECT($PIECE(EL,"^",2)="":1,'$DATA(^PS(50.4,$PIECE(EL,"^",2),0)):1,1:0)
SET HYPL(Z,"*","ALL")=".0001 ***"_U_$PIECE(EL,U,2)
QUIT
+2 IF $PIECE($PIECE($PIECE(EL,"^",3),"/")," ",2)=""
SET HYPL(50.4,$PIECE(EL,"^",2),"ALL")=".0001 ***"_U_$PIECE(EL,U,2)
QUIT
+3 SET ELT=$SELECT($PIECE(NAD,"^",10)!(Z=52.7):$PIECE(DRG,"^",3)/$SELECT(Z=52.7:1,1:$PIECE(NAD,"^",10))*$PIECE(EL,"^",3),1:0)
+4 SET HYPL(50.4,$PIECE(EL,"^",2),$PIECE(DRG,"^",4))=$SELECT($DATA(HYPL(50.4,$PIECE(EL,"^",2),$PIECE(DRG,"^",4))):HYPL(50.4,$PIECE(EL,"^",2),$PIECE(DRG,"^",4)),1:0)+ELT_" "_$PIECE($PIECE($PIECE(EL,"^",3),"/")," ",2)_U_$PIECE(EL,U,2)
+5 ;S HYPA(50.4,$P(EL,"^",2),$P(DRG,"^",4))=Z_"^"_+DRG_ZZ
+6 SET HYPLRPT($PIECE(EL,U,2),ZZ,+DRG)=""
+7 KILL ELT
QUIT
ADD if '$DATA(HYPL(+Z,+DRG,$PIECE(DRG,"^",4)))
SET HYPL(+Z,+DRG,$PIECE(DRG,"^",4))=0
SET HYPL(+Z,+DRG,$PIECE(DRG,"^",4))=HYPL(+Z,+DRG,$PIECE(DRG,"^",4))+$PIECE(DRG,"^",3)_" "_$PIECE($PIECE(DRG,"^",3)," ",2)_U_+DRG_ZZ
QUIT
