PSXREF ;BIR/BAB-Cross Reference Utility ;[ 04/08/97 2:06 PM ]
;;2.0;CMOP;;11 Apr 97
ACT ;Entry point to create xref for CMOP Dispense field edit
Q:$G(^PSDRUG(DA,3))=""
S:'$D(^PSDRUG(DA,4,0)) ^PSDRUG(DA,4,0)="^50.0214DA^^"
S (PSX,Z)=0 F S Z=$O(^PSDRUG(DA,4,Z)) Q:'Z S PSX=Z
S PSX=PSX+1 D NOW^%DTC S ^PSDRUG(DA,4,PSX,0)=%_"^E^"_DUZ_"^CMOP Dispense^"_$S($G(^PSDRUG(DA,3))=1:"YES",$G(^PSDRUG(DA,3))=0:"NO",1:"")
S $P(^PSDRUG(DA,4,0),"^",3)=PSX,$P(^(0),"^",4)=$P(^(0),"^",4)+1
K PSX,Z,% Q
DEL ; Called by ^DD(52.1,.01,"DEL",550,0)- PREVENTS DELETING REFILL DATE
I $G(PSX(DA))]"",($G(PSX(DA))="L"!(+$G(PSX(DA))'=3)) D
.W !!,"You cannot delete a refill date for a fill that is"_$S(+$G(PSX(DA))=1:" released by",+$G(PSX(DA))=0:" in transmission to",1:" being retransmitted to")_" the CMOP",!!
Q
AR ; Sets the "AR" xref if CMOP status in 52 =1
; ^PSRX("AR",RELEASE D/T,INTERNAL ENTRY # RX in 52,fill #
I X=1 D
.I $P(^PSRX(DA(1),4,DA,0),U,3)=0,($P($G(^PSRX(DA(1),2)),U,13)) S ^PSRX("AR",$P(^PSRX(DA(1),2),U,13),DA(1),$P(^PSRX(DA(1),4,DA,0),U,3))=""
.I $P(^PSRX(DA(1),4,DA,0),U,3)>0,($D(^PSRX(DA(1),1,$P(^PSRX(DA(1),4,DA,0),U,3),0))),($P($G(^PSRX(DA(1),1,$P(^PSRX(DA(1),4,DA,0),U,3),0)),U,18)]"") D
..S ^PSRX("AR",$P(^PSRX(DA(1),1,$P(^PSRX(DA(1),4,DA,0),U,3),0),U,18),DA(1),$P(^PSRX(DA(1),4,DA,0),U,3))=""
Q
AS ; Transmission D/T xref
; ^PSRX("AS",TRANS D/T,INTERNAL ENTRY # RX in 52, fill #
S ^PSRX("AS",$P(^PSX(550.2,$P(^PSRX(DA(1),4,DA,0),U),0),U,6),DA(1),$P(^PSRX(DA(1),4,DA,0),U,3))=""
Q
ASKILL ;
;K ^PSRX("AS",$P(^PSX(550.2,$P(^PSRX(DA(1),4,DA,0),U),0),U,6),DA(1),$P(^PSRX(DA(1),4,DA,0),U,3))
Q
DISPUNIT ;Called by ^DD(50,14.5,"DEL",0) to prevent deleting CMOP disp units.
I $D(^PSDRUG("AQ",DA)) W !,"The Dispense Unit of a CMOP drug cannot be deleted!",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXREF 1818 printed Dec 13, 2024@01:44:50 Page 2
PSXREF ;BIR/BAB-Cross Reference Utility ;[ 04/08/97 2:06 PM ]
+1 ;;2.0;CMOP;;11 Apr 97
ACT ;Entry point to create xref for CMOP Dispense field edit
+1 if $GET(^PSDRUG(DA,3))=""
QUIT
+2 if '$DATA(^PSDRUG(DA,4,0))
SET ^PSDRUG(DA,4,0)="^50.0214DA^^"
+3 SET (PSX,Z)=0
FOR
SET Z=$ORDER(^PSDRUG(DA,4,Z))
if 'Z
QUIT
SET PSX=Z
+4 SET PSX=PSX+1
DO NOW^%DTC
SET ^PSDRUG(DA,4,PSX,0)=%_"^E^"_DUZ_"^CMOP Dispense^"_$SELECT($GET(^PSDRUG(DA,3))=1:"YES",$GET(^PSDRUG(DA,3))=0:"NO",1:"")
+5 SET $PIECE(^PSDRUG(DA,4,0),"^",3)=PSX
SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)+1
+6 KILL PSX,Z,%
QUIT
DEL ; Called by ^DD(52.1,.01,"DEL",550,0)- PREVENTS DELETING REFILL DATE
+1 IF $GET(PSX(DA))]""
IF ($GET(PSX(DA))="L"!(+$GET(PSX(DA))'=3))
Begin DoDot:1
+2 WRITE !!,"You cannot delete a refill date for a fill that is"_$SELECT(+$GET(PSX(DA))=1:" released by",+$GET(PSX(DA))=0:" in transmission to",1:" being retransmitted to")_" the CMOP",!!
End DoDot:1
+3 QUIT
AR ; Sets the "AR" xref if CMOP status in 52 =1
+1 ; ^PSRX("AR",RELEASE D/T,INTERNAL ENTRY # RX in 52,fill #
+2 IF X=1
Begin DoDot:1
+3 IF $PIECE(^PSRX(DA(1),4,DA,0),U,3)=0
IF ($PIECE($GET(^PSRX(DA(1),2)),U,13))
SET ^PSRX("AR",$PIECE(^PSRX(DA(1),2),U,13),DA(1),$PIECE(^PSRX(DA(1),4,DA,0),U,3))=""
+4 IF $PIECE(^PSRX(DA(1),4,DA,0),U,3)>0
IF ($DATA(^PSRX(DA(1),1,$PIECE(^PSRX(DA(1),4,DA,0),U,3),0)))
IF ($PIECE($GET(^PSRX(DA(1),1,$PIECE(^PSRX(DA(1),4,DA,0),U,3),0)),U,18)]"")
Begin DoDot:2
+5 SET ^PSRX("AR",$PIECE(^PSRX(DA(1),1,$PIECE(^PSRX(DA(1),4,DA,0),U,3),0),U,18),DA(1),$PIECE(^PSRX(DA(1),4,DA,0),U,3))=""
End DoDot:2
End DoDot:1
+6 QUIT
AS ; Transmission D/T xref
+1 ; ^PSRX("AS",TRANS D/T,INTERNAL ENTRY # RX in 52, fill #
+2 SET ^PSRX("AS",$PIECE(^PSX(550.2,$PIECE(^PSRX(DA(1),4,DA,0),U),0),U,6),DA(1),$PIECE(^PSRX(DA(1),4,DA,0),U,3))=""
+3 QUIT
ASKILL ;
+1 ;K ^PSRX("AS",$P(^PSX(550.2,$P(^PSRX(DA(1),4,DA,0),U),0),U,6),DA(1),$P(^PSRX(DA(1),4,DA,0),U,3))
+2 QUIT
DISPUNIT ;Called by ^DD(50,14.5,"DEL",0) to prevent deleting CMOP disp units.
+1 IF $DATA(^PSDRUG("AQ",DA))
WRITE !,"The Dispense Unit of a CMOP drug cannot be deleted!",!
+2 QUIT
