- PSOCMOPC ;BIR/HTW-Utility for CMOP/OP Edit ;8/30/96
- ;;7.0;OUTPATIENT PHARMACY;**2,30,43,547,753**;DEC 1997;Build 53
- ;External reference to ^PS(55 supported by DBIA 2228
- ;External reference to ^PSDRUG supported by DBIA 221
- EN(XDA) N A,A1,CMOP,PSOA,PSOB,PSOCK,T,T1,DA
- ;
- S DA=XDA
- D ^PSOCMOPA
- ; Q:If not in suspense file, set status to 0 - active
- I '$G(CMOP("52.5")) D Q
- . S:+$P($G(PSOLST(ORN)),"^",2) ^PSRX($P(PSOLST(ORN),"^",2),"STA")=0
- ;
- D CHECK
- I $G(CMOP("S"))']"",($G(CMOP)) D ACT D G QUIT
- .K ^PS(52.5,"AC",$P(^PSRX(XDA,0),"^",2),$P(^PS(52.5,CMOP("52.5"),0),"^",2),CMOP("52.5"))
- .S DIE="^PS(52.5,",DR="3////Q",DA=CMOP("52.5") D ^DIE K DIE
- .S T=$P(^PSRX(XDA,3),"^")
- .S T1=$E(T,4,5)_"-"_$E(T,6,7)_"-"_$E(T,2,3)
- .S $P(^PSRX(XDA,"A",0),"^",3)=A,$P(^PSRX(XDA,"A",0),"^",4)=A1
- .D NOW^%DTC
- .S ^PSRX(XDA,"A",PSOB,0)=%_"^S^"_DUZ_"^"_$S($G(CMOP("L"))<6:$G(CMOP("L")),1:$G(CMOP("L"))+1)_"^ Placed on Suspense for CMOP until "_T1
- .K T,T1,%
- UNSUS ; If Rx is suspended and is not CMOP, ensure is not suspended as CMOP (Exception of a Partial Fill done after the CMOP Suspense)
- I $G(CMOP("S"))["Q",('$G(CMOP)),'$G(RXPR(XDA)),$G(PSOFROM)'="PARTIAL" D G QUIT
- .S DIE="^PS(52.5,",DR="3////@",DA=CMOP("52.5") D ^DIE K DIE,DR
- .S ^PS(52.5,"AC",$P(^PSRX(XDA,0),"^",2),$P(^PS(52.5,DA,0),"^",2),DA)=""
- .D ACT
- .S T=$P(^PSRX(XDA,3),"^")
- .S T1=$E(T,4,5)_"-"_$E(T,6,7)_"-"_$E(T,2,3)
- .S $P(^PSRX(XDA,"A",0),"^",3)=A,$P(^PSRX(XDA,"A",0),"^",4)=A1
- .D NOW^%DTC
- .S ^PSRX(XDA,"A",PSOB,0)=%_"^S^"_DUZ_"^"_$S($G(CMOP("L"))<6:$G(CMOP("L")),1:$G(CMOP("L"))+1)_"^ Removed from CMOP Suspense, returned to OP Suspense. "_T1
- .S DA=XDA
- QUIT K A,A1,CMOP,PSOA,PSOB,PSOCK,T,T1,XDA Q
- ACT ; If no act node, make one .... determine last entry
- S:'$D(^PSRX(XDA,"A",0)) ^(0)="^52.3XDA^^"
- S PSOA="" F S PSOA=$O(^PSRX(XDA,"A",PSOA)) Q:PSOA']"" S PSOB=PSOA+1
- S A=$P(^PSRX(XDA,"A",0),"^",3),A1=$P(^PSRX(XDA,"A",0),"^",4),A=A+1,A1=A1+1
- K PSOA
- Q
- CHECK S CMOP=0 Q:'$G(PSXSYS)
- ; Q:Partial or Reprint
- S PSOCMSUS=$O(^PS(52.5,"B",XDA,0))
- I $G(PSOCMSUS) I $P($G(^PS(52.5,PSOCMSUS,0)),"^",5)!($P($G(^(0)),"^",12)) K PSOCMSUS Q
- K PSOCMSUS
- ; Q:Do not Mail
- S PSOCMPAT=+$P($G(^PSRX(XDA,0)),"^",2),PSOCMDT=$P($G(^PS(55,PSOCMPAT,0)),"^",5),PSOCMMAI=$P($G(^PS(55,PSOCMPAT,0)),"^",3)
- I $$GET1^DIQ(52,XDA,100.2,"I")]"" S PSOCMMAI=$$GET1^DIQ(52,XDA,100.2,"I"),PSOCMDT="" ;p753
- I $G(PSOCMMAI)>1,$S($G(PSOCMDT)=""!($G(PSOCMDT)>DT):1,1:0) D KMAIL Q
- D KMAIL
- ; Get drug IEN and check if CMOP
- S PSOCK=$P($G(^PSRX(XDA,0)),"^",6) Q:'$D(^PSDRUG("AQ",PSOCK))
- I $P($G(^PSDRUG(+$G(PSOCK),2)),"^",3)'["O" Q
- Q:$G(PSOFROM)="PARTIAL"
- ; Q:If tradename
- Q:$G(^PSRX(XDA,"TN"))]""
- ; Q: If Cancelled, Expired, Deleted
- Q:$P($G(^PSRX(XDA,"STA")),"^")>10
- ; Q: If pending
- Q:$P($G(^PSRX(XDA,"STA")),"^")=4
- ; Q:If not "Mail"
- S PSOMW=$S($G(CMOP("L"))>0:$P(^PSRX(XDA,1,CMOP("L"),0),"^",2),1:$P(^PSRX(XDA,0),"^",11)) I $G(PSOMW)="W" K CMOP("L") Q
- ; Q:If fill was CMOPed and other than '3' 'not dispensed'
- Q:'$$FILTRAN^PSOCMOP(XDA,CMOP("L"))
- S CMOP=1
- Q
- KMAIL K PSOCMPAT,PSOCMDT,PSOCMMAI Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCMOPC 3211 printed Feb 18, 2025@23:52 Page 2
- PSOCMOPC ;BIR/HTW-Utility for CMOP/OP Edit ;8/30/96
- +1 ;;7.0;OUTPATIENT PHARMACY;**2,30,43,547,753**;DEC 1997;Build 53
- +2 ;External reference to ^PS(55 supported by DBIA 2228
- +3 ;External reference to ^PSDRUG supported by DBIA 221
- EN(XDA) NEW A,A1,CMOP,PSOA,PSOB,PSOCK,T,T1,DA
- +1 ;
- +2 SET DA=XDA
- +3 DO ^PSOCMOPA
- +4 ; Q:If not in suspense file, set status to 0 - active
- +5 IF '$GET(CMOP("52.5"))
- Begin DoDot:1
- +6 if +$PIECE($GET(PSOLST(ORN)),"^",2)
- SET ^PSRX($PIECE(PSOLST(ORN),"^",2),"STA")=0
- End DoDot:1
- QUIT
- +7 ;
- +8 DO CHECK
- +9 IF $GET(CMOP("S"))']""
- IF ($GET(CMOP))
- DO ACT
- Begin DoDot:1
- +10 KILL ^PS(52.5,"AC",$PIECE(^PSRX(XDA,0),"^",2),$PIECE(^PS(52.5,CMOP("52.5"),0),"^",2),CMOP("52.5"))
- +11 SET DIE="^PS(52.5,"
- SET DR="3////Q"
- SET DA=CMOP("52.5")
- DO ^DIE
- KILL DIE
- +12 SET T=$PIECE(^PSRX(XDA,3),"^")
- +13 SET T1=$EXTRACT(T,4,5)_"-"_$EXTRACT(T,6,7)_"-"_$EXTRACT(T,2,3)
- +14 SET $PIECE(^PSRX(XDA,"A",0),"^",3)=A
- SET $PIECE(^PSRX(XDA,"A",0),"^",4)=A1
- +15 DO NOW^%DTC
- +16 SET ^PSRX(XDA,"A",PSOB,0)=%_"^S^"_DUZ_"^"_$SELECT($GET(CMOP("L"))<6:$GET(CMOP("L")),1:$GET(CMOP("L"))+1)_"^ Placed on Suspense for CMOP until "_T1
- +17 KILL T,T1,%
- End DoDot:1
- GOTO QUIT
- UNSUS ; If Rx is suspended and is not CMOP, ensure is not suspended as CMOP (Exception of a Partial Fill done after the CMOP Suspense)
- +1 IF $GET(CMOP("S"))["Q"
- IF ('$GET(CMOP))
- IF '$GET(RXPR(XDA))
- IF $GET(PSOFROM)'="PARTIAL"
- Begin DoDot:1
- +2 SET DIE="^PS(52.5,"
- SET DR="3////@"
- SET DA=CMOP("52.5")
- DO ^DIE
- KILL DIE,DR
- +3 SET ^PS(52.5,"AC",$PIECE(^PSRX(XDA,0),"^",2),$PIECE(^PS(52.5,DA,0),"^",2),DA)=""
- +4 DO ACT
- +5 SET T=$PIECE(^PSRX(XDA,3),"^")
- +6 SET T1=$EXTRACT(T,4,5)_"-"_$EXTRACT(T,6,7)_"-"_$EXTRACT(T,2,3)
- +7 SET $PIECE(^PSRX(XDA,"A",0),"^",3)=A
- SET $PIECE(^PSRX(XDA,"A",0),"^",4)=A1
- +8 DO NOW^%DTC
- +9 SET ^PSRX(XDA,"A",PSOB,0)=%_"^S^"_DUZ_"^"_$SELECT($GET(CMOP("L"))<6:$GET(CMOP("L")),1:$GET(CMOP("L"))+1)_"^ Removed from CMOP Suspense, returned to OP Suspense. "_T1
- +10 SET DA=XDA
- End DoDot:1
- GOTO QUIT
- QUIT KILL A,A1,CMOP,PSOA,PSOB,PSOCK,T,T1,XDA
- QUIT
- ACT ; If no act node, make one .... determine last entry
- +1 if '$DATA(^PSRX(XDA,"A",0))
- SET ^(0)="^52.3XDA^^"
- +2 SET PSOA=""
- FOR
- SET PSOA=$ORDER(^PSRX(XDA,"A",PSOA))
- if PSOA']""
- QUIT
- SET PSOB=PSOA+1
- +3 SET A=$PIECE(^PSRX(XDA,"A",0),"^",3)
- SET A1=$PIECE(^PSRX(XDA,"A",0),"^",4)
- SET A=A+1
- SET A1=A1+1
- +4 KILL PSOA
- +5 QUIT
- CHECK SET CMOP=0
- if '$GET(PSXSYS)
- QUIT
- +1 ; Q:Partial or Reprint
- +2 SET PSOCMSUS=$ORDER(^PS(52.5,"B",XDA,0))
- +3 IF $GET(PSOCMSUS)
- IF $PIECE($GET(^PS(52.5,PSOCMSUS,0)),"^",5)!($PIECE($GET(^(0)),"^",12))
- KILL PSOCMSUS
- QUIT
- +4 KILL PSOCMSUS
- +5 ; Q:Do not Mail
- +6 SET PSOCMPAT=+$PIECE($GET(^PSRX(XDA,0)),"^",2)
- SET PSOCMDT=$PIECE($GET(^PS(55,PSOCMPAT,0)),"^",5)
- SET PSOCMMAI=$PIECE($GET(^PS(55,PSOCMPAT,0)),"^",3)
- +7 ;p753
- IF $$GET1^DIQ(52,XDA,100.2,"I")]""
- SET PSOCMMAI=$$GET1^DIQ(52,XDA,100.2,"I")
- SET PSOCMDT=""
- +8 IF $GET(PSOCMMAI)>1
- IF $SELECT($GET(PSOCMDT)=""!($GET(PSOCMDT)>DT):1,1:0)
- DO KMAIL
- QUIT
- +9 DO KMAIL
- +10 ; Get drug IEN and check if CMOP
- +11 SET PSOCK=$PIECE($GET(^PSRX(XDA,0)),"^",6)
- if '$DATA(^PSDRUG("AQ",PSOCK))
- QUIT
- +12 IF $PIECE($GET(^PSDRUG(+$GET(PSOCK),2)),"^",3)'["O"
- QUIT
- +13 if $GET(PSOFROM)="PARTIAL"
- QUIT
- +14 ; Q:If tradename
- +15 if $GET(^PSRX(XDA,"TN"))]""
- QUIT
- +16 ; Q: If Cancelled, Expired, Deleted
- +17 if $PIECE($GET(^PSRX(XDA,"STA")),"^")>10
- QUIT
- +18 ; Q: If pending
- +19 if $PIECE($GET(^PSRX(XDA,"STA")),"^")=4
- QUIT
- +20 ; Q:If not "Mail"
- +21 SET PSOMW=$SELECT($GET(CMOP("L"))>0:$PIECE(^PSRX(XDA,1,CMOP("L"),0),"^",2),1:$PIECE(^PSRX(XDA,0),"^",11))
- IF $GET(PSOMW)="W"
- KILL CMOP("L")
- QUIT
- +22 ; Q:If fill was CMOPed and other than '3' 'not dispensed'
- +23 if '$$FILTRAN^PSOCMOP(XDA,CMOP("L"))
- QUIT
- +24 SET CMOP=1
- +25 QUIT
- KMAIL KILL PSOCMPAT,PSOCMDT,PSOCMMAI
- QUIT