- PSORXED1 ;BHAM ISC/SAB - Edit prescription utility #2 ;29-May-2012 15:12;PLS
- ;;7.0;OUTPATIENT PHARMACY;**2,16,21,1002,289,1015**;DEC 1997;Build 62
- ;show edits on last refill
- ; Modified - IHS/CIA/PLS - 12/21/03 - PSORXED1+6
- ; IHS/CIA/PLS - 01/26/04 - Added set for RX19999999 node
- ; IHS/CIA/PLS - 12/13/04 - Line APCOM+17
- ;F ZDL=0:0 S ZDL=$O(^PSRX(DA,1,ZDL)) Q:'ZDL S:$P($G(^PSRX(DA,1,ZDL,0)),"^") ZD(DA)=$P($G(^PSRX(DA,1,ZDL,0)),"^")
- F ZDL=0:0 S ZDL=$O(^PSRX(DA,1,ZDL)) Q:'ZDL S:$P($G(^PSRX(DA,1,ZDL,0)),"^") ZD(DA)=$P($G(^PSRX(DA,1,ZDL,0)),"^") S PSORXED("RX19999999")=$G(^(9999999))
- G:'$O(^PSRX(DA,1,0))!($G(^PSRX(DA,1,RFED,0))']"") SUS S (PSRX1,RX1)=PSORXED("RX1"),QTY=$P(RX1,"^",4),QTY=QTY-$P(^PSRX(DA,1,RFED,0),"^",4)
- ;S COM1="" F I=1:1:6,9:1:11,17 I $P(PSRX1,"^",I)'=$P(^PSRX(DA,1,RFED,0),"^",I) D
- ;.S PSI=$S(I=1:.01,I=4:1,I=5:4,I=6:5,I=9:8,I=10:1.1,I=11:1.2,I=17:15,1:I),COM1=COM1_$P(^DD(52.1,PSI,0),"^")_" ("_$P(PSRX1,"^",I)_"),"
- ; IHS/CIA/PLS - 12/21/03 - Need NDC for refill
- S COM1="" F I=1:1:6,9:1:11,13,17 I $P(PSRX1,"^",I)'=$P(^PSRX(DA,1,RFED,0),"^",I) D
- .S PSI=$S(I=1:.01,I=4:1,I=5:4,I=6:5,I=9:8,I=10:1.1,I=11:1.2,I=13:17,I=17:15,1:I),COM1=COM1_$P(^DD(52.1,PSI,0),"^")_" ("_$P(PSRX1,"^",I)_"),"
- ; IHS/CIA/PLS - 12/21/03 - Need AWP on refill
- I $P(PSORXED("RX19999999"),U,6)'=$P($G(^PSRX(DA,1,RFD,9999999)),U,6) D
- .S COM1=COM1_$P(^DD(52.1,9999999.06,0),U)_" ("_$P(PSORXED("RX19999999"),U,6)_"),"
- ; IHS/CIA/PLS - 12/21/03 - Guarantee printing and billing of refill note in OVERRIDE^APSQBRES
- S:$G(APSQCOMR)]"" COM1=COM1_APSQCOMR K APSQCOMR
- N PSOTRIC,PSOECMES,PSOERFL S (PSOTRIC,PSOERFL,PSOECMES)="",PSOERFL=$$LSTRFL^PSOBPSU1(DA),PSOECMES=$$FIND^PSOREJUT(DA,PSOERFL)
- S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(DA,PSOERFL,.PSOTRIC)
- I COM1=""&('$G(PSOTRIC)) K COM1 G SUS
- I COM1=""&($G(PSOTRIC)) G:'PSOECMES SKPTRIC I PSOECMES K COM1 G SUS
- ;
- S K=1,D1=0 F Z=0:0 S Z=$O(^PSRX(DA,"A",Z)) Q:'Z S D1=Z,K=K+1
- S D1=D1+1 S:'($D(^PSRX(DA,"A",0))#2) ^(0)="^52.3DA^^^" S ^(0)=$P(^(0),"^",1,2)_"^"_D1_"^"_K
- S ^PSRX(DA,"A",D1,0)=DT_"^E^"_DUZ_"^"_$S(RFED'<0&(RFED<6):RFED,1:(RFED+1))_"^"_COM1
- SKPTRIC ;
- I QTY,$P(^PSRX(DA,1,RFED,0),"^",18) S ^PSDRUG($P(^PSRX(DA,0),"^",6),660.1)=$S($D(^PSDRUG(+$P(^PSRX(DA,0),"^",6),660.1)):^(660.1)+QTY,1:QTY)
- G:RFD'=RFED EX
- D FILL^PSORXED S PSOEDITL=$S($G(PSOEDITF)'=$G(RFED):1,$G(PSOEDITF)=$G(RFED)&('$G(PSOEDITR)):0,1:2)
- I $G(PSOTRIC)&(PSOECMES) S PSOEDITL=0 G SUS
- I $G(PSOEDITL)=2,'$G(RXRP(DA)),$P($G(^PSRX(DA,"STA")),"^")'=5,'$G(PSOSIGFL) D ASKL^PSORXED
- G:+$P(^PSRX(DA,"STA"),"^")!($G(PSOEDITL)=1&('$G(PSOTRIC))) SUS I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=PSORXED("IRXN")_"," S RXFL(DA)=RFED D SETRP^PSORXED G SUS
- F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1
- I $L(PSORX("PSOL",PSOX2))+$L(PSORXED("IRXN"))<220 D G ELSE
- .I PSORX("PSOL",PSOX2)'[PSORXED("IRXN")_"," S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSORXED("IRXN")_"," D SETRP^PSORXED
- E I PSORX("PSOL",PSOX2)'[PSORXED("IRXN")_"," S PSORX("PSOL",PSOX2+1)=PSORXED("IRXN")_"," D SETRP^PSORXED
- ELSE S RXFL(DA)=RFED
- K COM1
- SUS ;update suspense file
- K PSOEDITF,PSOEDITR,PSOEDITL
- S RXS=$O(^PS(52.5,"B",DA,0)) I RXS,$G(^PS(52.5,RXS,"P"))=1 S ZD=$P(^PSRX(DA,3),"^") Q
- G:'RXS EX
- N PSOSITE I RFDT,$G(^PSRX(DA,1,RFED,0))]"",RFDT'=+$G(^PSRX(DA,1,RFED,0))!($P(PSORXED("RX1"),"^",9)'=$P(^(0),"^",9)) S SD=$P(^PSRX(DA,1,RFED,0),"^"),PSOSITE=$P(^(0),"^",9) D SUP Q
- I 'RFED,$P(PSORXED("RX2"),"^",2)'=$P(^PSRX(DA,2),"^",2)!($P(PSORXED("RX2"),"^",9)'=$P(^(2),"^",9)) S SD=$P(^PSRX(DA,2),"^",2),PSOSITE=$P(^(2),"^",9) D SUP
- EX K COM1,DIK,K,PSORXED("RX1"),RX1,RXS,SD,IR,FDA,RXN,RFDT,COPIES,J,PSPOP,COM,RX0,RX2,D1,IOP,%,%Y,D0,DA,D1
- K DIC,DIE,DIG,DQ,DR,DRUG,I,II,N,PHYS,PS,QTY,RFDATE,RFL,RFL1,RXF,SIG,ST,ST0,Z,Z0,Z1,X,Y,ZDL
- Q
- SUP I $P($G(^PS(52.5,RXS,0)),"^",7)="Q" D SUS^PSOCMOPB Q
- S RXN=DA,RX0=^PSRX(DA,0),DA=RXS,DIK="^PS(52.5," D ^DIK S DA=RXN
- S DIC="^PS(52.5,",DIC(0)="L",X=RXN,DLAYGO=52.5
- S DIC("DR")=".02///"_SD_";.03////"_$P(^PSRX(DA,0),"^",2)_";.04///M;.05///0;.06////"_PSOSITE_";2///0" K DD,DO D FILE^DICN I +$G(Y),$G(RFED)'="" S $P(^PS(52.5,+Y,0),"^",13)=$G(RFED)
- S IR=0,DA=RXN F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA S IR=FDA
- S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
- D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^E^"_DUZ_"^"_$S(RFED'<0&(RFED<6):RFED,1:(RFED+1))_"^RX Placed on Suspense until "_$E(SD,4,5)_"-"_$E(SD,6,7)_"-"_$E(SD,2,3)
- W !,"RX# "_$P(RX0,"^")_" has been Suspended until "_$E(SD,4,5)_"-"_$E(SD,6,7)_"-"_$E(SD,2,3)_".",!
- Q
- ;
- DIE W !,"Now Editing Rx # ",$P(PSORXED("RX0"),"^") K DIE,DA,DIC,DR S DIE="^PSRX(",DA=PSORXED("IRXN")
- ; IHS/CIA/PLS - 12/21/03 - Adjust field list for edit
- ;S DR="1;22R;3;Q;4;5"_$S($P(PSOPAR,"^",3):";6",1:"")_";6.5:8;Q;17;9:10;10.6;11;"_$S($P(PSOPAR,"^",12):"35;",1:"")_"12;20" S:RFD DR=DR_";52" S DR=DR_";23;24",DR(2,52.1)=".01:5;8;15"
- S DR="1;22R;"_$S('$G(RFD):"3;",1:"")_"Q;4;5"_$S($P(PSOPAR,"^",3):";6",1:"")_";6.5:8;Q;17;9:10;10.6;11;"_$S($P(PSOPAR,"^",12):"35;",1:"")_"12;20;9999999.02" S DR=DR_";23"
- S DR(2,52.1)="I +D'=$G(APSREFD) S Y=0 W ""ONLY THE LAST REFILL CAN BE EDITED"";1:4;8;15"
- S DR=DR_";27;S APSAZNDC=X;W !,""DELETE AWP FIELD TO RECALCUATE"";9999999.06//^S X=$$AWP^APSQDAWP($G(APSAZNDC),APSAZIEN,.MESS);I X="""" S Y=9999999.06;W !,$G(MESS) K MESS;9999999.07"
- S DR(2,52.1)=DR(2,52.1)_";11;S APSARNDC=X;W !,""DELETE REFILL AWP FIELD TO RECALCULATE"";9999999.06//^S X=$$AWP^APSQDAWP($G(APSARNDC),APSAZIEN,.MESS);I X="""" S Y=9999999.06;W !,$G(MESS) K MESS;9999999.07"
- S (APSREFF,APSREFD,I)=0 F S I=$O(^PSRX(PSORXED("IRXN"),1,I)) Q:'+I S APSREFF=APSREFF+1
- S:APSREFF APSREFD=+(^PSRX(PSORXED("IRXN"),1,APSREFF,0))
- I APSPMAN=1&(RFD) S DR(2,52.1)=DR(2,52.1)_";5;12;13"
- I APSPMAN=2&(RFD) S DR(2,52.1)=DR(2,52.1)_";13"
- I APSPMAN=1&'$G(RFD) S DR=DR_";24;28;29"
- I APSPMAN=2&'$G(RFD) S DR=DR_";29"
- S:RFD DR=DR_";52" ; Refill prompt last
- S PSOBXIEN=$P($G(^PSRX(PSORXED("IRXN"),9999999)),"^",12) ;Insurer field of Rx
- S:RFD PSOBRIEN=$P($G(^PSRX(PSORXED("IRXN"),1,RFD,9999999)),"^",12) ; Insurer of last refill
- S:'RFD DR=DR_";W !,""DO YOU WANT TO EDIT RX INSURER INFO"" S %=2 D YN^DICN S:%'=1 Y=0;9999999.12///^S X=$$OVERRIDE^APSQBRES(PSOBXIEN)" ;If no refill
- S:RFD DR(2,52.1)=DR(2,52.1)_";W !,""DO YOU WANT TO EDIT REFILL INSURER INFO"" S %=2 D YN^DICN S:%'=1 Y=0;9999999.12///^S X=$$OVERRIDE^APSQBRES(PSOBRIEN)" ;If refill exists
- ; IHS/CIA/PLS - 12/21/03 - End of Changes
- D ^DIE K DIE,DR,DA,X,Y L -^PSRX(PSORXED("IRXN")) I RFD,$G(^PSRX(PSORXED("IRXN"),1,RFD,0))]"" D
- .S:$P(PSORXED("RX1"),"^",17)'=$P(^PSRX(PSORXED("IRXN"),1,RFD,0),"^",17) PSONEW("PROVIDER NAME")=$P(^VA(200,$P(^PSRX(PSORXED("IRXN"),1,RFD,0),"^",17),0),"^")
- ; IHS/CIA/PLS - 12/21/03 - Begin modifications
- APCOM ;
- S COM=""
- I APSPMAN=""!(APSPMAN=3) S PSONEW("EXPIRATION DATE")="",PSONEW("MANUFACTURER")="",PSONEW("LOT #")=""
- ; Setup COM variable for MFG data
- I APSPMAN=1&'$G(RFD) S APSP91=^PSRX(PSORXED("IRXN"),2),PSONEW("EXPIRATION DATE")=$P($G(APSP91),"^",11),PSONEW("MANUFACTURER")=$P($G(APSP91),"^",8),PSONEW("LOT #")=$P($G(APSP91),"^",4) D
- .I PSONEW("EXPIRATION DATE")'=$P($G(PSORXED("RX2")),"^",11) S COM=COM_$P(^DD(52,29,0),"^")_" ("_PSONEW("EXPIRATION DATE")_"),"
- .I PSONEW("MANUFACTURER")'=$P($G(PSORXED("RX2")),"^",8) S COM=COM_$P(^DD(52,28,0),"^")_" ("_PSONEW("MANUFACTURER")_"),"
- .I PSONEW("LOT #")'=$P($G(PSORXED("RX2")),"^",4) S COM=COM_$P(^DD(52,24,0),"^")_" ("_PSONEW("LOT #")_"),"
- I APSPMAN=2&'$G(RFD) S APSP91=^PSRX(PSORXED("IRXN"),2),PSONEW("EXPIRATION DATE")=$P($G(APSP91),"^",11)
- ; Setup COM variable for refill MFG data
- I APSPMAN=1&(RFD) S APSP92=$G(^PSRX(PSORXED("IRXN"),1,RFD,0)),APSP44("EXP DATE")=$P($G(APSP92),"^",15),APSP44("MFG")=$P($G(APSP92),"^",14),APSP44("LOT #")=$P($G(APSP92),"^",6) D
- .S PSONEW("EXPIRATION DATE")=APSP44("EXP DATE"),PSONEW("MANUFACTURER")=APSP44("MFG"),PSONEW("LOT #")=APSP44("LOT #")
- .I APSP44("EXP DATE")'=$P($G(PSORXED("RX1")),"^",15) S COM=COM_$P(^DD(52.1,13,0),"^")_" ("_APSP44("EXP DATE")_"),"
- .I APSP44("MFG")'=$P($G(PSORXED("RX1")),"^",14) S COM=COM_$P(^DD(52.1,12,0),"^")_" ("_APSP44("MFG")_"),"
- .I APSP44("LOT #")'=$P($G(PSORXED("RX1")),"^",6) S COM=COM_$P(^DD(52.1,5,0),"^")_" ("_APSP44("LOT #")_"),"
- I APSPMAN=2&(RFD) S APSP92=$G(^PSRX(PSORXED("IRXN"),1,RFD,0)),APSP44("EXP DATE")=$P($G(APSP92),"^",15),PSONEW("EXPIRATION DATE")=APSP44("EXP DATE") D
- .I APSP44("EXP DATE")'=$P($G(PSORXED("RX1")),"^",15) S COM=COM_$P(^DD(52.1,13,0),"^")_" ("_APSP44("EXP DATE")_"),"
- ;S:$G(APSPCP) PSORXED("CM")=$$GET1^DIQ(52,PSORXED("IRXN"),9999999.02)
- S:$G(APSPCP) PSORXED("CM")=$$GET1^DIQ(52,PSORXED("IRXN"),9999999.02,"I") ; CIA/IHS/PLS - 12/13/04 - Added internal flag
- S PSORXED("NDC")=$P($G(^PSRX(PSORXED("IRXN"),2)),"^",7),PSORXED("AWP")=$P($G(^(9999999)),"^",6) ; Data displayed at line EN1^PSONEW2
- I $G(RFD) S PSORXED("NDC")=$P($G(^PSRX(PSORXED("IRXN"),1,RFD,0)),"^",13),PSORXED("AWP")=$P($G(^PSRX(PSORXED("IRXN"),1,RFD,9999999)),"^",6) ; Data displayed at line EN1^PSONEW2
- D EN1^PSONEW2(.PSORXED) I PSORXED("DFLG") S PSORXED("QFLG")=1 G DIEX
- G:'PSORXED("QFLG") DIE S PSORXED("QFLG")=0
- DIEX Q
- PSORXED1 ;BHAM ISC/SAB - Edit prescription utility #2 ;29-May-2012 15:12;PLS
- +1 ;;7.0;OUTPATIENT PHARMACY;**2,16,21,1002,289,1015**;DEC 1997;Build 62
- +2 ;show edits on last refill
- +3 ; Modified - IHS/CIA/PLS - 12/21/03 - PSORXED1+6
- +4 ; IHS/CIA/PLS - 01/26/04 - Added set for RX19999999 node
- +5 ; IHS/CIA/PLS - 12/13/04 - Line APCOM+17
- +6 ;F ZDL=0:0 S ZDL=$O(^PSRX(DA,1,ZDL)) Q:'ZDL S:$P($G(^PSRX(DA,1,ZDL,0)),"^") ZD(DA)=$P($G(^PSRX(DA,1,ZDL,0)),"^")
- +7 FOR ZDL=0:0
- SET ZDL=$ORDER(^PSRX(DA,1,ZDL))
- IF 'ZDL
- QUIT
- IF $PIECE($GET(^PSRX(DA,1,ZDL,0)),"^")
- SET ZD(DA)=$PIECE($GET(^PSRX(DA,1,ZDL,0)),"^")
- SET PSORXED("RX19999999")=$GET(^(9999999))
- +8 IF '$ORDER(^PSRX(DA,1,0))!($GET(^PSRX(DA,1,RFED,0))']"")
- GOTO SUS
- SET (PSRX1,RX1)=PSORXED("RX1")
- SET QTY=$PIECE(RX1,"^",4)
- SET QTY=QTY-$PIECE(^PSRX(DA,1,RFED,0),"^",4)
- +9 ;S COM1="" F I=1:1:6,9:1:11,17 I $P(PSRX1,"^",I)'=$P(^PSRX(DA,1,RFED,0),"^",I) D
- +10 ;.S PSI=$S(I=1:.01,I=4:1,I=5:4,I=6:5,I=9:8,I=10:1.1,I=11:1.2,I=17:15,1:I),COM1=COM1_$P(^DD(52.1,PSI,0),"^")_" ("_$P(PSRX1,"^",I)_"),"
- +11 ; IHS/CIA/PLS - 12/21/03 - Need NDC for refill
- +12 SET COM1=""
- FOR I=1:1:6,9:1:11,13,17
- IF $PIECE(PSRX1,"^",I)'=$PIECE(^PSRX(DA,1,RFED,0),"^",I)
- Begin DoDot:1
- +13 SET PSI=$SELECT(I=1:.01,I=4:1,I=5:4,I=6:5,I=9:8,I=10:1.1,I=11:1.2,I=13:17,I=17:15,1:I)
- SET COM1=COM1_$PIECE(^DD(52.1,PSI,0),"^")_" ("_$PIECE(PSRX1,"^",I)_"),"
- End DoDot:1
- +14 ; IHS/CIA/PLS - 12/21/03 - Need AWP on refill
- +15 IF $PIECE(PSORXED("RX19999999"),U,6)'=$PIECE($GET(^PSRX(DA,1,RFD,9999999)),U,6)
- Begin DoDot:1
- +16 SET COM1=COM1_$PIECE(^DD(52.1,9999999.06,0),U)_" ("_$PIECE(PSORXED("RX19999999"),U,6)_"),"
- End DoDot:1
- +17 ; IHS/CIA/PLS - 12/21/03 - Guarantee printing and billing of refill note in OVERRIDE^APSQBRES
- +18 IF $GET(APSQCOMR)]""
- SET COM1=COM1_APSQCOMR
- KILL APSQCOMR
- +19 NEW PSOTRIC,PSOECMES,PSOERFL
- SET (PSOTRIC,PSOERFL,PSOECMES)=""
- SET PSOERFL=$$LSTRFL^PSOBPSU1(DA)
- SET PSOECMES=$$FIND^PSOREJUT(DA,PSOERFL)
- +20 SET PSOTRIC=""
- SET PSOTRIC=$$TRIC^PSOREJP1(DA,PSOERFL,.PSOTRIC)
- +21 IF COM1=""&('$GET(PSOTRIC))
- KILL COM1
- GOTO SUS
- +22 IF COM1=""&($GET(PSOTRIC))
- IF 'PSOECMES
- GOTO SKPTRIC
- IF PSOECMES
- KILL COM1
- GOTO SUS
- +23 ;
- +24 SET K=1
- SET D1=0
- FOR Z=0:0
- SET Z=$ORDER(^PSRX(DA,"A",Z))
- IF 'Z
- QUIT
- SET D1=Z
- SET K=K+1
- +25 SET D1=D1+1
- IF '($DATA(^PSRX(DA,"A",0))#2)
- SET ^(0)="^52.3DA^^^"
- SET ^(0)=$PIECE(^(0),"^",1,2)_"^"_D1_"^"_K
- +26 SET ^PSRX(DA,"A",D1,0)=DT_"^E^"_DUZ_"^"_$SELECT(RFED'<0&(RFED<6):RFED,1:(RFED+1))_"^"_COM1
- SKPTRIC ;
- +1 IF QTY
- IF $PIECE(^PSRX(DA,1,RFED,0),"^",18)
- SET ^PSDRUG($PIECE(^PSRX(DA,0),"^",6),660.1)=$SELECT($DATA(^PSDRUG(+$PIECE(^PSRX(DA,0),"^",6),660.1)):^(660.1)+QTY,1:QTY)
- +2 IF RFD'=RFED
- GOTO EX
- +3 DO FILL^PSORXED
- SET PSOEDITL=$SELECT($GET(PSOEDITF)'=$GET(RFED):1,$GET(PSOEDITF)=$GET(RFED)&('$GET(PSOEDITR)):0,1:2)
- +4 IF $GET(PSOTRIC)&(PSOECMES)
- SET PSOEDITL=0
- GOTO SUS
- +5 IF $GET(PSOEDITL)=2
- IF '$GET(RXRP(DA))
- IF $PIECE($GET(^PSRX(DA,"STA")),"^")'=5
- IF '$GET(PSOSIGFL)
- DO ASKL^PSORXED
- +6 IF +$PIECE(^PSRX(DA,"STA"),"^")!($GET(PSOEDITL)=1&('$GET(PSOTRIC)))
- GOTO SUS
- IF $GET(PSORX("PSOL",1))']""
- SET PSORX("PSOL",1)=PSORXED("IRXN")_","
- SET RXFL(DA)=RFED
- DO SETRP^PSORXED
- GOTO SUS
- +7 FOR PSOX1=0:0
- SET PSOX1=$ORDER(PSORX("PSOL",PSOX1))
- IF 'PSOX1
- QUIT
- SET PSOX2=PSOX1
- +8 IF $LENGTH(PSORX("PSOL",PSOX2))+$LENGTH(PSORXED("IRXN"))<220
- Begin DoDot:1
- +9 IF PSORX("PSOL",PSOX2)'[PSORXED("IRXN")_","
- SET PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSORXED("IRXN")_","
- DO SETRP^PSORXED
- End DoDot:1
- GOTO ELSE
- +10 IF '$TEST
- IF PSORX("PSOL",PSOX2)'[PSORXED("IRXN")_","
- SET PSORX("PSOL",PSOX2+1)=PSORXED("IRXN")_","
- DO SETRP^PSORXED
- ELSE SET RXFL(DA)=RFED
- +1 KILL COM1
- SUS ;update suspense file
- +1 KILL PSOEDITF,PSOEDITR,PSOEDITL
- +2 SET RXS=$ORDER(^PS(52.5,"B",DA,0))
- IF RXS
- IF $GET(^PS(52.5,RXS,"P"))=1
- SET ZD=$PIECE(^PSRX(DA,3),"^")
- QUIT
- +3 IF 'RXS
- GOTO EX
- +4 NEW PSOSITE
- IF RFDT
- IF $GET(^PSRX(DA,1,RFED,0))]""
- IF RFDT'=+$GET(^PSRX(DA,1,RFED,0))!($PIECE(PSORXED("RX1"),"^",9)'=$PIECE(^(0),"^",9))
- SET SD=$PIECE(^PSRX(DA,1,RFED,0),"^")
- SET PSOSITE=$PIECE(^(0),"^",9)
- DO SUP
- QUIT
- +5 IF 'RFED
- IF $PIECE(PSORXED("RX2"),"^",2)'=$PIECE(^PSRX(DA,2),"^",2)!($PIECE(PSORXED("RX2"),"^",9)'=$PIECE(^(2),"^",9))
- SET SD=$PIECE(^PSRX(DA,2),"^",2)
- SET PSOSITE=$PIECE(^(2),"^",9)
- DO SUP
- EX KILL COM1,DIK,K,PSORXED("RX1"),RX1,RXS,SD,IR,FDA,RXN,RFDT,COPIES,J,PSPOP,COM,RX0,RX2,D1,IOP,%,%Y,D0,DA,D1
- +1 KILL DIC,DIE,DIG,DQ,DR,DRUG,I,II,N,PHYS,PS,QTY,RFDATE,RFL,RFL1,RXF,SIG,ST,ST0,Z,Z0,Z1,X,Y,ZDL
- +2 QUIT
- SUP IF $PIECE($GET(^PS(52.5,RXS,0)),"^",7)="Q"
- DO SUS^PSOCMOPB
- QUIT
- +1 SET RXN=DA
- SET RX0=^PSRX(DA,0)
- SET DA=RXS
- SET DIK="^PS(52.5,"
- DO ^DIK
- SET DA=RXN
- +2 SET DIC="^PS(52.5,"
- SET DIC(0)="L"
- SET X=RXN
- SET DLAYGO=52.5
- +3 SET DIC("DR")=".02///"_SD_";.03////"_$PIECE(^PSRX(DA,0),"^",2)_";.04///M;.05///0;.06////"_PSOSITE_";2///0"
- KILL DD,DO
- DO FILE^DICN
- IF +$GET(Y)
- IF $GET(RFED)'=""
- SET $PIECE(^PS(52.5,+Y,0),"^",13)=$GET(RFED)
- +4 SET IR=0
- SET DA=RXN
- FOR FDA=0:0
- SET FDA=$ORDER(^PSRX(DA,"A",FDA))
- IF 'FDA
- QUIT
- SET IR=FDA
- +5 SET IR=IR+1
- SET ^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
- +6 DO NOW^%DTC
- SET ^PSRX(DA,"A",IR,0)=%_"^E^"_DUZ_"^"_$SELECT(RFED'<0&(RFED<6):RFED,1:(RFED+1))_"^RX Placed on Suspense until "_$EXTRACT(SD,4,5)_"-"_$EXTRACT(SD,6,7)_"-"_$EXTRACT(SD,2,3)
- +7 WRITE !,"RX# "_$PIECE(RX0,"^")_" has been Suspended until "_$EXTRACT(SD,4,5)_"-"_$EXTRACT(SD,6,7)_"-"_$EXTRACT(SD,2,3)_".",!
- +8 QUIT
- +9 ;
- DIE WRITE !,"Now Editing Rx # ",$PIECE(PSORXED("RX0"),"^")
- KILL DIE,DA,DIC,DR
- SET DIE="^PSRX("
- SET DA=PSORXED("IRXN")
- +1 ; IHS/CIA/PLS - 12/21/03 - Adjust field list for edit
- +2 ;S DR="1;22R;3;Q;4;5"_$S($P(PSOPAR,"^",3):";6",1:"")_";6.5:8;Q;17;9:10;10.6;11;"_$S($P(PSOPAR,"^",12):"35;",1:"")_"12;20" S:RFD DR=DR_";52" S DR=DR_";23;24",DR(2,52.1)=".01:5;8;15"
- +3 SET DR="1;22R;"_$SELECT('$GET(RFD):"3;",1:"")_"Q;4;5"_$SELECT($PIECE(PSOPAR,"^",3):";6",1:"")_";6.5:8;Q;17;9:10;10.6;11;"_$SELECT($PIECE(PSOPAR,"^",12):"35;",1:"")_"12;20;9999999.02"
- SET DR=DR_";23"
- +4 SET DR(2,52.1)="I +D'=$G(APSREFD) S Y=0 W ""ONLY THE LAST REFILL CAN BE EDITED"";1:4;8;15"
- +5 SET DR=DR_";27;S APSAZNDC=X;W !,""DELETE AWP FIELD TO RECALCUATE"";9999999.06//^S X=$$AWP^APSQDAWP($G(APSAZNDC),APSAZIEN,.MESS);I X="""" S Y=9999999.06;W !,$G(MESS) K MESS;9999999.07"
- +6 SET DR(2,52.1)=DR(2,52.1)_";11;S APSARNDC=X;W !,""DELETE REFILL AWP FIELD TO RECALCULATE"";9999999.06//^S X=$$AWP^APSQDAWP($G(APSARNDC),APSAZIEN,.MESS);I X="""" S Y=9999999.06;W !,$G(MESS) K MESS;9999999.07"
- +7 SET (APSREFF,APSREFD,I)=0
- FOR
- SET I=$ORDER(^PSRX(PSORXED("IRXN"),1,I))
- IF '+I
- QUIT
- SET APSREFF=APSREFF+1
- +8 IF APSREFF
- SET APSREFD=+(^PSRX(PSORXED("IRXN"),1,APSREFF,0))
- +9 IF APSPMAN=1&(RFD)
- SET DR(2,52.1)=DR(2,52.1)_";5;12;13"
- +10 IF APSPMAN=2&(RFD)
- SET DR(2,52.1)=DR(2,52.1)_";13"
- +11 IF APSPMAN=1&'$GET(RFD)
- SET DR=DR_";24;28;29"
- +12 IF APSPMAN=2&'$GET(RFD)
- SET DR=DR_";29"
- +13 ; Refill prompt last
- IF RFD
- SET DR=DR_";52"
- +14 ;Insurer field of Rx
- SET PSOBXIEN=$PIECE($GET(^PSRX(PSORXED("IRXN"),9999999)),"^",12)
- +15 ; Insurer of last refill
- IF RFD
- SET PSOBRIEN=$PIECE($GET(^PSRX(PSORXED("IRXN"),1,RFD,9999999)),"^",12)
- +16 ;If no refill
- IF 'RFD
- SET DR=DR_";W !,""DO YOU WANT TO EDIT RX INSURER INFO"" S %=2 D YN^DICN S:%'=1 Y=0;9999999.12///^S X=$$OVERRIDE^APSQBRES(PSOBXIEN)"
- +17 ;If refill exists
- IF RFD
- SET DR(2,52.1)=DR(2,52.1)_";W !,""DO YOU WANT TO EDIT REFILL INSURER INFO"" S %=2 D YN^DICN S:%'=1 Y=0;9999999.12///^S X=$$OVERRIDE^APSQBRES(PSOBRIEN)"
- +18 ; IHS/CIA/PLS - 12/21/03 - End of Changes
- +19 DO ^DIE
- KILL DIE,DR,DA,X,Y
- LOCK -^PSRX(PSORXED("IRXN"))
- IF RFD
- IF $GET(^PSRX(PSORXED("IRXN"),1,RFD,0))]""
- Begin DoDot:1
- +20 IF $PIECE(PSORXED("RX1"),"^",17)'=$PIECE(^PSRX(PSORXED("IRXN"),1,RFD,0),"^",17)
- SET PSONEW("PROVIDER NAME")=$PIECE(^VA(200,$PIECE(^PSRX(PSORXED("IRXN"),1,RFD,0),"^",17),0),"^")
- End DoDot:1
- +21 ; IHS/CIA/PLS - 12/21/03 - Begin modifications
- APCOM ;
- +1 SET COM=""
- +2 IF APSPMAN=""!(APSPMAN=3)
- SET PSONEW("EXPIRATION DATE")=""
- SET PSONEW("MANUFACTURER")=""
- SET PSONEW("LOT #")=""
- +3 ; Setup COM variable for MFG data
- +4 IF APSPMAN=1&'$GET(RFD)
- SET APSP91=^PSRX(PSORXED("IRXN"),2)
- SET PSONEW("EXPIRATION DATE")=$PIECE($GET(APSP91),"^",11)
- SET PSONEW("MANUFACTURER")=$PIECE($GET(APSP91),"^",8)
- SET PSONEW("LOT #")=$PIECE($GET(APSP91),"^",4)
- Begin DoDot:1
- +5 IF PSONEW("EXPIRATION DATE")'=$PIECE($GET(PSORXED("RX2")),"^",11)
- SET COM=COM_$PIECE(^DD(52,29,0),"^")_" ("_PSONEW("EXPIRATION DATE")_"),"
- +6 IF PSONEW("MANUFACTURER")'=$PIECE($GET(PSORXED("RX2")),"^",8)
- SET COM=COM_$PIECE(^DD(52,28,0),"^")_" ("_PSONEW("MANUFACTURER")_"),"
- +7 IF PSONEW("LOT #")'=$PIECE($GET(PSORXED("RX2")),"^",4)
- SET COM=COM_$PIECE(^DD(52,24,0),"^")_" ("_PSONEW("LOT #")_"),"
- End DoDot:1
- +8 IF APSPMAN=2&'$GET(RFD)
- SET APSP91=^PSRX(PSORXED("IRXN"),2)
- SET PSONEW("EXPIRATION DATE")=$PIECE($GET(APSP91),"^",11)
- +9 ; Setup COM variable for refill MFG data
- +10 IF APSPMAN=1&(RFD)
- SET APSP92=$GET(^PSRX(PSORXED("IRXN"),1,RFD,0))
- SET APSP44("EXP DATE")=$PIECE($GET(APSP92),"^",15)
- SET APSP44("MFG")=$PIECE($GET(APSP92),"^",14)
- SET APSP44("LOT #")=$PIECE($GET(APSP92),"^",6)
- Begin DoDot:1
- +11 SET PSONEW("EXPIRATION DATE")=APSP44("EXP DATE")
- SET PSONEW("MANUFACTURER")=APSP44("MFG")
- SET PSONEW("LOT #")=APSP44("LOT #")
- +12 IF APSP44("EXP DATE")'=$PIECE($GET(PSORXED("RX1")),"^",15)
- SET COM=COM_$PIECE(^DD(52.1,13,0),"^")_" ("_APSP44("EXP DATE")_"),"
- +13 IF APSP44("MFG")'=$PIECE($GET(PSORXED("RX1")),"^",14)
- SET COM=COM_$PIECE(^DD(52.1,12,0),"^")_" ("_APSP44("MFG")_"),"
- +14 IF APSP44("LOT #")'=$PIECE($GET(PSORXED("RX1")),"^",6)
- SET COM=COM_$PIECE(^DD(52.1,5,0),"^")_" ("_APSP44("LOT #")_"),"
- End DoDot:1
- +15 IF APSPMAN=2&(RFD)
- SET APSP92=$GET(^PSRX(PSORXED("IRXN"),1,RFD,0))
- SET APSP44("EXP DATE")=$PIECE($GET(APSP92),"^",15)
- SET PSONEW("EXPIRATION DATE")=APSP44("EXP DATE")
- Begin DoDot:1
- +16 IF APSP44("EXP DATE")'=$PIECE($GET(PSORXED("RX1")),"^",15)
- SET COM=COM_$PIECE(^DD(52.1,13,0),"^")_" ("_APSP44("EXP DATE")_"),"
- End DoDot:1
- +17 ;S:$G(APSPCP) PSORXED("CM")=$$GET1^DIQ(52,PSORXED("IRXN"),9999999.02)
- +18 ; CIA/IHS/PLS - 12/13/04 - Added internal flag
- IF $GET(APSPCP)
- SET PSORXED("CM")=$$GET1^DIQ(52,PSORXED("IRXN"),9999999.02,"I")
- +19 ; Data displayed at line EN1^PSONEW2
- SET PSORXED("NDC")=$PIECE($GET(^PSRX(PSORXED("IRXN"),2)),"^",7)
- SET PSORXED("AWP")=$PIECE($GET(^(9999999)),"^",6)
- +20 ; Data displayed at line EN1^PSONEW2
- IF $GET(RFD)
- SET PSORXED("NDC")=$PIECE($GET(^PSRX(PSORXED("IRXN"),1,RFD,0)),"^",13)
- SET PSORXED("AWP")=$PIECE($GET(^PSRX(PSORXED("IRXN"),1,RFD,9999999)),"^",6)
- +21 DO EN1^PSONEW2(.PSORXED)
- IF PSORXED("DFLG")
- SET PSORXED("QFLG")=1
- GOTO DIEX
- +22 IF 'PSORXED("QFLG")
- GOTO DIE
- SET PSORXED("QFLG")=0
- DIEX QUIT
