- PSOCMOPA ;BIR/HTW-Utility for Hold/Can/Park ;Feb 07, 2019@06:29:42
- ;;7.0;OUTPATIENT PHARMACY;**61,76,443,508,441**;DEC 1997;Build 208
- ;External Referrence to file # 550.2 granted by DBIA 2231
- ;Required input: DA - internal entry # - ^PSRX
- ;Returns:
- ;CMOP("L")=LAST FILL... if it is orig Rx =0
- ;CMOP(FILL #)=CMOP status from 52...Trans/0,DISP/1,RETRAN/2,NOT DISP/3
- ;If suspended CMOP("S")=CMOP suspense status Q,L,X,P,R
- ;PSOCMOP=STATUS_^_TRAN DATE_^_LAST FILL
- ;All returned variables can be killed by K CMOP,PSOCMOP
- ;
- N X,XN,BATCH,TDT,BIEN
- K PSOCMOP
- S (CMOP("L"),X)=0 F S X=$O(^PSRX(DA,1,X)) Q:'X S CMOP("L")=X
- I $O(^PSRX(DA,4,0)) F X=0:0 S X=$O(^PSRX(DA,4,X)) Q:'X D
- .S XN=$G(^PSRX(DA,4,X,0)),BATCH=$P($G(XN),"^") Q:$G(BATCH)']""
- .S BIEN=$O(^PSX(550.2,"B",BATCH,"")) Q:$G(BIEN)']"" S TDT=$P(^PSX(550.2,BIEN,0),"^",6)
- .S CMOP($P($G(XN),"^",3))=$P($G(XN),"^",4),PSOCMOP=$P($G(XN),"^",4)_"^"_$G(TDT)_"^"_CMOP("L")
- S X=$O(^PS(52.5,"B",DA,0)) I X]"" S CMOP("S")=$P($G(^PS(52.5,X,0)),"^",7),CMOP("52.5")=X
- K X,XN,BATCH,TDT,BIEN
- Q
- UNHOLD N FDT S FDT=PSORX("FILL DATE"),XFROM="UNHOLD" G EN1
- UNPARK N FDT S FDT=PSORX("FILL DATE"),XFROM="UNPARK" G EN1 ;441 PAPI
- REINS S XFROM="REINSTATE"
- EN1 D SUS1^PSOCMOP I '$G(XFLAG) G KILL
- D PSOCMOPA
- I $G(REL)]""!($G(CMOP(CMOP("L")))=0)!($G(CMOP(CMOP("L")))=2) D G KILL
- .I XFROM="REINSTATE" W !!,RX_" REINSTATED -- ",! Q
- .I XFROM="UNHOLD" W !!,$P(^PSRX(DA,0),"^")_" Removed from Hold Status",!!
- .I XFROM="UNPARK" W !!,$P(^PSRX(DA,0),"^")_" Removed from Park Status",!! ;441 PAPI
- I $G(CMOP(CMOP("L")))']"" D S^PSOCMOP G KILL
- I $G(CMOP(CMOP("L")))=3,(FDT>DT) D S^PSOCMOP G KILL
- KILL D D1^PSOCMOP
- K CMOP,DIR,X,DIRUT,DUOUT,Y,DTOUT,XFROM
- Q
- ;
- QS W !! S DIR("A")="LABEL: QUEUE"_$S($P(PSOPAR,"^",24):"/SUSPEND",1:"")_" or '^' to bypass "
- S DIR("?",1)="Enter 'Q' to queue labels for printing" S:$P(PSOPAR,"^",24) DIR("?",2)="Enter 'S' to suspend labels for printing at a later date"
- S DIR(0)="SA^Q:QUEUE"_$S($P(PSOPAR,"^",24):";S:SUSPENSE",1:""),DIR("B")="Q" D ^DIR K DIR
- I $D(DUOUT)!$D(DIRUT) G KILL
- I $G(Y)="S" D S^PSOCMOP K CMOP Q
- I $G(Y)="Q" D D1^PSOCMOP K CMOP I $G(PSOLAP)]"",($G(PSOLAP)'=ION) S PPL=DA,RXLTOP=1 D QLBL^PSORXL Q
- I $G(Y)="Q" S PPL=DA,RXLTOP=1 D Q1^PSORXL
- Q
- HLD N PSOFROM S PSOFROM="HOLD"
- EN ; Called from PSORXDL,HLD+4^PSOHLD, PSOCAN, PSOPRK
- ; if in suspense and "loading" no delete
- Q:'$G(DA) D PSOCMOPA
- I $G(CMOP("S"))="L" D MSG K CMOP Q
- ; PSO*7*508 - quit before the DIR call if this is an eRx
- I $G(PSOFROM)="HOLD",($G(CMOP(CMOP("L")))=0!($G(CMOP(CMOP("L")))=2)) D MSG D MSG Q:$G(ERXDCIEN) K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR ;*443
- I $G(PSOFROM)="DELETE",($G(CMOP(CMOP("L")))=0!($G(CMOP(CMOP("L")))=2)) D MSG
- K CMOP
- Q
- MSG I $G(ERXDCIEN) S XFLAG=1 Q
- ;441 PAPI
- W !!,"A CMOP Rx cannot be"_$S($G(PSOFROM)="HOLD":" placed on HOLD",$G(PSOFROM)="CANCEL":" DISCONTINUED",$G(PSOFROM)="PARK":" PARKED",1:" DELETED")
- W $S($G(PSOFROM)="DELETE":" while in",1:" during")
- W $S($G(PSOFROM)="DELETE":" transmission status!",1:" transmission! ")_" Try later.",!!
- S XFLAG=1
- Q
- CMOP ;
- I $D(^PSRX(RXN,4)) F PSXZ=0:0 S PSXZ=$O(^PSRX(RXN,4,PSXZ)) Q:'PSXZ D
- .S PSX($P(^PSRX(RXN,4,PSXZ,0),U,3))=$P(^PSRX(RXN,4,PSXZ,0),U,4)
- K PSXZ
- Q
- DUPCAN N DA,PSOFROM S DA=+PSOSD(STA,DNM),PSOFROM="CANCEL" G EN
- ;Called from ASK+4^PSORENW
- MW(PSODIR) ;
- K DIR,DIC
- S DIR(0)="52,11"
- S DIR("B")=$S($G(PSORX("MAIL/WINDOW"))]"":PSORX("MAIL/WINDOW"),1:"WINDOW")
- I $G(PSODRUG("DEA"))["D",$E($G(PSORX("MAIL/WINDOW")))="P" S DIR("B")="WINDOW" ;441 PAPI
- I ($G(PSODRUG("DEA"))["D")!($G(DRGNM)["CLOZAPINE") S DIR(0)="S^M:MAIL;W:WINDOW",DIR("A")="MAIL/WINDOW" G MW0 ;441 PAPI & CLOZAPINE
- ;I $P(PSOPAR,"^",34) S DIR(0)="S^M:MAIL;W:WINDOW;P:PARK",DIR("A")="MAIL/WINDOW/PARK"
- ;I '$P(PSOPAR,"^",34) S DIR(0)="S^M:MAIL;W:WINDOW",DIR("A")="MAIL/WINDOW"
- N RESULTS,PSOPARKX
- S RESULTS="PSOPARKX" D GETPARK^PSORPC01()
- I $G(PSOPARKX(0))="YES" S DIR(0)="S^M:MAIL;W:WINDOW;P:PARK",DIR("A")="MAIL/WINDOW/PARK"
- E S DIR(0)="S^M:MAIL;W:WINDOW",DIR("A")="MAIL/WINDOW"
- MW0 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") MWX
- I $G(Y(0))']"" S PSODIR("DFLG")=1 G MWX
- S PSODIR("MAIL/WINDOW")=Y,PSORX("MAIL/WINDOW")=Y(0)
- MW1 G:PSODIR("MAIL/WINDOW")'="W"!('$P($G(PSOPAR),"^",12)) MWX
- S DIR(0)="52,35O"
- S:$G(PSORX("METHOD OF PICK-UP"))]"" DIR("B")=PSORX("METHOD OF PICK-UP")
- D DIR G:PSODIR("DFLG") MWX
- I X[U W !,"Cannot jump to another field ..",! G MW1
- S (PSODIR("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))=Y
- MWX K X,Y
- Q
- DIR ;
- S PSODIR("FIELD")=0
- G:$G(DIR(0))']"" DIRX
- D ^DIR K DIR,DIE,DIC,DA
- I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1!(Y="") S PSODIR("DFLG")=1 G DIRX
- DIRX K DIRUT,DTOUT,DUOUT,DIROUT,PSOX
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCMOPA 4802 printed Jan 18, 2025@03:26:41 Page 2
- PSOCMOPA ;BIR/HTW-Utility for Hold/Can/Park ;Feb 07, 2019@06:29:42
- +1 ;;7.0;OUTPATIENT PHARMACY;**61,76,443,508,441**;DEC 1997;Build 208
- +2 ;External Referrence to file # 550.2 granted by DBIA 2231
- +3 ;Required input: DA - internal entry # - ^PSRX
- +4 ;Returns:
- +5 ;CMOP("L")=LAST FILL... if it is orig Rx =0
- +6 ;CMOP(FILL #)=CMOP status from 52...Trans/0,DISP/1,RETRAN/2,NOT DISP/3
- +7 ;If suspended CMOP("S")=CMOP suspense status Q,L,X,P,R
- +8 ;PSOCMOP=STATUS_^_TRAN DATE_^_LAST FILL
- +9 ;All returned variables can be killed by K CMOP,PSOCMOP
- +10 ;
- +11 NEW X,XN,BATCH,TDT,BIEN
- +12 KILL PSOCMOP
- +13 SET (CMOP("L"),X)=0
- FOR
- SET X=$ORDER(^PSRX(DA,1,X))
- if 'X
- QUIT
- SET CMOP("L")=X
- +14 IF $ORDER(^PSRX(DA,4,0))
- FOR X=0:0
- SET X=$ORDER(^PSRX(DA,4,X))
- if 'X
- QUIT
- Begin DoDot:1
- +15 SET XN=$GET(^PSRX(DA,4,X,0))
- SET BATCH=$PIECE($GET(XN),"^")
- if $GET(BATCH)']""
- QUIT
- +16 SET BIEN=$ORDER(^PSX(550.2,"B",BATCH,""))
- if $GET(BIEN)']""
- QUIT
- SET TDT=$PIECE(^PSX(550.2,BIEN,0),"^",6)
- +17 SET CMOP($PIECE($GET(XN),"^",3))=$PIECE($GET(XN),"^",4)
- SET PSOCMOP=$PIECE($GET(XN),"^",4)_"^"_$GET(TDT)_"^"_CMOP("L")
- End DoDot:1
- +18 SET X=$ORDER(^PS(52.5,"B",DA,0))
- IF X]""
- SET CMOP("S")=$PIECE($GET(^PS(52.5,X,0)),"^",7)
- SET CMOP("52.5")=X
- +19 KILL X,XN,BATCH,TDT,BIEN
- +20 QUIT
- UNHOLD NEW FDT
- SET FDT=PSORX("FILL DATE")
- SET XFROM="UNHOLD"
- GOTO EN1
- UNPARK ;441 PAPI
- NEW FDT
- SET FDT=PSORX("FILL DATE")
- SET XFROM="UNPARK"
- GOTO EN1
- REINS SET XFROM="REINSTATE"
- EN1 DO SUS1^PSOCMOP
- IF '$GET(XFLAG)
- GOTO KILL
- +1 DO PSOCMOPA
- +2 IF $GET(REL)]""!($GET(CMOP(CMOP("L")))=0)!($GET(CMOP(CMOP("L")))=2)
- Begin DoDot:1
- +3 IF XFROM="REINSTATE"
- WRITE !!,RX_" REINSTATED -- ",!
- QUIT
- +4 IF XFROM="UNHOLD"
- WRITE !!,$PIECE(^PSRX(DA,0),"^")_" Removed from Hold Status",!!
- +5 ;441 PAPI
- IF XFROM="UNPARK"
- WRITE !!,$PIECE(^PSRX(DA,0),"^")_" Removed from Park Status",!!
- End DoDot:1
- GOTO KILL
- +6 IF $GET(CMOP(CMOP("L")))']""
- DO S^PSOCMOP
- GOTO KILL
- +7 IF $GET(CMOP(CMOP("L")))=3
- IF (FDT>DT)
- DO S^PSOCMOP
- GOTO KILL
- KILL DO D1^PSOCMOP
- +1 KILL CMOP,DIR,X,DIRUT,DUOUT,Y,DTOUT,XFROM
- +2 QUIT
- +3 ;
- QS WRITE !!
- SET DIR("A")="LABEL: QUEUE"_$SELECT($PIECE(PSOPAR,"^",24):"/SUSPEND",1:"")_" or '^' to bypass "
- +1 SET DIR("?",1)="Enter 'Q' to queue labels for printing"
- if $PIECE(PSOPAR,"^",24)
- SET DIR("?",2)="Enter 'S' to suspend labels for printing at a later date"
- +2 SET DIR(0)="SA^Q:QUEUE"_$SELECT($PIECE(PSOPAR,"^",24):";S:SUSPENSE",1:"")
- SET DIR("B")="Q"
- DO ^DIR
- KILL DIR
- +3 IF $DATA(DUOUT)!$DATA(DIRUT)
- GOTO KILL
- +4 IF $GET(Y)="S"
- DO S^PSOCMOP
- KILL CMOP
- QUIT
- +5 IF $GET(Y)="Q"
- DO D1^PSOCMOP
- KILL CMOP
- IF $GET(PSOLAP)]""
- IF ($GET(PSOLAP)'=ION)
- SET PPL=DA
- SET RXLTOP=1
- DO QLBL^PSORXL
- QUIT
- +6 IF $GET(Y)="Q"
- SET PPL=DA
- SET RXLTOP=1
- DO Q1^PSORXL
- +7 QUIT
- HLD NEW PSOFROM
- SET PSOFROM="HOLD"
- EN ; Called from PSORXDL,HLD+4^PSOHLD, PSOCAN, PSOPRK
- +1 ; if in suspense and "loading" no delete
- +2 if '$GET(DA)
- QUIT
- DO PSOCMOPA
- +3 IF $GET(CMOP("S"))="L"
- DO MSG
- KILL CMOP
- QUIT
- +4 ; PSO*7*508 - quit before the DIR call if this is an eRx
- +5 ;*443
- IF $GET(PSOFROM)="HOLD"
- IF ($GET(CMOP(CMOP("L")))=0!($GET(CMOP(CMOP("L")))=2))
- DO MSG
- DO MSG
- if $GET(ERXDCIEN)
- QUIT
- KILL DIR
- SET DIR(0)="E"
- SET DIR("A")="Press Return to Continue"
- DO ^DIR
- KILL DIR
- +6 IF $GET(PSOFROM)="DELETE"
- IF ($GET(CMOP(CMOP("L")))=0!($GET(CMOP(CMOP("L")))=2))
- DO MSG
- +7 KILL CMOP
- +8 QUIT
- MSG IF $GET(ERXDCIEN)
- SET XFLAG=1
- QUIT
- +1 ;441 PAPI
- +2 WRITE !!,"A CMOP Rx cannot be"_$SELECT($GET(PSOFROM)="HOLD":" placed on HOLD",$GET(PSOFROM)="CANCEL":" DISCONTINUED",$GET(PSOFROM)="PARK":" PARKED",1:" DELETED")
- +3 WRITE $SELECT($GET(PSOFROM)="DELETE":" while in",1:" during")
- +4 WRITE $SELECT($GET(PSOFROM)="DELETE":" transmission status!",1:" transmission! ")_" Try later.",!!
- +5 SET XFLAG=1
- +6 QUIT
- CMOP ;
- +1 IF $DATA(^PSRX(RXN,4))
- FOR PSXZ=0:0
- SET PSXZ=$ORDER(^PSRX(RXN,4,PSXZ))
- if 'PSXZ
- QUIT
- Begin DoDot:1
- +2 SET PSX($PIECE(^PSRX(RXN,4,PSXZ,0),U,3))=$PIECE(^PSRX(RXN,4,PSXZ,0),U,4)
- End DoDot:1
- +3 KILL PSXZ
- +4 QUIT
- DUPCAN NEW DA,PSOFROM
- SET DA=+PSOSD(STA,DNM)
- SET PSOFROM="CANCEL"
- GOTO EN
- +1 ;Called from ASK+4^PSORENW
- MW(PSODIR) ;
- +1 KILL DIR,DIC
- +2 SET DIR(0)="52,11"
- +3 SET DIR("B")=$SELECT($GET(PSORX("MAIL/WINDOW"))]"":PSORX("MAIL/WINDOW"),1:"WINDOW")
- +4 ;441 PAPI
- IF $GET(PSODRUG("DEA"))["D"
- IF $EXTRACT($GET(PSORX("MAIL/WINDOW")))="P"
- SET DIR("B")="WINDOW"
- +5 ;441 PAPI & CLOZAPINE
- IF ($GET(PSODRUG("DEA"))["D")!($GET(DRGNM)["CLOZAPINE")
- SET DIR(0)="S^M:MAIL;W:WINDOW"
- SET DIR("A")="MAIL/WINDOW"
- GOTO MW0
- +6 ;I $P(PSOPAR,"^",34) S DIR(0)="S^M:MAIL;W:WINDOW;P:PARK",DIR("A")="MAIL/WINDOW/PARK"
- +7 ;I '$P(PSOPAR,"^",34) S DIR(0)="S^M:MAIL;W:WINDOW",DIR("A")="MAIL/WINDOW"
- +8 NEW RESULTS,PSOPARKX
- +9 SET RESULTS="PSOPARKX"
- DO GETPARK^PSORPC01()
- +10 IF $GET(PSOPARKX(0))="YES"
- SET DIR(0)="S^M:MAIL;W:WINDOW;P:PARK"
- SET DIR("A")="MAIL/WINDOW/PARK"
- +11 IF '$TEST
- SET DIR(0)="S^M:MAIL;W:WINDOW"
- SET DIR("A")="MAIL/WINDOW"
- MW0 DO DIR
- if PSODIR("DFLG")!PSODIR("FIELD")
- GOTO MWX
- +1 IF $GET(Y(0))']""
- SET PSODIR("DFLG")=1
- GOTO MWX
- +2 SET PSODIR("MAIL/WINDOW")=Y
- SET PSORX("MAIL/WINDOW")=Y(0)
- MW1 if PSODIR("MAIL/WINDOW")'="W"!('$PIECE($GET(PSOPAR),"^",12))
- GOTO MWX
- +1 SET DIR(0)="52,35O"
- +2 if $GET(PSORX("METHOD OF PICK-UP"))]""
- SET DIR("B")=PSORX("METHOD OF PICK-UP")
- +3 DO DIR
- if PSODIR("DFLG")
- GOTO MWX
- +4 IF X[U
- WRITE !,"Cannot jump to another field ..",!
- GOTO MW1
- +5 SET (PSODIR("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))=Y
- MWX KILL X,Y
- +1 QUIT
- DIR ;
- +1 SET PSODIR("FIELD")=0
- +2 if $GET(DIR(0))']""
- GOTO DIRX
- +3 DO ^DIR
- KILL DIR,DIE,DIC,DA
- +4 IF $DATA(DUOUT)!($DATA(DTOUT))!($DATA(DIROUT))
- IF $LENGTH($GET(X))'>1!(Y="")
- SET PSODIR("DFLG")=1
- GOTO DIRX
- DIRX KILL DIRUT,DTOUT,DUOUT,DIROUT,PSOX
- +1 QUIT