PSIVHYP.m

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

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