- PSXEDIT ;BIR/HTW-CMOP Edit Routine for Outpatient Pharmacy ; [ 03/30/98 12:03 PM ]
- ;;2.0;CMOP;**4,14**;11 Apr 97
- EDITCK ; Called from PROCESS+9^PSORXED to prevent editing CMOP Rx's
- N PPL
- S ZRX=PSORXED("IRXN"),PSXFILL=0,PSXTN=$G(^PSRX(ZRX,"TN"))
- S PSXFROM="EDIT"
- ; IF CMOP drug PSXYES=1
- DRUG I $D(^PSDRUG("AQ",$P(^PSRX(ZRX,0),"^",6))) S (PSXOUT,PSXYES)=1
- G:'$G(PSXYES) PSXDIEX
- GETCMOP ; Any CMOP nodes?
- F PSX=0:0 S PSX=$O(^PSRX(ZRX,4,PSX)) Q:(+PSX<1) D
- .S PSXSTAT=$P($G(^PSRX(ZRX,4,PSX,0)),"^",4)
- .S:$G(PSXSTAT)]"" PSXFLAGG=1
- .S ZFILL=$P($G(^PSRX(ZRX,4,PSX,0)),"^",3)
- .S PSX(ZFILL)=PSXSTAT
- I $G(PSXSTAT)=0!($G(PSXSTAT)=2) S PSXFLAG=1
- Q:$G(PSXHLD)
- ;Check if in suspense...
- I $D(^PS(52.5,"B",ZRX)) S PSXST=$O(^(ZRX,"")) D
- .S PSXSUSDT=$P(^PS(52.5,PSXST,0),"^",2),PSXST1=$P($G(^(0)),"^",7)
- .I $G(PSXST1)="L" S PSXFLAG=1
- .F ZZ=0:0 S ZZ=$O(^PSRX(ZRX,1,ZZ)) Q:(ZZ'>0) I $P(^(ZZ,0),"^")=PSXSUSDT S PSXFILL=ZZ,PSX(ZZ)=$G(PSX(ZZ))_PSXST1
- .I '$O(^PSRX(ZRX,1,0)) S PSX(0)=$G(PSX(0))_$G(PSXST1)
- .S PSXM=$S(PSXFILL=0:$P(^PSRX(ZRX,0),"^",11),1:$P(^PSRX(ZRX,1,PSXFILL,0),"^",2))
- PSXDIE ;
- I $G(PSXFLAG) D S PSORXED("DFLG")=1 G PSXDIEX
- .W !!,"This prescription cannot be edited during CMOP processing."
- W !,"Now Editing Rx # ",$P(PSORXED("RX0"),"^")
- K DIE,DIC,DR,MSG
- S DIE="^PSRX(",DA=ZRX
- S PSX50=$P(^PSRX(PSORXED("IRXN"),0),"^",6)
- S MSG=$P($G(^PSDRUG(PSX50,5)),"^")
- I $G(MSG)'="" S MSG=$TR(MSG,";",","),MSG=$TR(MSG,":",","),MSG=$TR(MSG,"^",",")
- ; PSXIDT=ISSUE DT, PSXFDT=FILL DT
- S PSXIDT=$P(^PSRX(ZRX,0),"^",13),Y=PSXIDT X ^DD("DD") S PSXIDT=Y
- S PSXFDT=$P(^PSRX(ZRX,2),"^",2),Y=PSXFDT X ^DD("DD") S PSXFDT=Y
- I $G(PSX(0))[1 W !,"ISSUE DATE: ",PSXIDT," (No editing)",!,"FILL DATE: ",PSXFDT," (No editing)"
- I $G(PSXFLAGG)!('$P(PSOPAR,"^",3)) W !,"DRUG: ",$P(^PSDRUG($P(^PSRX(PSORXED("IRXN"),0),"^",6),0),"^")," (No editing)"
- S DR=$S(+$G(PSX(0))'[1:"1;22R;",1:"")_"3;4;5"
- S DR=DR_$S($G(PSXFLAGG):"",'$P(PSOPAR,"^",3):"",1:";6")_";6.5;7QTY ( "_MSG_" )"
- S DR=DR_";8;17;9:11;"_$S($P(PSOPAR,"^",12):"35;",1:"")_"12;20;23;24"
- ;D ^DIE G:$D(Y)!($D(DTOUT)) UNLOCK
- REFILL I $G(RFD)>0 S DR=DR_";52"
- I S DR(2,52.1)="D CHECK^PSXEDIT;.01;@1;1"_"QTY ("_MSG_" )"_";1.1:5;8;15"
- D ^DIE K DIE,DR,X
- G:$D(Y)!($G(PSXEXIT)) UNLOCK I $D(DTOUT) S PSORXED("QFLG")=1 G PSXDIEX
- UNLOCK K DRG,PSXRFL D EN1^PSONEW2(.PSORXED)
- I PSORXED("DFLG") S PSORXED("QFLG")=1 G PSXDIEX
- G:'PSORXED("QFLG") PSXDIE
- S PSORXED("QFLG")=0
- TRADE ; Did tradename change?
- I $G(PSXTN)'=$P($G(^PSRX(ZRX,"TN")),"^") S PSXTN1=1 D ACT D
- .S $P(^PSRX(ZRX,"A",0),"^",3)=A,$P(^PSRX(ZRX,"A",0),"^",4)=A1
- .S ^PSRX(ZRX,"A",PSXB,0)=DT_"^E^"_DUZ_"^0^ Trade Name "_$G(PSXTN)
- .Q
- S:'$D(^PSDRUG("AQ",$P(^PSRX(ZRX,0),"^",6))) PSXYES=0
- I PSXFILL>0,('$D(^PSRX(ZRX,1,PSXFILL,0))) G PSXDIEX
- S PSXM1=$S(PSXFILL=0:$P(^PSRX(ZRX,0),"^",11),1:$P(^PSRX(ZRX,1,PSXFILL,0),"^",2))
- I '$G(PSXTN1),($G(PSXM)=$G(PSXM1)),($G(PSXYES))!('$G(PSXST)) G PSXDIEX
- S PSXFROM="EDIT"
- S PSXPPL=ZRX D TEST^PSXNEW
- SUS ; If Rx is suspended and checks out to be CMOP suspend as CMOP
- N DA
- Q:'$G(PSXSYS)
- I '$G(PPL),($G(PSXST)) D ACT D G PSXDIEX
- .K ^PS(52.5,"AC",$P(^PSRX(ZRX,0),"^",2),$P(^PS(52.5,PSXST,0),"^",2),PSXST)
- .S DIE="^PS(52.5,",DR="3////Q",DA=PSXST D ^DIE K DIE
- .S T=$P(^PSRX(ZRX,3),"^")
- .S T1=$E(T,4,5)_"-"_$E(T,6,7)_"-"_$E(T,2,3)
- .S $P(^PSRX(ZRX,"A",0),"^",3)=A,$P(^PSRX(ZRX,"A",0),"^",4)=A1
- .D NOW^%DTC
- .I $G(PSXFILL)>5 S PSXFILL=PSXFILL+1 ; Accomodating 1 yr patch
- .S ^PSRX(ZRX,"A",PSXB,0)=%_"^S^"_DUZ_"^"_$G(PSXFILL)_"^ Suspended for CMOP "_T1
- .K T,T1,%
- UNSUS ; If Rx is suspended and is not CMOP, ensure is not suspended as CMOP
- I $G(PSXST) D
- .S DIE="^PS(52.5,",DR="3////@",DA=PSXST D ^DIE K DIE
- .S ^PS(52.5,"AC",$P(^PSRX(ZRX,0),"^",2),$P(^PS(52.5,PSXST,0),"^",2),PSXST)=""
- PSXDIEX ;
- K PSX,PSXA,PSXB,PSXREL,PSXST,PSXST1,ZRX,PSXIDT,PSXFROM,PSXTN1,PSX50
- K PSXFDT,PSXRXF,PSXFILL,PSXFLAG,PSXM,PSXM1,PSXSTAT,PSXSUSDT,PSXTN,ZZ
- K PSXHLD,PSXREL1,PSXSTAT,ZZ1,A,A1,ACT,PSXYES,PSXFLAGG,DIE,DR,ZPPL,MSG
- Q
- ACT ; If no act node, make one .... determine last entry
- S:'$D(^PSRX(ZRX,"A",0)) ^(0)="^52.3DA^^"
- S PSXA="" F S PSXA=$O(^PSRX(ZRX,"A",PSXA)) Q:PSXA']"" S PSXB=PSXA+1
- S A=$P(^PSRX(ZRX,"A",0),"^",3),A1=$P(^PSRX(ZRX,"A",0),"^",4),A=A+1,A1=A1+1
- K PSXA
- Q
- CHECK ;
- I $G(PSX(D1))[1 S Y="@1"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXEDIT 4353 printed Feb 18, 2025@23:10:34 Page 2
- PSXEDIT ;BIR/HTW-CMOP Edit Routine for Outpatient Pharmacy ; [ 03/30/98 12:03 PM ]
- +1 ;;2.0;CMOP;**4,14**;11 Apr 97
- EDITCK ; Called from PROCESS+9^PSORXED to prevent editing CMOP Rx's
- +1 NEW PPL
- +2 SET ZRX=PSORXED("IRXN")
- SET PSXFILL=0
- SET PSXTN=$GET(^PSRX(ZRX,"TN"))
- +3 SET PSXFROM="EDIT"
- +4 ; IF CMOP drug PSXYES=1
- DRUG IF $DATA(^PSDRUG("AQ",$PIECE(^PSRX(ZRX,0),"^",6)))
- SET (PSXOUT,PSXYES)=1
- +1 if '$GET(PSXYES)
- GOTO PSXDIEX
- GETCMOP ; Any CMOP nodes?
- +1 FOR PSX=0:0
- SET PSX=$ORDER(^PSRX(ZRX,4,PSX))
- if (+PSX<1)
- QUIT
- Begin DoDot:1
- +2 SET PSXSTAT=$PIECE($GET(^PSRX(ZRX,4,PSX,0)),"^",4)
- +3 if $GET(PSXSTAT)]""
- SET PSXFLAGG=1
- +4 SET ZFILL=$PIECE($GET(^PSRX(ZRX,4,PSX,0)),"^",3)
- +5 SET PSX(ZFILL)=PSXSTAT
- End DoDot:1
- +6 IF $GET(PSXSTAT)=0!($GET(PSXSTAT)=2)
- SET PSXFLAG=1
- +7 if $GET(PSXHLD)
- QUIT
- +8 ;Check if in suspense...
- +9 IF $DATA(^PS(52.5,"B",ZRX))
- SET PSXST=$ORDER(^(ZRX,""))
- Begin DoDot:1
- +10 SET PSXSUSDT=$PIECE(^PS(52.5,PSXST,0),"^",2)
- SET PSXST1=$PIECE($GET(^(0)),"^",7)
- +11 IF $GET(PSXST1)="L"
- SET PSXFLAG=1
- +12 FOR ZZ=0:0
- SET ZZ=$ORDER(^PSRX(ZRX,1,ZZ))
- if (ZZ'>0)
- QUIT
- IF $PIECE(^(ZZ,0),"^")=PSXSUSDT
- SET PSXFILL=ZZ
- SET PSX(ZZ)=$GET(PSX(ZZ))_PSXST1
- +13 IF '$ORDER(^PSRX(ZRX,1,0))
- SET PSX(0)=$GET(PSX(0))_$GET(PSXST1)
- +14 SET PSXM=$SELECT(PSXFILL=0:$PIECE(^PSRX(ZRX,0),"^",11),1:$PIECE(^PSRX(ZRX,1,PSXFILL,0),"^",2))
- End DoDot:1
- PSXDIE ;
- +1 IF $GET(PSXFLAG)
- Begin DoDot:1
- +2 WRITE !!,"This prescription cannot be edited during CMOP processing."
- End DoDot:1
- SET PSORXED("DFLG")=1
- GOTO PSXDIEX
- +3 WRITE !,"Now Editing Rx # ",$PIECE(PSORXED("RX0"),"^")
- +4 KILL DIE,DIC,DR,MSG
- +5 SET DIE="^PSRX("
- SET DA=ZRX
- +6 SET PSX50=$PIECE(^PSRX(PSORXED("IRXN"),0),"^",6)
- +7 SET MSG=$PIECE($GET(^PSDRUG(PSX50,5)),"^")
- +8 IF $GET(MSG)'=""
- SET MSG=$TRANSLATE(MSG,";",",")
- SET MSG=$TRANSLATE(MSG,":",",")
- SET MSG=$TRANSLATE(MSG,"^",",")
- +9 ; PSXIDT=ISSUE DT, PSXFDT=FILL DT
- +10 SET PSXIDT=$PIECE(^PSRX(ZRX,0),"^",13)
- SET Y=PSXIDT
- XECUTE ^DD("DD")
- SET PSXIDT=Y
- +11 SET PSXFDT=$PIECE(^PSRX(ZRX,2),"^",2)
- SET Y=PSXFDT
- XECUTE ^DD("DD")
- SET PSXFDT=Y
- +12 IF $GET(PSX(0))[1
- WRITE !,"ISSUE DATE: ",PSXIDT," (No editing)",!,"FILL DATE: ",PSXFDT," (No editing)"
- +13 IF $GET(PSXFLAGG)!('$PIECE(PSOPAR,"^",3))
- WRITE !,"DRUG: ",$PIECE(^PSDRUG($PIECE(^PSRX(PSORXED("IRXN"),0),"^",6),0),"^")," (No editing)"
- +14 SET DR=$SELECT(+$GET(PSX(0))'[1:"1;22R;",1:"")_"3;4;5"
- +15 SET DR=DR_$SELECT($GET(PSXFLAGG):"",'$PIECE(PSOPAR,"^",3):"",1:";6")_";6.5;7QTY ( "_MSG_" )"
- +16 SET DR=DR_";8;17;9:11;"_$SELECT($PIECE(PSOPAR,"^",12):"35;",1:"")_"12;20;23;24"
- +17 ;D ^DIE G:$D(Y)!($D(DTOUT)) UNLOCK
- REFILL IF $GET(RFD)>0
- SET DR=DR_";52"
- +1 IF $TEST
- SET DR(2,52.1)="D CHECK^PSXEDIT;.01;@1;1"_"QTY ("_MSG_" )"_";1.1:5;8;15"
- +2 DO ^DIE
- KILL DIE,DR,X
- +3 if $DATA(Y)!($GET(PSXEXIT))
- GOTO UNLOCK
- IF $DATA(DTOUT)
- SET PSORXED("QFLG")=1
- GOTO PSXDIEX
- UNLOCK KILL DRG,PSXRFL
- DO EN1^PSONEW2(.PSORXED)
- +1 IF PSORXED("DFLG")
- SET PSORXED("QFLG")=1
- GOTO PSXDIEX
- +2 if 'PSORXED("QFLG")
- GOTO PSXDIE
- +3 SET PSORXED("QFLG")=0
- TRADE ; Did tradename change?
- +1 IF $GET(PSXTN)'=$PIECE($GET(^PSRX(ZRX,"TN")),"^")
- SET PSXTN1=1
- DO ACT
- Begin DoDot:1
- +2 SET $PIECE(^PSRX(ZRX,"A",0),"^",3)=A
- SET $PIECE(^PSRX(ZRX,"A",0),"^",4)=A1
- +3 SET ^PSRX(ZRX,"A",PSXB,0)=DT_"^E^"_DUZ_"^0^ Trade Name "_$GET(PSXTN)
- +4 QUIT
- End DoDot:1
- +5 if '$DATA(^PSDRUG("AQ",$PIECE(^PSRX(ZRX,0),"^",6)))
- SET PSXYES=0
- +6 IF PSXFILL>0
- IF ('$DATA(^PSRX(ZRX,1,PSXFILL,0)))
- GOTO PSXDIEX
- +7 SET PSXM1=$SELECT(PSXFILL=0:$PIECE(^PSRX(ZRX,0),"^",11),1:$PIECE(^PSRX(ZRX,1,PSXFILL,0),"^",2))
- +8 IF '$GET(PSXTN1)
- IF ($GET(PSXM)=$GET(PSXM1))
- IF ($GET(PSXYES))!('$GET(PSXST))
- GOTO PSXDIEX
- +9 SET PSXFROM="EDIT"
- +10 SET PSXPPL=ZRX
- DO TEST^PSXNEW
- SUS ; If Rx is suspended and checks out to be CMOP suspend as CMOP
- +1 NEW DA
- +2 if '$GET(PSXSYS)
- QUIT
- +3 IF '$GET(PPL)
- IF ($GET(PSXST))
- DO ACT
- Begin DoDot:1
- +4 KILL ^PS(52.5,"AC",$PIECE(^PSRX(ZRX,0),"^",2),$PIECE(^PS(52.5,PSXST,0),"^",2),PSXST)
- +5 SET DIE="^PS(52.5,"
- SET DR="3////Q"
- SET DA=PSXST
- DO ^DIE
- KILL DIE
- +6 SET T=$PIECE(^PSRX(ZRX,3),"^")
- +7 SET T1=$EXTRACT(T,4,5)_"-"_$EXTRACT(T,6,7)_"-"_$EXTRACT(T,2,3)
- +8 SET $PIECE(^PSRX(ZRX,"A",0),"^",3)=A
- SET $PIECE(^PSRX(ZRX,"A",0),"^",4)=A1
- +9 DO NOW^%DTC
- +10 ; Accomodating 1 yr patch
- IF $GET(PSXFILL)>5
- SET PSXFILL=PSXFILL+1
- +11 SET ^PSRX(ZRX,"A",PSXB,0)=%_"^S^"_DUZ_"^"_$GET(PSXFILL)_"^ Suspended for CMOP "_T1
- +12 KILL T,T1,%
- End DoDot:1
- GOTO PSXDIEX
- UNSUS ; If Rx is suspended and is not CMOP, ensure is not suspended as CMOP
- +1 IF $GET(PSXST)
- Begin DoDot:1
- +2 SET DIE="^PS(52.5,"
- SET DR="3////@"
- SET DA=PSXST
- DO ^DIE
- KILL DIE
- +3 SET ^PS(52.5,"AC",$PIECE(^PSRX(ZRX,0),"^",2),$PIECE(^PS(52.5,PSXST,0),"^",2),PSXST)=""
- End DoDot:1
- PSXDIEX ;
- +1 KILL PSX,PSXA,PSXB,PSXREL,PSXST,PSXST1,ZRX,PSXIDT,PSXFROM,PSXTN1,PSX50
- +2 KILL PSXFDT,PSXRXF,PSXFILL,PSXFLAG,PSXM,PSXM1,PSXSTAT,PSXSUSDT,PSXTN,ZZ
- +3 KILL PSXHLD,PSXREL1,PSXSTAT,ZZ1,A,A1,ACT,PSXYES,PSXFLAGG,DIE,DR,ZPPL,MSG
- +4 QUIT
- ACT ; If no act node, make one .... determine last entry
- +1 if '$DATA(^PSRX(ZRX,"A",0))
- SET ^(0)="^52.3DA^^"
- +2 SET PSXA=""
- FOR
- SET PSXA=$ORDER(^PSRX(ZRX,"A",PSXA))
- if PSXA']""
- QUIT
- SET PSXB=PSXA+1
- +3 SET A=$PIECE(^PSRX(ZRX,"A",0),"^",3)
- SET A1=$PIECE(^PSRX(ZRX,"A",0),"^",4)
- SET A=A+1
- SET A1=A1+1
- +4 KILL PSXA
- +5 QUIT
- CHECK ;
- +1 IF $GET(PSX(D1))[1
- SET Y="@1"
- +2 QUIT
