PSOHLDS6 ;BIR/MV,RBD - Update Host site for a OneVA fill ;18 Feb 2025 8:56 AM
;;7.0;OUTPATIENT PHARMACY;**643,736,774**;DEC 1997;Build 15
;
; Reference to DUZ^XUP supported by DBIA #4129
;
HOST ;Update dispensing information at the host site for a OneVa OPAI fill, p736 - handle possible HLNODE overflow nodes
N PSOHAIL,PSOHSUB,PSOHORC,PSOHRXD,PSOMSG,J,PSOHIEN,PSOHIENR,PSOHFILL,PSOHCHEK,PSOS5209,PSOHTPE,PSOHFLOT,PSOHSEXP,PSOHSMAN,PSOHSNDC,PSOHNTE,PSOHSUBR
N ORC K PSOMSG F PSOHAIL=1:1 X HLNEXT Q:HLQUIT'>0 S PSOMSG(PSOHAIL)=HLNODE,J=0 S:$D(HLNODE(PSOHAIL)) HLNODE=HLNODE_HLNODE(PSOHAIL) D
.I $P(PSOMSG(PSOHAIL),"|")="MSA"!($P(PSOMSG(PSOHAIL),"|")="RXR") Q
.I $P(PSOMSG(PSOHAIL),"|")="ORC" S PSOHORC=PSOMSG(PSOHAIL) Q
.I $P(PSOMSG(PSOHAIL),"|")="RXD" S PSOHRXD=PSOMSG(PSOHAIL) Q
.I $P(PSOMSG(PSOHAIL),"|")="NTE" S PSOHNTE=PSOMSG(PSOHAIL)
S PSOHIEN=$P($P($G(PSOHORC),"|",3),"~") I PSOHIEN'="" S PSOHIENR=$O(^PSRX("B",PSOHIEN,0)) Q:'PSOHIENR
S PSOHFILL=$P($G(PSOHORC),"|",11),PSOHCHEK=$P($G(PSOHORC),"|",12),PSOHTPE=$P($G(PSOHORC),"|",2)
S PSOHSUB=$P($G(PSOHRXD),"|",2),PSOS5209=$P($G(PSOHRXD),"|",14),PSOHFLOT=$P($G(PSOHRXD),"|",19)
S PSOHSEXP=$P($G(PSOHRXD),"|",20),PSOHSMAN=$P($G(PSOHRXD),"|",21)
S PSOHSNDC=$P($G(PSOHRXD),"|",10)
S PSOHSEXP=$$FMDATE^HLFNC(PSOHSEXP)
I PSOS5209 D
.S $P(^PSRXR(52.09,PSOS5209,0),"^",11)=$G(PSOHFILL)
.S $P(^PSRXR(52.09,PSOS5209,0),"^",12)=$G(PSOHCHEK)
.I $G(PSOHNTE)'="" D
..S $P(^PSRXR(52.09,PSOS5209,4),"^")=$P(PSOHNTE,"|",4)
..I $P(PSOHNTE,"|",4)'="" S ^PSRXR(52.09,"F",$P(PSOHNTE,"|",4),PSOS5209)=""
..S $P(^PSRXR(52.09,PSOS5209,4),"^",3)=$P(PSOHNTE,"|",5)
..S $P(^PSRXR(52.09,PSOS5209,4),"^",4)=$P(PSOHNTE,"|",6)
..S $P(^PSRXR(52.09,PSOS5209,4),"^",5)=$P(PSOHNTE,"|",7)
; RBD *774 Removed "Q:'PSOHSUB" so that Original Fill logic can pass through
;
S:PSOHTPE="RF" $P(^PSRXR(52.09,PSOS5209,0),"^",13)=PSOHSUB
S:PSOHTPE="PR" $P(^PSRXR(52.09,PSOS5209,0),"^",14)=PSOHSUB
;
I PSOHIENR D ; RBD *774 Removed PSOHSUB from IF check so Original Fill logic can be done
.S:$G(PSOHSUB)]"" PSOHSUBR=$S(PSOHTPE="PR":6,1:$S(PSOHSUB>5:PSOHSUB+1,1:PSOHSUB)) ; RBD *774 If PSOHSUB valued follow usual non-Original Fill path
.S:$G(PSOHSUB)']"" PSOHSUBR=0 D ACT^PSORREF($S(PSOHTPE="RF":"R",1:"P"),PSOHIENR,PSOHSUBR) ; RBD *774 Set PSOHSUBR to 0 when PSOHSUB blank (Original Fill path)
.I $P(^PSRXR(52.09,PSOS5209,4),"^",5) D ACTD^PSORREF("X","HL7 ID "_$P(PSOHNTE,"|",4)_" MESSAGE TRANSMITTED TO "_$P(PSOHNTE,"|",5)_" ("_$P(PSOHNTE,"|",6)_")")
.D ACTD^PSORREF("N","External Interface Dispensing is Complete.")
D UPDH^PSORREF
Q
;
UPDHREL ; RBD *774 - UPDHREL New for Auto-Release of Original Fills, Refills and Partial Fills
; Logic emulates Auto Release logic from PSOHLDIS, but is crafted for OneVA
N DIV,DRG,DUZ,PSOCPRX,PSOERR,PSOPAR,PSOSITE,PSRX0,QTY,RELDT,RPHARM,RXP
S RPHARM=$$FIND1^DIC(200,,"M","PSOAUTORELEASE,PROXY USER") I 'RPHARM S RPHARM=.5
D DUZ^XUP(RPHARM) ; DUZ is needed downstream and takes on the value of RPHARM by this call
S PSRX0=$G(^PSRX(IRX,0)),DRG=$P(PSRX0,"^",6),QTY=$P(PSRX0,"^",7),RELDT=$$NOW^XLFDT
I FLL="F",'FLLN D ;Original Fill
.S DIV=$P($G(^PSRX(IRX,2)),"^",9) I DIV]"",$P($G(^PS(59,DIV,"DISP")),"^",2) D
..S PSOPAR=$G(^PS(59,DIV,1)),PSOSITE=DIV
..N IRXS K FDA S IRXS=IRX_",",FDA(52,IRXS,31)=RELDT,FDA(52,IRXS,23)=RPHARM
..S FDA(52,IRXS,32.1)="@",FDA(52,IRXS,32.2)="@" D FILE^DIE(,"FDA","PSOERR") K FDA
..S PSOCPRX=$P(^PSRX(IRX,0),"^"),RXP=IRX D CP^PSOCP S:$G(DIV)']"" DIV=$G(PSOSITE)
..D EN^PSOHLSN1(IRX,"ZD"),AUTOREL^PSOBPSUT(IRX,FLLN,RELDT,PSOHSNDC,"A",,30)
.;else if not auto release
.E I $$NDCFMT^PSSNDCUT(PSOHSNDC)'="",$$STATUS^PSOBPSUT(IRX,FLLN)="" D SAVNDC^PSONDCUT(IRX,FLLN,PSOHSNDC)
I FLL="F",FLLN D ;Refill
.S DIV=$P(^PSRX(IRX,1,FLLN,0),"^",9) I DIV]"",$P($G(^PS(59,DIV,"DISP")),"^",2) D
..S PSOPAR=$G(^PS(59,DIV,1)),PSOSITE=DIV
..N REFIENS K FDA S REFIENS=FLLN_","_IRX_"," S FDA(52.1,REFIENS,17)=RELDT,FDA(52.1,REFIENS,4)=RPHARM
..D FILE^DIE(,"FDA") K FDA
..N YY S YY=FLLN,PSOCPRX=$P(^PSRX(IRX,0),"^"),RXP=IRX D CP^PSOCP S:$G(DIV)']"" DIV=$G(PSOSITE)
..D EN^PSOHLSN1(IRX,"ZD"),AUTOREL^PSOBPSUT(IRX,FLLN,RELDT,PSOHSNDC,"A",,30)
.;else if not auto release
.E I $$NDCFMT^PSSNDCUT(PSOHSNDC)'="",$$STATUS^PSOBPSUT(IRX,FLLN)="" D SAVNDC^PSONDCUT(IRX,FLLN,PSOHSNDC)
I FLL="P" D ;Partial Fill
.S DIV=$P(^PSRX(IRX,"P",FLLN,0),"^",9) I DIV]"",$P($G(^PS(59,DIV,"DISP")),"^",2) D
..S PSOPAR=$G(^PS(59,DIV,1)),PSOSITE=DIV
..N PARIENS K FDA S PARIENS=FLLN_","_IRX_"," S FDA(52.2,PARIENS,8)=RELDT,FDA(52.2,PARIENS,.05)=RPHARM
..D FILE^DIE(,"FDA") K FDA
S $P(^PSRXR(52.09,PSOS5209,0),"^",16)=RELDT
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLDS6 4708 printed Jan 29, 2026@15:28:47 Page 2
PSOHLDS6 ;BIR/MV,RBD - Update Host site for a OneVA fill ;18 Feb 2025 8:56 AM
+1 ;;7.0;OUTPATIENT PHARMACY;**643,736,774**;DEC 1997;Build 15
+2 ;
+3 ; Reference to DUZ^XUP supported by DBIA #4129
+4 ;
HOST ;Update dispensing information at the host site for a OneVa OPAI fill, p736 - handle possible HLNODE overflow nodes
+1 NEW PSOHAIL,PSOHSUB,PSOHORC,PSOHRXD,PSOMSG,J,PSOHIEN,PSOHIENR,PSOHFILL,PSOHCHEK,PSOS5209,PSOHTPE,PSOHFLOT,PSOHSEXP,PSOHSMAN,PSOHSNDC,PSOHNTE,PSOHSUBR
+2 NEW ORC
KILL PSOMSG
FOR PSOHAIL=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
SET PSOMSG(PSOHAIL)=HLNODE
SET J=0
if $DATA(HLNODE(PSOHAIL))
SET HLNODE=HLNODE_HLNODE(PSOHAIL)
Begin DoDot:1
+3 IF $PIECE(PSOMSG(PSOHAIL),"|")="MSA"!($PIECE(PSOMSG(PSOHAIL),"|")="RXR")
QUIT
+4 IF $PIECE(PSOMSG(PSOHAIL),"|")="ORC"
SET PSOHORC=PSOMSG(PSOHAIL)
QUIT
+5 IF $PIECE(PSOMSG(PSOHAIL),"|")="RXD"
SET PSOHRXD=PSOMSG(PSOHAIL)
QUIT
+6 IF $PIECE(PSOMSG(PSOHAIL),"|")="NTE"
SET PSOHNTE=PSOMSG(PSOHAIL)
End DoDot:1
+7 SET PSOHIEN=$PIECE($PIECE($GET(PSOHORC),"|",3),"~")
IF PSOHIEN'=""
SET PSOHIENR=$ORDER(^PSRX("B",PSOHIEN,0))
if 'PSOHIENR
QUIT
+8 SET PSOHFILL=$PIECE($GET(PSOHORC),"|",11)
SET PSOHCHEK=$PIECE($GET(PSOHORC),"|",12)
SET PSOHTPE=$PIECE($GET(PSOHORC),"|",2)
+9 SET PSOHSUB=$PIECE($GET(PSOHRXD),"|",2)
SET PSOS5209=$PIECE($GET(PSOHRXD),"|",14)
SET PSOHFLOT=$PIECE($GET(PSOHRXD),"|",19)
+10 SET PSOHSEXP=$PIECE($GET(PSOHRXD),"|",20)
SET PSOHSMAN=$PIECE($GET(PSOHRXD),"|",21)
+11 SET PSOHSNDC=$PIECE($GET(PSOHRXD),"|",10)
+12 SET PSOHSEXP=$$FMDATE^HLFNC(PSOHSEXP)
+13 IF PSOS5209
Begin DoDot:1
+14 SET $PIECE(^PSRXR(52.09,PSOS5209,0),"^",11)=$GET(PSOHFILL)
+15 SET $PIECE(^PSRXR(52.09,PSOS5209,0),"^",12)=$GET(PSOHCHEK)
+16 IF $GET(PSOHNTE)'=""
Begin DoDot:2
+17 SET $PIECE(^PSRXR(52.09,PSOS5209,4),"^")=$PIECE(PSOHNTE,"|",4)
+18 IF $PIECE(PSOHNTE,"|",4)'=""
SET ^PSRXR(52.09,"F",$PIECE(PSOHNTE,"|",4),PSOS5209)=""
+19 SET $PIECE(^PSRXR(52.09,PSOS5209,4),"^",3)=$PIECE(PSOHNTE,"|",5)
+20 SET $PIECE(^PSRXR(52.09,PSOS5209,4),"^",4)=$PIECE(PSOHNTE,"|",6)
+21 SET $PIECE(^PSRXR(52.09,PSOS5209,4),"^",5)=$PIECE(PSOHNTE,"|",7)
End DoDot:2
End DoDot:1
+22 ; RBD *774 Removed "Q:'PSOHSUB" so that Original Fill logic can pass through
+23 ;
+24 if PSOHTPE="RF"
SET $PIECE(^PSRXR(52.09,PSOS5209,0),"^",13)=PSOHSUB
+25 if PSOHTPE="PR"
SET $PIECE(^PSRXR(52.09,PSOS5209,0),"^",14)=PSOHSUB
+26 ;
+27 ; RBD *774 Removed PSOHSUB from IF check so Original Fill logic can be done
IF PSOHIENR
Begin DoDot:1
+28 ; RBD *774 If PSOHSUB valued follow usual non-Original Fill path
if $GET(PSOHSUB)]""
SET PSOHSUBR=$SELECT(PSOHTPE="PR":6,1:$SELECT(PSOHSUB>5:PSOHSUB+1,1:PSOHSUB))
+29 ; RBD *774 Set PSOHSUBR to 0 when PSOHSUB blank (Original Fill path)
if $GET(PSOHSUB)']""
SET PSOHSUBR=0
DO ACT^PSORREF($SELECT(PSOHTPE="RF":"R",1:"P"),PSOHIENR,PSOHSUBR)
+30 IF $PIECE(^PSRXR(52.09,PSOS5209,4),"^",5)
DO ACTD^PSORREF("X","HL7 ID "_$PIECE(PSOHNTE,"|",4)_" MESSAGE TRANSMITTED TO "_$PIECE(PSOHNTE,"|",5)_" ("_$PIECE(PSOHNTE,"|",6)_")")
+31 DO ACTD^PSORREF("N","External Interface Dispensing is Complete.")
End DoDot:1
+32 DO UPDH^PSORREF
+33 QUIT
+34 ;
UPDHREL ; RBD *774 - UPDHREL New for Auto-Release of Original Fills, Refills and Partial Fills
+1 ; Logic emulates Auto Release logic from PSOHLDIS, but is crafted for OneVA
+2 NEW DIV,DRG,DUZ,PSOCPRX,PSOERR,PSOPAR,PSOSITE,PSRX0,QTY,RELDT,RPHARM,RXP
+3 SET RPHARM=$$FIND1^DIC(200,,"M","PSOAUTORELEASE,PROXY USER")
IF 'RPHARM
SET RPHARM=.5
+4 ; DUZ is needed downstream and takes on the value of RPHARM by this call
DO DUZ^XUP(RPHARM)
+5 SET PSRX0=$GET(^PSRX(IRX,0))
SET DRG=$PIECE(PSRX0,"^",6)
SET QTY=$PIECE(PSRX0,"^",7)
SET RELDT=$$NOW^XLFDT
+6 ;Original Fill
IF FLL="F"
IF 'FLLN
Begin DoDot:1
+7 SET DIV=$PIECE($GET(^PSRX(IRX,2)),"^",9)
IF DIV]""
IF $PIECE($GET(^PS(59,DIV,"DISP")),"^",2)
Begin DoDot:2
+8 SET PSOPAR=$GET(^PS(59,DIV,1))
SET PSOSITE=DIV
+9 NEW IRXS
KILL FDA
SET IRXS=IRX_","
SET FDA(52,IRXS,31)=RELDT
SET FDA(52,IRXS,23)=RPHARM
+10 SET FDA(52,IRXS,32.1)="@"
SET FDA(52,IRXS,32.2)="@"
DO FILE^DIE(,"FDA","PSOERR")
KILL FDA
+11 SET PSOCPRX=$PIECE(^PSRX(IRX,0),"^")
SET RXP=IRX
DO CP^PSOCP
if $GET(DIV)']""
SET DIV=$GET(PSOSITE)
+12 DO EN^PSOHLSN1(IRX,"ZD")
DO AUTOREL^PSOBPSUT(IRX,FLLN,RELDT,PSOHSNDC,"A",,30)
End DoDot:2
+13 ;else if not auto release
+14 IF '$TEST
IF $$NDCFMT^PSSNDCUT(PSOHSNDC)'=""
IF $$STATUS^PSOBPSUT(IRX,FLLN)=""
DO SAVNDC^PSONDCUT(IRX,FLLN,PSOHSNDC)
End DoDot:1
+15 ;Refill
IF FLL="F"
IF FLLN
Begin DoDot:1
+16 SET DIV=$PIECE(^PSRX(IRX,1,FLLN,0),"^",9)
IF DIV]""
IF $PIECE($GET(^PS(59,DIV,"DISP")),"^",2)
Begin DoDot:2
+17 SET PSOPAR=$GET(^PS(59,DIV,1))
SET PSOSITE=DIV
+18 NEW REFIENS
KILL FDA
SET REFIENS=FLLN_","_IRX_","
SET FDA(52.1,REFIENS,17)=RELDT
SET FDA(52.1,REFIENS,4)=RPHARM
+19 DO FILE^DIE(,"FDA")
KILL FDA
+20 NEW YY
SET YY=FLLN
SET PSOCPRX=$PIECE(^PSRX(IRX,0),"^")
SET RXP=IRX
DO CP^PSOCP
if $GET(DIV)']""
SET DIV=$GET(PSOSITE)
+21 DO EN^PSOHLSN1(IRX,"ZD")
DO AUTOREL^PSOBPSUT(IRX,FLLN,RELDT,PSOHSNDC,"A",,30)
End DoDot:2
+22 ;else if not auto release
+23 IF '$TEST
IF $$NDCFMT^PSSNDCUT(PSOHSNDC)'=""
IF $$STATUS^PSOBPSUT(IRX,FLLN)=""
DO SAVNDC^PSONDCUT(IRX,FLLN,PSOHSNDC)
End DoDot:1
+24 ;Partial Fill
IF FLL="P"
Begin DoDot:1
+25 SET DIV=$PIECE(^PSRX(IRX,"P",FLLN,0),"^",9)
IF DIV]""
IF $PIECE($GET(^PS(59,DIV,"DISP")),"^",2)
Begin DoDot:2
+26 SET PSOPAR=$GET(^PS(59,DIV,1))
SET PSOSITE=DIV
+27 NEW PARIENS
KILL FDA
SET PARIENS=FLLN_","_IRX_","
SET FDA(52.2,PARIENS,8)=RELDT
SET FDA(52.2,PARIENS,.05)=RPHARM
+28 DO FILE^DIE(,"FDA")
KILL FDA
End DoDot:2
End DoDot:1
+29 SET $PIECE(^PSRXR(52.09,PSOS5209,0),"^",16)=RELDT
+30 QUIT
+31 ;
