PSJH1.m

PSJH1 ;BIR/CML3,PR-GET UNIT DOSE/IV ORDERS FOR INPATIENT ; 11/15/07 4:21pm

 ;;5.0; INPATIENT MEDICATIONS ;**35,47,58,85,174,198**;16 DEC 97;Build 7

 ;

 ;Reference to ^PS(50.7 is supported by DBIA 2180

 ;Reference to ^PS(55 is supported by DBIA 2191

 ;Reference to ^%DTC is supported by DBIA 10000

 ;Reference to ^%ZOSV is supported by DBIA 10097

 ;Reference to ^XLFDT is supported by DBIA 10103

 ;

ECHK ;

 S C="A",DRG=$P($G(^PS(55,PSGP,5,+O,.2)),"^") S:PSJOS START=-$P($G(^(2)),"^",2)

 S O=O_"U"

 G:SD>PSGDT SET S ND=$G(^PS(55,PSGP,5,+O,0)) G:$S($P(ND,"^",9)="":1,1:"DE"'[$P(ND,"^",9)) SET S ND4=$G(^(4)) I ST'="O",SD'<PSGODT,$S($P(ND,"^",9)="E":$P(ND4,"^",16),1:0)

 E  I ST="O",$P(ND,"^",9)="E",$S('$P(ND4,"^",UDU):1,SD<PSGODT:0,1:$P(ND4,"^",16))

 E  Q:PSJOL="S"  S C="O"

 ;

SET ;

 S DN=$S(DRG="":"NOT FOUND",'$D(^PS(50.7,DRG,0)):"NOT FOUND ("_DRG_")",$P(^(0),"^")]"":$P(^(0),"^"),1:DRG_";PS(50.7,"),NF=$P(DN,"^",9),SUB=$S(PSJOS:START,1:$E(DN,1,50))

 S ^TMP("PSJ",$J,C,$S(PSJOS:SUB,1:ST),$S(PSJOS:ST,1:SUB),O)=DN_"^"_NF,PSJOCNT=PSJOCNT+1 Q

 ;

IVSET ; Set IV data in ^TMP("PSJ",$J,.

 N DRG,DRGT,ON55,ORTX,P,STAT,TYP,X,Y,ND

 ;GMZ;PSJ*5*198;Change date search criteria for IV orders to be consistent with the way unit dose orders work

 I ON["V" S ON55=ON,Y=$G(^PS(55,DFN,"IV",+ON,0)) Q:$D(PSJHDATE)&($P(Y,"^",3)<PSJHDATE)  F X=2,3,4,9,17 S P(X)=$P(Y,U,X)

 I ON'["V" S ND=$G(^PS(53.1,+ON,0)) I 'ND K ^PS(53.1,"AS",SD,PSGP,+ON) Q

 I ON'["V",ND S P(17)=$P($G(^PS(53.1,+ON,0)),U,9),Y=$G(^PS(53.1,+ON,2)),P(9)=$P(Y,U),P(2)=$P(Y,U,2),P(3)=$P(Y,U,4),P(4)=$P($G(^PS(53.1,+ON,8)),U)

 G:PSJOS IVSET1 I P(4)="H" S ORTX="* TPN *" G IVSET1

 I P(4)="A" D @$S(ON["V":"GTDRG^PSIVORFB",1:"GTDRG^PSIVORFA"),GTOT^PSIVUTL(P(4)) I $E(P("OT"))="F" S DRGT=$O(DRG(0)),Y=$O(DRG(DRGT,0)),ORTX=$P(DRG(DRGT,Y),U,2) G IVSET1

 S ORTX=$$ENPDN^PSGMI(+$S(ON["V":$G(^PS(55,DFN,"IV",+ON,6)),1:$G(^PS(53.1,+ON,.1))))

 ;

IVSET1 ;

 S TYP=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3)) I TYP'="O" S TYP="C"

 S STAT=$S("ED"[P(17):"O",P(17)="P":"NZ",1:"A"),^TMP("PSJ",$J,STAT,$S(PSJOS:-P(2),1:TYP),$S(PSJOS:TYP,1:ORTX),ON)="",PSJOCNT=PSJOCNT+1

 Q

 ;

ENU ; update status field to reflect expired orders, if necessary

 W !!,"...a few moments, I have some updating to do..."

ENUNM ;

 F Q=+PSJPAD:0 S Q=$O(^PS(55,PSGP,5,"AUS",Q)) Q:'Q!(Q>PSGDT)  S UPD=Q F QQ=0:0 S QQ=$O(^PS(55,PSGP,5,"AUS",Q,QQ)) Q:'QQ  I $D(^PS(55,PSGP,5,QQ,0)),"DEH"'[$E($P(^(0),"^",9)) S $P(^(0),"^",9)="E"

 K UPD Q

 ;

EN ; enter here

 I PSJOL="L",$D(XRTL) D T0^%ZOSV

 K ^TMP("PSJ",$J) D NOW^%DTC S PSGDT=+$E(%,1,12),DT=$$DT^XLFDT,PSJOS=$P(PSJSYSP0,"^",11),UDU=$S($P(PSJSYSU,";",3)>1:3,1:1) S:'$D(PSJHDATE) PSJHDATE=0

 S PSJOCNT=0 F PSJORD=0:0 S PSJORD=$O(^PS(55,DFN,"IV",PSJORD)) Q:'PSJORD  D

 .S X=$G(^PS(55,DFN,"IV",+PSJORD,0))

 .S Y=$P(X,U,17)

 .S ON=+PSJORD_"V" D IVSET

 D NOW^%DTC S PSJIVOF=PSJOCNT,PSGDT=%,X1=$P(%,"."),X2=-2 D C^%DTC S PSGODT=X_(PSGDT#1),HDT=$$ENDTC^PSGMI(PSGDT)

 F ST="C","O","OC","P","R" F SD=+PSJHDATE:0 S SD=$O(^PS(55,PSGP,5,"AU",ST,SD)) Q:'SD  F O=0:0 S O=$O(^PS(55,PSGP,5,"AU",ST,SD,O)) Q:'O  D ECHK

 Q:$D(PSGONNV)

 F SD="I","N" S O=0 F  S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O  D NVSET

 ;I $S(+PSJSYSU=3:1,1:$D(PSGLPF)) S SD="P",O=0 F  S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O  S ON=O_"P" D @$S($P($G(^PS(53.1,O,0)),U,4)="F":"IVSET",1:"NVSET")

 S SD="P",O=0 F  S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O  S ON=O_"P" D @$S($P($G(^PS(53.1,O,0)),U,4)="F":"IVSET",1:"NVSET")

 I PSJOL="L",$D(XRT0) S XRTN="PSJO1" D T1^%ZOSV

 Q

 ;

NVSET ; Set up orders from 53.1.

 N ND,OSAVE,PORD S ND=$G(^PS(53.1,O,0)) I 'ND D  Q

 .K ^PS(53.1,"AS",SD,PSGP,O)

 S ST=$P($G(^PS(53.1,O,0)),U,7),START=-$P($G(^(2)),U,2),DRG=$P($G(^(.2)),U),C="N"_$TR(SD,"NIP","XYZ") S:ST="" ST="z"

 S PORD=$P($G(^PS(53.1,O,.2)),U,8),OSAVE=O,O=$S(PORD:PORD,1:O_"P") D SET S O=+OSAVE

 Q

 ;

KILL ;

 K P,STAT,TYP,ORTX,N,JJ

 Q

PSJH1     ;BIR/CML3,PR-GET UNIT DOSE/IV ORDERS FOR INPATIENT ; 11/15/07 4:21pm

 +1       ;;5.0; INPATIENT MEDICATIONS ;**35,47,58,85,174,198**;16 DEC 97;Build 7

 +2       ;

 +3       ;Reference to ^PS(50.7 is supported by DBIA 2180

 +4       ;Reference to ^PS(55 is supported by DBIA 2191

 +5       ;Reference to ^%DTC is supported by DBIA 10000

 +6       ;Reference to ^%ZOSV is supported by DBIA 10097

 +7       ;Reference to ^XLFDT is supported by DBIA 10103

 +8       ;

ECHK      ;

 +1        SET C="A"

           SET DRG=$PIECE($GET(^PS(55,PSGP,5,+O,.2)),"^")

           IF PSJOS

               SET START=-$PIECE($GET(^(2)),"^",2)

 +2        SET O=O_"U"

 +3        IF SD>PSGDT

               GOTO SET

           SET ND=$GET(^PS(55,PSGP,5,+O,0))

           IF $SELECT($PIECE(ND,"^",9)=""

               GOTO SET

           SET ND4=$GET(^(4))

           IF ST'="O"

               IF SD'<PSGODT

                   IF $SELECT($PIECE(ND,"^",9)="E":$PIECE(ND4,"^",16),1:0)

 +4       IF '$TEST

               IF ST="O"

                   IF $PIECE(ND,"^",9)="E"

                       IF $SELECT('$PIECE(ND4,"^",UDU):1,SD<PSGODT:0,1:$PIECE(ND4,"^",16))

 +5       IF '$TEST

               IF PSJOL="S"

                   QUIT 

               SET C="O"

 +6       ;

SET       ;

 +1        SET DN=$SELECT(DRG="":"NOT FOUND",'$DATA(^PS(50.7,DRG,0)):"NOT FOUND ("_DRG_")",$PIECE(^(0),"^")]"":$PIECE(^(0),"^"),1:DRG_";PS(50.7,")

           SET NF=$PIECE(DN,"^",9)

           SET SUB=$SELECT(PSJOS:START,1:$EXTRACT(DN,1,50))

 +2        SET ^TMP("PSJ",$JOB,C,$SELECT(PSJOS:SUB,1:ST),$SELECT(PSJOS:ST,1:SUB),O)=DN_"^"_NF

           SET PSJOCNT=PSJOCNT+1

           QUIT 

 +3       ;

IVSET     ; Set IV data in ^TMP("PSJ",$J,.

 +1        NEW DRG,DRGT,ON55,ORTX,P,STAT,TYP,X,Y,ND

 +2       ;GMZ;PSJ*5*198;Change date search criteria for IV orders to be consistent with the way unit dose orders work

 +3        IF ON["V"

               SET ON55=ON

               SET Y=$GET(^PS(55,DFN,"IV",+ON,0))

               IF $DATA(PSJHDATE)&($PIECE(Y,"^",3)<PSJHDATE)

                   QUIT 

               FOR X=2,3,4,9,17

                   SET P(X)=$PIECE(Y,U,X)

 +4        IF ON'["V"

               SET ND=$GET(^PS(53.1,+ON,0))

               IF 'ND

                   KILL ^PS(53.1,"AS",SD,PSGP,+ON)

                   QUIT 

 +5        IF ON'["V"

               IF ND

                   SET P(17)=$PIECE($GET(^PS(53.1,+ON,0)),U,9)

                   SET Y=$GET(^PS(53.1,+ON,2))

                   SET P(9)=$PIECE(Y,U)

                   SET P(2)=$PIECE(Y,U,2)

                   SET P(3)=$PIECE(Y,U,4)

                   SET P(4)=$PIECE($GET(^PS(53.1,+ON,8)),U)

 +6        IF PSJOS

               GOTO IVSET1

           IF P(4)="H"

               SET ORTX="* TPN *"

               GOTO IVSET1

 +7        IF P(4)="A"

               DO @$SELECT(ON["V":"GTDRG^PSIVORFB",1:"GTDRG^PSIVORFA")

               DO GTOT^PSIVUTL(P(4))

               IF $EXTRACT(P("OT"))="F"

                   SET DRGT=$ORDER(DRG(0))

                   SET Y=$ORDER(DRG(DRGT,0))

                   SET ORTX=$PIECE(DRG(DRGT,Y),U,2)

                   GOTO IVSET1

 +8        SET ORTX=$$ENPDN^PSGMI(+$SELECT(ON["V":$GET(^PS(55,DFN,"IV",+ON,6)),1:$GET(^PS(53.1,+ON,.1))))

 +9       ;

IVSET1    ;

 +1        SET TYP=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3))

           IF TYP'="O"

               SET TYP="C"

 +2        SET STAT=$SELECT("ED"[P(17):"O",P(17)="P":"NZ",1:"A")

           SET ^TMP("PSJ",$JOB,STAT,$SELECT(PSJOS:-P(2),1:TYP),$SELECT(PSJOS:TYP,1:ORTX),ON)=""

           SET PSJOCNT=PSJOCNT+1

 +3        QUIT 

 +4       ;

ENU       ; update status field to reflect expired orders, if necessary

 +1        WRITE !!,"...a few moments, I have some updating to do..."

ENUNM     ;

 +1        FOR Q=+PSJPAD:0

               SET Q=$ORDER(^PS(55,PSGP,5,"AUS",Q))

               IF 'Q!(Q>PSGDT)

                   QUIT 

               SET UPD=Q

               FOR QQ=0:0

                   SET QQ=$ORDER(^PS(55,PSGP,5,"AUS",Q,QQ))

                   IF 'QQ

                       QUIT 

                   IF $DATA(^PS(55,PSGP,5,QQ,0))

                       IF "DEH"'[$EXTRACT($PIECE(^(0),"^",9))

                           SET $PIECE(^(0),"^",9)="E"

 +2        KILL UPD

           QUIT 

 +3       ;

EN        ; enter here

 +1        IF PSJOL="L"

               IF $DATA(XRTL)

                   DO T0^%ZOSV

 +2        KILL ^TMP("PSJ",$JOB)

           DO NOW^%DTC

           SET PSGDT=+$EXTRACT(%,1,12)

           SET DT=$$DT^XLFDT

           SET PSJOS=$PIECE(PSJSYSP0,"^",11)

           SET UDU=$SELECT($PIECE(PSJSYSU,";",3)>1:3,1:1)

           IF '$DATA(PSJHDATE)

               SET PSJHDATE=0

 +3        SET PSJOCNT=0

           FOR PSJORD=0:0

               SET PSJORD=$ORDER(^PS(55,DFN,"IV",PSJORD))

               IF 'PSJORD

                   QUIT 

               Begin DoDot:1

 +4                SET X=$GET(^PS(55,DFN,"IV",+PSJORD,0))

 +5                SET Y=$PIECE(X,U,17)

 +6                SET ON=+PSJORD_"V"

                   DO IVSET

               End DoDot:1

 +7        DO NOW^%DTC

           SET PSJIVOF=PSJOCNT

           SET PSGDT=%

           SET X1=$PIECE(%,".")

           SET X2=-2

           DO C^%DTC

           SET PSGODT=X_(PSGDT#1)

           SET HDT=$$ENDTC^PSGMI(PSGDT)

 +8        FOR ST="C","O","OC","P","R"

               FOR SD=+PSJHDATE:0

                   SET SD=$ORDER(^PS(55,PSGP,5,"AU",ST,SD))

                   IF 'SD

                       QUIT 

                   FOR O=0:0

                       SET O=$ORDER(^PS(55,PSGP,5,"AU",ST,SD,O))

                       IF 'O

                           QUIT 

                       DO ECHK

 +9        IF $DATA(PSGONNV)

               QUIT 

 +10       FOR SD="I","N"

               SET O=0

               FOR 

                   SET O=$ORDER(^PS(53.1,"AS",SD,PSGP,O))

                   IF 'O

                       QUIT 

                   DO NVSET

 +11      ;I $S(+PSJSYSU=3:1,1:$D(PSGLPF)) S SD="P",O=0 F  S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O  S ON=O_"P" D @$S($P($G(^PS(53.1,O,0)),U,4)="F":"IVSET",1:"NVSET")

 +12       SET SD="P"

           SET O=0

           FOR 

               SET O=$ORDER(^PS(53.1,"AS",SD,PSGP,O))

               IF 'O

                   QUIT 

               SET ON=O_"P"

               DO @$SELECT($PIECE($GET(^PS(53.1,O,0)),U,4)="F":"IVSET",1:"NVSET")

 +13       IF PSJOL="L"

               IF $DATA(XRT0)

                   SET XRTN="PSJO1"

                   DO T1^%ZOSV

 +14       QUIT 

 +15      ;

NVSET     ; Set up orders from 53.1.

 +1        NEW ND,OSAVE,PORD

           SET ND=$GET(^PS(53.1,O,0))

           IF 'ND

               Begin DoDot:1

 +2                KILL ^PS(53.1,"AS",SD,PSGP,O)

               End DoDot:1

               QUIT 

 +3        SET ST=$PIECE($GET(^PS(53.1,O,0)),U,7)

           SET START=-$PIECE($GET(^(2)),U,2)

           SET DRG=$PIECE($GET(^(.2)),U)

           SET C="N"_$TRANSLATE(SD,"NIP","XYZ")

           IF ST=""

               SET ST="z"

 +4        SET PORD=$PIECE($GET(^PS(53.1,O,.2)),U,8)

           SET OSAVE=O

           SET O=$SELECT(PORD:PORD,1:O_"P")

           DO SET

           SET O=+OSAVE

 +5        QUIT 

 +6       ;

KILL      ;

 +1        KILL P,STAT,TYP,ORTX,N,JJ

 +2        QUIT