Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APSPRESK

APSPRESK.m

Go to the documentation of this file. 
  1. APSPRESK ; IHS/DSD/ENM - BHAM ISC/SAB/ENM - RETURN TO STOCK ;21-Mar-2004 20:36;PLS
  1.  ;;7.0;IHS PHARMACY MODIFICATIONS;;09/03/97
  1.  ;MODIFIED VERSION OF PSORESK BY ENM
  1.  ; Modified - 01/21/04 - Changed calls to PSONUM to APSPNUM
  1.  S:$G(PSOFROM)']"" PSOFROM="RETURN" ;IHS/DSD/ENM 02/07/96
  1. AC S PSIN=+$P(^PS(59.7,1,49.99),"^",2)
  1.  ;IHS/DSD/ENM  6.14.95 Next 13 lines added for multi-lkup&view Rx data
  1. START G:$D(PSOSD)'>1 END ;IHS/DSD/ENM/POC 3/5/98
  1.  D INIT,LKUP G:PSORXED("QFLG") END D PARSE,EX G AC
  1. END D EX
  1. EMQ Q
  1. INIT S PSORXED("QFLG")=0 Q
  1. LKUP ;S PSONUM="RX",PSONUM("A")="Return to Stock",PSOQFLG=0 D EN1^APSPNUM I PSOQFLG!($Q(PSOLIST)']"") S PSORXED("QFLG")=1 ;IHS/DSD/ENM 10/01/96
  1.  N PSOOPT S PSOOPT=0 ;IHS/DSD/ENM 10/01/96
  1.  S PSONUM("A")="Return to Stock ",PSOQFLG=0 D ^APSPNUM I $G(PSOQFLG)']""!($Q(PSOLIST)']"") S PSORXED("QFLG")=1 ;IHS/DSD/ENM 10/30/97
  1.  K PSOQFLG Q
  1.  ;
  1. PARSE F PSORXED("LIST")=1:1 Q:'$D(PSOLIST(PSORXED("LIST")))!PSORXED("QFLG")  F PSORXED("I")=1:1:$L(PSOLIST(PSORXED("LIST"))) S PSORXED("IRXN")=$P(PSOLIST(PSORXED("LIST")),",",PSORXED("I")) D:+PSORXED("IRXN") BC
  1.  Q
  1. BC ;W !! S DIR("A")="Enter PRESCRIPTION number",DIR("?")="^D HP^PSORESK",DIR(0)="FO" D ^DIR K DIR G:$D(DIRUT) EX
  1.  S APSPX="" D ^APSPRXV S (X,Y)=APSPX9 ;IHS/DSD/ENM DISPLAY RX INFO
  1.  ;G:$D(DIRUT) EX ;IHS/DSD/ENM 5.19.95
  1.  Q:APSPQ  ;IHS/DSD/ENM 5.19.95
  1.  I X'["-" D BCI W:'$G(RXP) !,"INVALID Rx" G:'$G(RXP) EMQ G BC1
  1.  I X["-",$P(X,"-")'=$P(^DD("SITE",1),"^") W !,*7,*7,"   INVALID STATION NUMBER !!",*7,*7,! Q
  1.  I X["-" S RXP=$P(X,"-",2) I '$D(^PSRX(+$G(RXP),0))!($G(RXP)']"") W !,*7,*7,*7,"   NON-EXISTENT Rx" Q
  1.  G:$D(^PSRX(RXP,0)) BC1
  1.  W !,*7,*7,*7,"   IMPROPER BARCODE FORMAT" Q
  1. BC1 ;
  1.  I $S('+$P($G(^PSRX(+RXP,0)),"^",15):0,$P(^(0),"^",15)=11:0,$P(^(0),"^",15)=12:0,1:1) D STAT Q
  1.  S COPAYFLG=1,QDRUG=$P($G(^PSRX(RXP,0)),"^",6),QTY=$P($G(^(0)),"^",7) I $O(^PSRX(RXP,1,0)) G REF
  1.  I $O(^PSRX(RXP,"P",0)) D  Q:$D(DTOUT)!($D(DUOUT))
  1.  .S DIR(0)="SA^O:ORIGINAL;P:PARTIAL",DIR("B")="ORIGINAL",DIR("A",1)="",DIR("A",2)="There are Partials for this Rx.",DIR("A")="Which are you Returning To Stock? "
  1.  .S DIR("?")=" Press return for Original. Enter 'P' for Partial" D ^DIR K DIR
  1.  ;S XTYPE=$S(Y="O":"O",1:"P") G:Y="P" PAR
  1.  S XTYPE=$S(Y="P":"P",1:"O") G:Y="P" PAR ;RX REF IN ACT LOG DEF ORIG
  1.  I $P($G(^PSRX(RXP,2)),"^",15) W !,*7,*7,"Original fill for Rx # "_$P(^PSRX(RXP,0),"^")_" was RETURNED TO STOCK." Q
  1.  I '$P($G(^PSRX(RXP,2)),"^",13),$P($G(^(2)),"^",2)'<PSIN W !,*7,*7,"Rx # "_$P(^PSRX(RXP,0),"^")_" was NOT released !" Q
  1.  I $P($G(^PSRX(RXP,2)),"^",2)<PSIN D  Q
  1.  .W !!,*7,*7,"Original Fill CANNOT be Returned!",!,"This fill entered before installation of version 6.  There are no refills.",!
  1.  W ! S DIR("B")="Y",DIR("A")="Are you sure you want to RETURN TO STOCK Rx # "_$P(^PSRX(RXP,0),"^"),DIR(0)="YO" D ^DIR K DIR G:Y=0 EMQ G:$G(DIRUT) EMQ
  1.  ;ORI
  1.  I $P($G(^PSRX(RXP,2)),"^",2)'<PSIN D  D EX Q
  1.  .;I +$G(^PSRX(RXP,"IB")) D CP Q:'$G(COPAYFLG) ;IHS/DSD/ENM 03/06/97
  1.  .I $G(^PSDRUG(QDRUG,660.1)) S ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)+QTY
  1.  .D NOW^%DTC S DA=RXP,DIE="^PSRX(",DR="12COMMENTS;31///@;32.1///"_% L +^PSRX(DA):20 D ^DIE K DIE,DR L -^PSRX(DA) K DA Q:$D(Y)
  1.  .D ACT S DA=$O(^PS(52.5,"B",RXP,0)) I DA S DIK="^PS(52.5," D ^DIK
  1.  .W !,"Rx # "_$P(^PSRX(RXP,0),"^")_" RETURNED TO STOCK.",!
  1.  .D STOCK ;IHS/DSD/ENM/POC 01/28/98 ADDS A REFILL
  1.  .D  ;IHS/OKCAO/POC 8/18/2000
  1.  ..N APSQPST
  1.  ..S APSQPST=$$EN^APSQBRES(RXP,"","D")
  1.  .D PCC ;IHS/DSD/ENM 02/09/96
  1. REF I $O(^PSRX(RXP,1,0)),$O(^PSRX(RXP,"P",0)) D  Q:$D(DTOUT)!($D(DUOUT))  S XTYPE=$S(Y="R":1,1:"P")
  1.  .S DIR(0)="SA^R:REFILL;P:PARTIAL",DIR("B")="REFILL",DIR("A",1)="",DIR("A",2)="There are Refills and Paritals for this Rx.",DIR("A")="Which are you Returning To Stock? "
  1.  .S DIR("?")=" Press return for Refill. Enter 'P' for Partial" D ^DIR K DIR
  1. PAR S:$G(XTYPE)']"" XTYPE=1 S TYPE=0 F YY=0:0 S YY=$O(^PSRX(RXP,XTYPE,YY)) Q:'YY  S TYPE=YY
  1.  I 'TYPE D EX Q
  1.  I $P($G(^PSRX(RXP,XTYPE,TYPE,0)),"^",16) W *7,!!,"Last Fill Already Returned to Stock !",! D EX Q
  1.  I '$P(^PSRX(RXP,XTYPE,TYPE,0),"^",$S(XTYPE:18,1:19)),$P(^(0),"^")'<PSIN W !!,*7,*7,$S(XTYPE:"Refill",1:"PARTIAL")_" #"_TYPE_" was NOT released !",! Q
  1.  I '$P(^PSRX(RXP,XTYPE,TYPE,0),"^",$S(XTYPE:18,1:19)),$P(^(0),"^")<PSIN D  Q
  1.  .W !!,*7,*7,$S(XTYPE:"Refill",1:"PARTIAL")_" #"_TYPE_" CANNOT be Returned!",!,"This fill entered before installation of version 6.",!
  1.  W ! K DIR,DUOUT,DTOUT
  1.  S DIR("B")="Y",DIR("A",1)="Are you sure you want to RETURN TO STOCK",DIR("A")="Rx # "_$P(^PSRX(RXP,0),"^")_$S(XTYPE:" REFILL ",1:" PARTIAL ")_"# "_TYPE,DIR(0)="YO"
  1.  D ^DIR K DIR Q:'Y!($D(DUOUT))!($D(DTOUT))
  1.  D PCC ;IHS/DSD/ENM 12/26/95
  1.  ;I +$G(^PSRX(RXP,"IB")),XTYPE D CP Q:'$G(COPAYFLG)
  1.  D NOW^%DTC S QTY=$P(^PSRX(RXP,XTYPE,TYPE,0),"^",4) S:$G(^PSDRUG(QDRUG,660.1)) ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)+QTY
  1.  S DA(1)=RXP,DA=TYPE,DIE="^PSRX("_DA(1)_","_$S(XTYPE:1,1:"""P""")_",",DR=$S(XTYPE:"3COMMENTS;14////"_%_";17////@",1:".03COMMENTS;5////"_%_";8////@")
  1.  L +^PSRX(DA(1)):20 W ! D ^DIE L -^PSRX(DA(1)) G:$D(Y) EMQ D ACT
  1.  W !!,"Rx # "_$P(^PSRX(RXP,0),"^")_$S(XTYPE:" REFILL",1:" PARTIAL")_" #"_TYPE_" RETURNED TO STOCK" S DA=$O(^PS(52.5,"B",RXP,0)) I DA S DIK="^PS(52.5," D ^DIK
  1.  D STOCK ;IHS/DSD/ENM/POC 01/28/98 ADDS A REFILL
  1.  D  ;IHS/OKCAO/POC 8/18/2000 FOR BILLING
  1.  .N APSQPST
  1.  .S APSQPST=$$EN^APSQBRES(RXP,TYPE,"D")
  1.  Q
  1. EX K DA,DR,DIE,X,X1,X2,Y,RXP,REC,DIR,XDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,YY,QDRUG,QTY,TYPE,XTYPE,I,%,DIRUT,COPAYFLG,APSPQ,APSPX
  1.  ;K PS,PSIN,RXN,SEX,SSN,AGE,APSP,APSPD,APSPL,APSPLTYP,APSPMM,APSPRXX,APSPX9,APST,D,D0,DFN,DOB ;IHS/DSD/ENM 04/29/99
  1.  K PS,RXN,SEX,SSN,AGE,APSP,APSPD,APSPL,APSPLTYP,APSPMM,APSPRXX,APSPX9,APST,D,D0,DFN,DOB ;IHS/DSD/ENM 04/29/99;IHS/DSD/LWJ 09/03/99
  1.  Q
  1. HP ;W !!,"Wand the barcode number of the Rx or manually key in",!,"the number below the barcode or the Rx number."
  1.  ;W !,"The barcode number should be of the format - 'NNN-NNNNNNN'",!!,"Press 'ENTER' to process Rx or ""^"" to quit"
  1.  W !,"Enter the Rx number you would like to return to stock." ;IHS/DSD/ENM 5.18.95
  1.  Q
  1. BCI ;S RXP=0
  1. RXP ;S RXP=$O(^PSRX("B",X,RXP)) I $P($G(^PSRX(+RXP,0)),"^",15)=13 G RXP
  1.  S RXP=APSPX ;I $P($G(^PSRX(+RXP,0)),"^",15)=13 G RXP ;IHS/DSD/ENM 03/0697
  1.  Q
  1. STAT S RX0=^PSRX(RXP,0),RX2=^PSRX(RXP,2),J=RXP D ^PSOFUNC
  1.  W !!,*7,*7,"Rx has a status of "_ST_" and cannot be returned to stock.",!
  1.  K RX0,ST Q
  1. CP ;S PSOCPRX=$P(^PSRX(RXP,0),"^") S PSO=1,PSODA=RXP,PSOPAR7=$G(^PS(59,PSOSITE,"IB")) W !!,"ATTEMPTING TO REMOVE COPAY CHARGES",! D RXED^PSOCPA
  1.  ;I COPAYFLG=0 W !!,"REASON MUST BE ENTERED. Rx ",$P(^PSRX(RXP,0),"^")," NOT RETURNED TO STOCK.",!
  1.  Q
  1. ACT S IFN=0 F I=0:0 S I=$O(^PSRX(RXP,"A",I)) Q:'I  S IFN=I
  1.  D NOW^%DTC S IFN=IFN+1,^PSRX(RXP,"A",0)="^52.3DA^"_IFN_"^"_IFN,^PSRX(RXP,"A",IFN,0)=%_"^I^"_DUZ_"^"_$S(XTYPE="O":0,XTYPE:$G(TYPE),1:6)_"^ RETURNED TO STOCK"
  1.  K DA Q
  1. PCC ;Data link to IHS/PCC (cancel/reinstate) ;IHS/DSD/ENM 11/29/95
  1.  I $P(%APSITE,U,15)="Y" S APSRX=RXP,APSREA="C",APSPFROM="R" D ^APSPCCC ;IHS/DSD/ENM 02/09/96
  1.  Q
  1. STOCK ;ADD ONE BACK TO STOCK ;IHS/DSD/ENM/POC
  1.  S $P(^PSRX(RXP,0),"^",9)=$P(^PSRX(RXP,0),"^",9)+1
  1.  K PSOSD ;NODE REMOVED SO THAT RX PROFILE WILL BE REBUILD
  1.  Q