PSOMHV1.m

PSOMHV1 ;BIR/MHA - MHV API, Build patient medication ; 4/20/05 8:54am

 ;;7.0;OUTPATIENT PHARMACY;**204**;DEC 1997

 ;External reference ^PS(55 supported by DBIA 2228

 ;External reference ^PSDRUG( supported by DBIA 221

 ;External reference to ^PS(51 supported by DBIA 2224

 ;External reference to ^PS(51.2 supported by DBIA 2226

 ;External reference to ^PS(50.7 supported by DBIA 2223

 ;External reference to ^PS(50.606 supported by DBIA 2174

 ; Input variables: dfn, start date, cut off date

EN(DFN,BDT,EDT) ;entry point to return medication list

 Q:'$G(DFN)

 N DRG,DRGN,EXD,I,IFN,MIG,LSTFD,ORD,PEN,PSOBD,PSOED,PSODD,PSOOI,PSOSD,RX,RX0,RX2,RX3,TFN,TD,TR,TRM,SC,SCH,ST0,STA,PSODIV

 I '$G(DT) S DT=$$DT^XLFDT

 K ^TMP("PSO",$J) S PSOBD=$G(BDT),PSOED=$G(EDT)

 I +$G(PSOBD)<1 S X1=DT,X2=-120 D C^%DTC S PSOBD=X

 S EXD=PSOBD-1

 I PSOED="" S PSOED=9999999

 F  S EXD=$O(^PS(55,DFN,"P","A",EXD)) Q:'EXD  Q:EXD>PSOED  D

 .S RX=0 F  S RX=$O(^PS(55,DFN,"P","A",EXD,RX)) Q:'RX  D:$D(^PSRX(RX,0)) GET

 S STA="ACT^NVR^REF^HLD^NVR^SUS^^^^^^EXP^DCD^DEL^DCD^DCD^HLD"

 S DRG="" F  S DRG=$O(PSOSD(DRG)) Q:DRG=""  D:$G(PSOSD(DRG))]"" 

 .S PSOSD($P(STA,"^",$P(PSOSD(DRG),"^",2)+1),DRG)=PSOSD(DRG) K PSOSD(DRG)

 D PEN D:$D(PSOSD) BLD

 Q

EN2(DFN,RXLIST) ;Entry point to return data for specified RX #s

 Q:DFN<1

 Q:'RXLIST

 N DRG,DRGN,EXD,I,IFN,MIG,LSTFD,ORD,PEN,PSOBD,PSOED,PSODD,PSOOI,PSOSD,RX,RX0,RX2,RX3,TFN,TD,TR,TRM,SC,SCH,ST0,STA,PSORX,J,PSOERR,RX,PSRXD,PSODIV,PSOSTA

 I '$G(DT) S DT=$$DT^XLFDT

 K ^TMP("PSO",$J)

 S PSOSTA="ACT^NVR^REF^HLD^NVR^SUS^^^^^^EXP^DCD^DEL^DCD^DCD^HLD"

 F J=1:1 S PSORX=$P(RXLIST,"^",J) Q:PSORX=""  D

 . I '$D(^PSRX("B",PSORX)) Q

 . I $O(^PSRX("B",PSORX,""))="" Q

 . S RX=$O(^PSRX("B",PSORX,"")),PSRXD=$G(^PSRX(RX,0))

 . Q:PSRXD=""

 . Q:$P(PSRXD,"^",2)'=DFN

 . Q:$P($G(^PSRX(RX,"STA")),"^")=13

 . Q:$P($G(^PSRX(RX,"STA")),"^")=15

 . Q:'$D(^PSDRUG($P(PSRXD,"^",6),0))

 . S IFN=RX,TR=$P(PSOSTA,"^",$P($G(^PSRX(RX,"STA")),"^")+1)

 . S TD=$P(^PSDRUG($P(PSRXD,"^",6),0),"^")

 . D RXD

 . Q

 Q

 ;

EN3(DFN,BDT,EDT) ;entry point to return prescription history

 Q:'$G(DFN)

 N DRG,DRGN,EXD,I,IFN,MIG,LSTFD,ORD,PEN,PSOBD,PSOED,PSODD,PSOOI,PSOSD,RX,RX0,RX2,RX3,TFN,TD,TR,TRM,SC,SCH,ST0,STA,PSODIV

 I '$G(DT) S DT=$$DT^XLFDT

 K ^TMP("PSO",$J) S PSOBD=$G(BDT),PSOED=$G(EDT)

 I +$G(PSOBD)<1 S X1=DT,X2=-120 D C^%DTC S PSOBD=X

 S EXD=PSOBD-1

 I PSOED="" S PSOED=9999999

 F  S EXD=$O(^PS(55,DFN,"P","A",EXD)) Q:'EXD  Q:EXD>PSOED  D

 .S RX=0 F  S RX=$O(^PS(55,DFN,"P","A",EXD,RX)) Q:'RX  D:$D(^PSRX(RX,0)) GET1

 S STA="ACT^NVR^REF^HLD^NVR^SUS^^^^^^EXP^DCD^DEL^DCD^DCD^HLD"

 ; Uses RX (Rx IEN) instead of DRUG as a subscript in PSOSD and thus

 ; in ^TMP("PSO",$J).  Other entry points use DRUG

 S RX="" F  S RX=$O(PSOSD(RX)) Q:RX=""  D:$G(PSOSD(RX))]""

 .S PSOSD($P(STA,"^",$P(PSOSD(RX),"^",2)+1),RX)=PSOSD(RX) K PSOSD(RX)

 D:$D(PSOSD) BLD

 Q

 ;

PEN F PEN=0:0 S PEN=$O(^PS(52.41,"P",DFN,PEN)) Q:'PEN  D

 .S ORD=^PS(52.41,PEN,0) Q:$P(ORD,"^",2)'=DFN  S DRG=""

 .Q:$P(ORD,"^",3)="DC"!($P(ORD,"^",3)="DE")!($P(ORD,"^",3)="")!($P(ORD,"^",3)="RF")

 .S PSOOI=$P(ORD,"^",8),PSODD=+$P(ORD,"^",9)

 .S DRG=$S(PSODD:$P($G(^PSDRUG(PSODD,0)),"^"),+PSOOI&('PSODD):$P(^PS(50.7,+PSOOI,0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,+PSOOI,0),"^",2),0),"^"),1:"")

 .Q:DRG']""

 .I $D(PSOSD("PEN",DRG)) S DRG=DRG_"^"_PEN

 .S PSOSD("PEN",DRG)=PEN

 Q

GET ;

 Q:$P($G(^PSRX(RX,"STA")),"^")=13

 Q:$P($G(^PSRX(RX,"STA")),"^")=15

 Q:'$P(^PSRX(RX,0),"^",2)

 Q:$P(^PSRX(RX,0),"^",2)'=DFN

 S RX0=^PSRX(RX,0),RX2=^PSRX(RX,2)

 S DRG=$P(^PSRX(RX,0),"^",6),STA=+^("STA") Q:'$D(^PSDRUG(DRG,0))

 S DRGN=$P(^PSDRUG(DRG,0),"^"),ST0=$S(STA<12&($P(RX2,"^",6)<DT):11,1:STA)

 I $D(PSOSD(DRGN)),ST0>10 Q:$P(PSOSD(DRGN),"^",2)<11  Q:$P(PSOSD(DRGN),"^",2)>10&($P(RX0,"^",13)<$P(^PSRX(+$P(PSOSD(DRGN),"^"),0),"^",13))

 I $D(PSOSD(DRGN)),$P(PSOSD(DRGN),"^",2)<10,ST0<10 S PSOSD(DRGN_"^"_RX)=RX_"^"_ST0

 E  S PSOSD(DRGN)=RX_"^"_ST0

 Q

GET1 ;

 Q:'$P(^PSRX(RX,0),"^",2)

 Q:$P(^PSRX(RX,0),"^",2)'=DFN

 S RX0=^PSRX(RX,0),RX2=^PSRX(RX,2)

 S DRG=$P(^PSRX(RX,0),"^",6),STA=+^("STA") Q:'$D(^PSDRUG(DRG,0))

 S DRGN=$P(^PSDRUG(DRG,0),"^"),ST0=$S(STA<12&($P(RX2,"^",6)<DT):11,1:STA)

 S PSOSD(RX)=RX_"^"_ST0

 Q

BLD ;

 S TR="" F  S TR=$O(PSOSD(TR)) Q:TR=""  D

 .S TFN=0,TD="" F  S TD=$O(PSOSD(TR,TD)) Q:TD=""  S IFN=+PSOSD(TR,TD) D @$S(TR="PEN":"PND",1:"RXD")

 Q

RXD ;

 Q:'$D(^PSRX(IFN,0))

 S RX0=^PSRX(IFN,0),RX2=$G(^(2)),RX3=$G(^(3)),STA=+$G(^("STA")),TRM=0,LSTFD=$P(RX2,"^",2)

 S ^TMP("PSO",$J,TR,TD,"RXN",0)=$P(RX0,"^")_"^"_$E($P(RX2,"^",13),1,7)_"^"_$S($P(RX0,"^",11)="W":"W",1:"M")_"^"_$P(RX3,"^",7)

 S ^TMP("PSO",$J,TR,TD,"RXN",0)=^TMP("PSO",$J,TR,TD,"RXN",0)_"^"_$S($P($G(^PSRX(IFN,"OR1")),"^",5):$P(^PSRX(IFN,"OR1"),"^",5),1:"")_"^"_$E($P(RX2,"^",2),1,7)_"^"_$E($P(RX2,"^",13),1,7)_"^^"_IFN

 S I=0 F  S I=$O(^PSRX(IFN,1,I)) Q:'I  S TRM=TRM+1,LSTFD=$P(^PSRX(IFN,1,I,0),"^") D

 .S ^TMP("PSO",$J,TR,TD,"REF",I,0)=$P(^PSRX(IFN,1,I,0),"^")_"^"_$P(^(0),"^",10)_"^"_$P(^(0),"^",4)_"^"_$E($P(^(0),"^",18),1,7)_"^"_$S($P(^(0),"^",2)="W":"W",1:"M")_"^"_$P(^(0),"^",3)

 .I $P(^PSRX(IFN,1,I,0),"^",18) S $P(^TMP("PSO",$J,TR,TD,"RXN",0),"^",2)=$E($P(^PSRX(IFN,1,I,0),"^",18),1,7)

 .S ^TMP("PSO",$J,TR,TD,"REF",0)=$G(^TMP("PSO",$J,TR,TD,"REF",0))+1

 S I=0 F  S I=$O(^PSRX(IFN,"P",I)) Q:'I  D

 .S ^TMP("PSO",$J,TR,TD,"PAR",I,0)=$P(^PSRX(IFN,"P",I,0),"^")_"^"_$P(^(0),"^",10)_"^"_$P(^(0),"^",4)_"^"_$E($P(^(0),"^",19),1,7)_"^"_$S($P(^(0),"^",2)="W":"W",1:"M")_"^"_$P(^(0),"^",3)

 .S ^TMP("PSO",$J,TR,TD,"PAR",0)=$G(^TMP("PSO",$J,TR,TD,"PAR",0))+1

 S ^TMP("PSO",$J,TR,TD,0)=$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^")_"^^"_$P(RX2,"^",6)

 S ^TMP("PSO",$J,TR,TD,"P",0)=$P(RX0,"^",4)_"^"_$P($G(^VA(200,+$P(RX0,"^",4),0)),"^")

 S ST0=$S(STA<12&($P(RX2,"^",6)<DT):11,1:STA)

 S SC=$P("ERROR^ACTIVE^NON-VERIFIED^REFILL FILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^DONE^EXPIRED^DISCONTINUED^DELETED^DISCONTINUED^DISCONTINUED (EDIT)^HOLD^","^",ST0+2)

 S ^TMP("PSO",$J,TR,TD,0)=^TMP("PSO",$J,TR,TD,0)_"^"_($P(RX0,"^",9)-TRM)_"^"_$P(RX0,"^",13)_"^"_SC_"^"_$P(RX0,"^",8)_"^"_$P(RX0,"^",7)_"^^^"_$P($G(^PSRX(IFN,"OR1")),"^",2)_"^"_LSTFD_"^^"

 S ^TMP("PSO",$J,TR,TD,"DD",0)=1,^TMP("PSO",$J,TR,TD,"DD",1,0)=$P(RX0,"^",6)_"^^"

 S (SCH,SC)=0

 F  S SC=$O(^PSRX(IFN,"SCH",SC)) Q:'SC  S SCH=SCH+1,^TMP("PSO",$J,TR,TD,"SCH",SCH,0)=$P(^PSRX(IFN,"SCH",SC,0),"^") D

 .S ^TMP("PSO",$J,TR,TD,"SCH",0)=$G(^TMP("PSO",$J,TR,TD,"SCH",0))+1

 D MDR

 S SC=0 I $D(^PSRX(IFN,"SIG")),'$P(^PSRX(IFN,"SIG"),"^",2) S SC=1 S X=$P(^PSRX(IFN,"SIG"),"^") D SIG

 I '$G(SC) S SCH=1 D

 .S ^TMP("PSO",$J,TR,TD,"SIG",SCH,0)=$G(^PSRX(IFN,"SIG1",1,0)),^TMP("PSO",$J,TR,TD,"SIG",0)=SCH

 .F I=1:0 S I=$O(^PSRX(IFN,"SIG1",I)) Q:'I  S SCH=SCH+1,^TMP("PSO",$J,TR,TD,"SIG",SCH,0)=^PSRX(IFN,"SIG1",I,0),^TMP("PSO",$J,TR,TD,"SIG",0)=SCH

 S (I,SC)=0

 F  S I=$O(^PSRX(IFN,"PRC",I)) Q:'I  S SC=SC+1 D

 .S ^TMP("PSO",$J,TR,TD,"PC",SC,0)=^PSRX(IFN,"PRC",I,0),^TMP("PSO",$J,TR,TD,"PC",0)=SC

 S PSODIV=$P(RX2,"^",9)

 I PSODIV'="",$D(^PS(59,PSODIV,0)) S ^TMP("PSO",$J,TR,TD,"DIV",0)=PSODIV_"^"_^PS(59,PSODIV,0)

 Q

MDR ;

 S (SCH,SC)=0

 F  S SC=$O(^PSRX(IFN,"MEDR",SC)) Q:'SC  D

 .Q:'$D(^PS(51.2,+^PSRX(IFN,"MEDR",SC,0),0))  S SCH=SCH+1

 .S ^TMP("PSO",$J,TR,TD,"MDR",SCH,0)=$S($P(^PS(51.2,+^PSRX(IFN,"MEDR",SC,0),0),"^",3)]"":$P(^(0),"^",3),1:$P(^(0),"^"))

 .S ^TMP("PSO",$J,TR,TD,"MDR",0)=SCH

 Q

PND Q:'$D(^PS(52.41,IFN,0))

 S ORD=^PS(52.41,IFN,0) Q:$P(ORD,"^",2)'=DFN

 Q:$P(ORD,"^",3)="DC"!($P(ORD,"^",3)="DE")

 S PSOOI=+$P(ORD,"^",8),PSODD=+$P(ORD,"^",9)

 S DRG=$S(PSODD:$P($G(^PSDRUG(PSODD,0)),"^"),1:$P(^PS(50.7,PSOOI,0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,PSOOI,0),"^",2),0),"^"))

 S ^TMP("PSO",$J,TR,TD,0)=DRG

 S:PSODD ^TMP("PSO",$J,TR,TD,"DD",0)=1,^TMP("PSO",$J,TR,TD,"DD",1,0)=PSODD_"^^"

 S ^TMP("PSO",$J,TR,TD,0)=^TMP("PSO",$J,TR,TD,0)_"^"_$S($G(^PS(51.2,+$P(ORD,"^",15),0))]"":$P(^PS(51.2,+$P(ORD,"^",15),0),"^",3),1:"")

 S ^TMP("PSO",$J,TR,TD,0)=^TMP("PSO",$J,TR,TD,0)_"^^"_$P(ORD,"^",11)_"^"_$P($P(ORD,"^",6),".")_"^"_$S($P(ORD,"^",3)'="HD":"PENDING",1:" ONHOLD")_"^^"_$P(ORD,"^",10)

 S $P(^TMP("PSO",$J,TR,TD,0),"^",11)=$P(ORD,"^")

 S (SC,SCH)=0 F  S SC=$O(^PS(52.41,IFN,1,SC)) Q:'SC  D

 .S SCH=SCH+1,^TMP("PSO",$J,TR,TD,"SCH",SCH,0)=$P(^PS(52.41,IFN,1,SC,1),"^"),^TMP("PSO",$J,TR,TD,"SCH",0)=SCH

 S (SC,SCH)=0 F  S SC=$O(^PS(52.41,IFN,"SIG",SC)) Q:'SC  D

 .S SCH=SCH+1,^TMP("PSO",$J,TR,TD,"SIG",SCH,0)=$P(^PS(52.41,IFN,"SIG",SC,0),"^"),^TMP("PSO",$J,TR,TD,"SIG",0)=SCH

 S SC=1,PEN="" F  S PEN=$O(^PS(52.41,IFN,2,PEN)) Q:'PEN  D

 .S MIG=^PS(52.41,IFN,2,PEN,0),^TMP("PSO",$J,TR,TD,"SIO",0)=SC D

 ..F SCH=1:1:$L(MIG," ") S:$L($G(^TMP("PSO",$J,TR,TD,"SIO",SC,0))_" "_$P(MIG,"",SCH))>80 SC=SC+1,^TMP("PSO",$J,TR,TD,"SIO",0)=SC D

 ...S ^TMP("PSO",$J,TR,TD,"SIO",SC,0)=$G(^TMP("PSO",$J,TR,TD,"SIO",SC,0))_" "_$P(MIG," ",SCH)

 Q

SIG ;

 N Z0,Z1,PSOX1,PSOX2 F Z0=1:1:$L(X," ") Q:Z0=""  S Z1=$P(X," ",Z0) D

 .D:$D(X)&($G(Z1)]"")

 ..S Y=$O(^PS(51,"B",Z1,0)) Q:'Y!($P($G(^PS(51,+Y,0)),"^",4)>1)  S Z1=$P(^PS(51,Y,0),"^",2) Q:'$D(^(9))  S Y=$P(X," ",Z0-1),Y=$E(Y,$L(Y)) S:Y>1 Z1=^(9)

 .I $G(^TMP("PSO",$J,TR,TD,"SIG",1,0))']"" S ^TMP("PSO",$J,TR,TD,"SIG",1,0)=Z1,^TMP("PSO",$J,TR,TD,"SIG",0)=1 Q

 .F PSOX1=0:0 S PSOX1=$O(^TMP("PSO",$J,TR,TD,"SIG",PSOX1)) Q:'PSOX1  S PSOX2=PSOX1

 .I $L(^TMP("PSO",$J,TR,TD,"SIG",PSOX2,0))+$L(Z1)<245 S ^TMP("PSO",$J,TR,TD,"SIG",PSOX2,0)=^TMP("PSO",$J,TR,TD,"SIG",PSOX2,0)_" "_Z1

 .E  S PSOX2=PSOX2+1,^TMP("PSO",$J,TR,TD,"SIG",PSOX2,0)=Z1

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSOMHV1   9465     printed  Mar 13, 2025@21:36:06                                                                                                                                                                                                     Page 2

PSOMHV1   ;BIR/MHA - MHV API, Build patient medication ; 4/20/05 8:54am

 +1       ;;7.0;OUTPATIENT PHARMACY;**204**;DEC 1997

 +2       ;External reference ^PS(55 supported by DBIA 2228

 +3       ;External reference ^PSDRUG( supported by DBIA 221

 +4       ;External reference to ^PS(51 supported by DBIA 2224

 +5       ;External reference to ^PS(51.2 supported by DBIA 2226

 +6       ;External reference to ^PS(50.7 supported by DBIA 2223

 +7       ;External reference to ^PS(50.606 supported by DBIA 2174

 +8       ; Input variables: dfn, start date, cut off date

EN(DFN,BDT,EDT) ;entry point to return medication list

 +1        if '$GET(DFN)

               QUIT 

 +2        NEW DRG,DRGN,EXD,I,IFN,MIG,LSTFD,ORD,PEN,PSOBD,PSOED,PSODD,PSOOI,PSOSD,RX,RX0,RX2,RX3,TFN,TD,TR,TRM,SC,SCH,ST0,STA,PSODIV

 +3        IF '$GET(DT)

               SET DT=$$DT^XLFDT

 +4        KILL ^TMP("PSO",$JOB)

           SET PSOBD=$GET(BDT)

           SET PSOED=$GET(EDT)

 +5        IF +$GET(PSOBD)<1

               SET X1=DT

               SET X2=-120

               DO C^%DTC

               SET PSOBD=X

 +6        SET EXD=PSOBD-1

 +7        IF PSOED=""

               SET PSOED=9999999

 +8        FOR 

               SET EXD=$ORDER(^PS(55,DFN,"P","A",EXD))

               if 'EXD

                   QUIT 

               if EXD>PSOED

                   QUIT 

               Begin DoDot:1

 +9                SET RX=0

                   FOR 

                       SET RX=$ORDER(^PS(55,DFN,"P","A",EXD,RX))

                       if 'RX

                           QUIT 

                       if $DATA(^PSRX(RX,0))

                           DO GET

               End DoDot:1

 +10       SET STA="ACT^NVR^REF^HLD^NVR^SUS^^^^^^EXP^DCD^DEL^DCD^DCD^HLD"

 +11       SET DRG=""

           FOR 

               SET DRG=$ORDER(PSOSD(DRG))

               if DRG=""

                   QUIT 

               if $GET(PSOSD(DRG))]""

                   Begin DoDot:1

 +12                   SET PSOSD($PIECE(STA,"^",$PIECE(PSOSD(DRG),"^",2)+1),DRG)=PSOSD(DRG)

                       KILL PSOSD(DRG)

                   End DoDot:1

 +13       DO PEN

           if $DATA(PSOSD)

               DO BLD

 +14       QUIT 

EN2(DFN,RXLIST) ;Entry point to return data for specified RX #s

 +1        if DFN<1

               QUIT 

 +2        if 'RXLIST

               QUIT 

 +3        NEW DRG,DRGN,EXD,I,IFN,MIG,LSTFD,ORD,PEN,PSOBD,PSOED,PSODD,PSOOI,PSOSD,RX,RX0,RX2,RX3,TFN,TD,TR,TRM,SC,SCH,ST0,STA,PSORX,J,PSOERR,RX,PSRXD,PSODIV,PSOSTA

 +4        IF '$GET(DT)

               SET DT=$$DT^XLFDT

 +5        KILL ^TMP("PSO",$JOB)

 +6        SET PSOSTA="ACT^NVR^REF^HLD^NVR^SUS^^^^^^EXP^DCD^DEL^DCD^DCD^HLD"

 +7        FOR J=1:1

               SET PSORX=$PIECE(RXLIST,"^",J)

               if PSORX=""

                   QUIT 

               Begin DoDot:1

 +8                IF '$DATA(^PSRX("B",PSORX))

                       QUIT 

 +9                IF $ORDER(^PSRX("B",PSORX,""))=""

                       QUIT 

 +10               SET RX=$ORDER(^PSRX("B",PSORX,""))

                   SET PSRXD=$GET(^PSRX(RX,0))

 +11               if PSRXD=""

                       QUIT 

 +12               if $PIECE(PSRXD,"^",2)'=DFN

                       QUIT 

 +13               if $PIECE($GET(^PSRX(RX,"STA")),"^")=13

                       QUIT 

 +14               if $PIECE($GET(^PSRX(RX,"STA")),"^")=15

                       QUIT 

 +15               if '$DATA(^PSDRUG($PIECE(PSRXD,"^",6),0))

                       QUIT 

 +16               SET IFN=RX

                   SET TR=$PIECE(PSOSTA,"^",$PIECE($GET(^PSRX(RX,"STA")),"^")+1)

 +17               SET TD=$PIECE(^PSDRUG($PIECE(PSRXD,"^",6),0),"^")

 +18               DO RXD

 +19               QUIT 

               End DoDot:1

 +20       QUIT 

 +21      ;

EN3(DFN,BDT,EDT) ;entry point to return prescription history

 +1        if '$GET(DFN)

               QUIT 

 +2        NEW DRG,DRGN,EXD,I,IFN,MIG,LSTFD,ORD,PEN,PSOBD,PSOED,PSODD,PSOOI,PSOSD,RX,RX0,RX2,RX3,TFN,TD,TR,TRM,SC,SCH,ST0,STA,PSODIV

 +3        IF '$GET(DT)

               SET DT=$$DT^XLFDT

 +4        KILL ^TMP("PSO",$JOB)

           SET PSOBD=$GET(BDT)

           SET PSOED=$GET(EDT)

 +5        IF +$GET(PSOBD)<1

               SET X1=DT

               SET X2=-120

               DO C^%DTC

               SET PSOBD=X

 +6        SET EXD=PSOBD-1

 +7        IF PSOED=""

               SET PSOED=9999999

 +8        FOR 

               SET EXD=$ORDER(^PS(55,DFN,"P","A",EXD))

               if 'EXD

                   QUIT 

               if EXD>PSOED

                   QUIT 

               Begin DoDot:1

 +9                SET RX=0

                   FOR 

                       SET RX=$ORDER(^PS(55,DFN,"P","A",EXD,RX))

                       if 'RX

                           QUIT 

                       if $DATA(^PSRX(RX,0))

                           DO GET1

               End DoDot:1

 +10       SET STA="ACT^NVR^REF^HLD^NVR^SUS^^^^^^EXP^DCD^DEL^DCD^DCD^HLD"

 +11      ; Uses RX (Rx IEN) instead of DRUG as a subscript in PSOSD and thus

 +12      ; in ^TMP("PSO",$J).  Other entry points use DRUG

 +13       SET RX=""

           FOR 

               SET RX=$ORDER(PSOSD(RX))

               if RX=""

                   QUIT 

               if $GET(PSOSD(RX))]""

                   Begin DoDot:1

 +14                   SET PSOSD($PIECE(STA,"^",$PIECE(PSOSD(RX),"^",2)+1),RX)=PSOSD(RX)

                       KILL PSOSD(RX)

                   End DoDot:1

 +15       if $DATA(PSOSD)

               DO BLD

 +16       QUIT 

 +17      ;

PEN        FOR PEN=0:0

               SET PEN=$ORDER(^PS(52.41,"P",DFN,PEN))

               if 'PEN

                   QUIT 

               Begin DoDot:1

 +1                SET ORD=^PS(52.41,PEN,0)

                   if $PIECE(ORD,"^",2)'=DFN

                       QUIT 

                   SET DRG=""

 +2                if $PIECE(ORD,"^",3)="DC"!($PIECE(ORD,"^",3)="DE")!($PIECE(ORD,"^",3)="")!($PIECE(ORD,"^",3)="RF")

                       QUIT 

 +3                SET PSOOI=$PIECE(ORD,"^",8)

                   SET PSODD=+$PIECE(ORD,"^",9)

 +4                SET DRG=$SELECT(PSODD:$PIECE($GET(^PSDRUG(PSODD,0)),"^"),+PSOOI&('PSODD):$PIECE(^PS(50.7,+PSOOI,0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^PS(50.7,+PSOOI,0),"^",2),0),"^"),1:"")

 +5                if DRG']""

                       QUIT 

 +6                IF $DATA(PSOSD("PEN",DRG))

                       SET DRG=DRG_"^"_PEN

 +7                SET PSOSD("PEN",DRG)=PEN

               End DoDot:1

 +8        QUIT 

GET       ;

 +1        if $PIECE($GET(^PSRX(RX,"STA")),"^")=13

               QUIT 

 +2        if $PIECE($GET(^PSRX(RX,"STA")),"^")=15

               QUIT 

 +3        if '$PIECE(^PSRX(RX,0),"^",2)

               QUIT 

 +4        if $PIECE(^PSRX(RX,0),"^",2)'=DFN

               QUIT 

 +5        SET RX0=^PSRX(RX,0)

           SET RX2=^PSRX(RX,2)

 +6        SET DRG=$PIECE(^PSRX(RX,0),"^",6)

           SET STA=+^("STA")

           if '$DATA(^PSDRUG(DRG,0))

               QUIT 

 +7        SET DRGN=$PIECE(^PSDRUG(DRG,0),"^")

           SET ST0=$SELECT(STA<12&($PIECE(RX2,"^",6)<DT):11,1:STA)

 +8        IF $DATA(PSOSD(DRGN))

               IF ST0>10

                   if $PIECE(PSOSD(DRGN),"^",2)<11

                       QUIT 

                   if $PIECE(PSOSD(DRGN),"^",2)>10&($PIECE(RX0,"^",13)<$PIECE(^PSRX(+$PIECE(PSOSD(DRGN),"^"),0),"^",13))

                       QUIT 

 +9        IF $DATA(PSOSD(DRGN))

               IF $PIECE(PSOSD(DRGN),"^",2)<10

                   IF ST0<10

                       SET PSOSD(DRGN_"^"_RX)=RX_"^"_ST0

 +10      IF '$TEST

               SET PSOSD(DRGN)=RX_"^"_ST0

 +11       QUIT 

GET1      ;

 +1        if '$PIECE(^PSRX(RX,0),"^",2)

               QUIT 

 +2        if $PIECE(^PSRX(RX,0),"^",2)'=DFN

               QUIT 

 +3        SET RX0=^PSRX(RX,0)

           SET RX2=^PSRX(RX,2)

 +4        SET DRG=$PIECE(^PSRX(RX,0),"^",6)

           SET STA=+^("STA")

           if '$DATA(^PSDRUG(DRG,0))

               QUIT 

 +5        SET DRGN=$PIECE(^PSDRUG(DRG,0),"^")

           SET ST0=$SELECT(STA<12&($PIECE(RX2,"^",6)<DT):11,1:STA)

 +6        SET PSOSD(RX)=RX_"^"_ST0

 +7        QUIT 

BLD       ;

 +1        SET TR=""

           FOR 

               SET TR=$ORDER(PSOSD(TR))

               if TR=""

                   QUIT 

               Begin DoDot:1

 +2                SET TFN=0

                   SET TD=""

                   FOR 

                       SET TD=$ORDER(PSOSD(TR,TD))

                       if TD=""

                           QUIT 

                       SET IFN=+PSOSD(TR,TD)

                       DO @$SELECT(TR="PEN":"PND",1:"RXD")

               End DoDot:1

 +3        QUIT 

RXD       ;

 +1        if '$DATA(^PSRX(IFN,0))

               QUIT 

 +2        SET RX0=^PSRX(IFN,0)

           SET RX2=$GET(^(2))

           SET RX3=$GET(^(3))

           SET STA=+$GET(^("STA"))

           SET TRM=0

           SET LSTFD=$PIECE(RX2,"^",2)

 +3        SET ^TMP("PSO",$JOB,TR,TD,"RXN",0)=$PIECE(RX0,"^")_"^"_$EXTRACT($PIECE(RX2,"^",13),1,7)_"^"_$SELECT($PIECE(RX0,"^",11)="W":"W",1:"M")_"^"_$PIECE(RX3,"^",7)

 +4        SET ^TMP("PSO",$JOB,TR,TD,"RXN",0)=^TMP("PSO",$JOB,TR,TD,"RXN",0)_"^"_$SELECT($PIECE($GET(^PSRX(IFN,"OR1")),"^",5):$PIECE(^PSRX(IFN,"OR1"),"^",5),1:"")_"^"_$EXTRACT($PIECE(RX2,"^",2),1,7)_"^"_$EXTRACT($PIECE(RX2,"^",13),1,7)_"^^"_IFN

 +5        SET I=0

           FOR 

               SET I=$ORDER(^PSRX(IFN,1,I))

               if 'I

                   QUIT 

               SET TRM=TRM+1

               SET LSTFD=$PIECE(^PSRX(IFN,1,I,0),"^")

               Begin DoDot:1

 +6                SET ^TMP("PSO",$JOB,TR,TD,"REF",I,0)=$PIECE(^PSRX(IFN,1,I,0),"^")_"^"_$PIECE(^(0),"^",10)_"^"_$PIECE(^(0),"^",4)_"^"_$EXTRACT($PIECE(^(0),"^",18),1,7)_"^"_$SELECT($PIECE(^(0),"^",2)="W":"W",1:"M")_"^"_$PIECE(^(0),"^",3)