PSOFIXIB ;BHAM ISC/RTR - REMOVE IB NODES FROM EXEMPT PRESCRIPTIONS ;8/4/93
;;6.0;OUTPATIENT PHARMACY;**23**;AUGUST 1993
D WAIT^DICD W "Checking Prescriptions."
S SDATE=2921028,FILL="",(PN,RX)=0 F S SDATE=$O(^PSRX("AD",SDATE)) Q:'SDATE D
.F S RX=$O(^PSRX("AD",SDATE,RX)) Q:'RX F S FILL=$O(^PSRX("AD",SDATE,RX,FILL)) Q:FILL="" S DFN=+$P($G(^PSRX(RX,0)),"^",2) I DFN S X=$$RXST^IBARXEU(DFN) D:+X=1
..W "." I 'FILL,$D(^PSRX(RX,"IB")) K ^PSRX(RX,"IB") S PN=PN+1 Q
..I FILL,$D(^PSRX(RX,1,FILL,"IB")) K ^PSRX(RX,1,FILL,"IB") S PN=PN+1
W !!,"Finished. "_PN_" Prescriptions Found.",! K PN,FILL,SDATE,RX,SUS,DFN,X Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOFIXIB 628 printed Dec 13, 2024@02:29:26 Page 2
PSOFIXIB ;BHAM ISC/RTR - REMOVE IB NODES FROM EXEMPT PRESCRIPTIONS ;8/4/93
+1 ;;6.0;OUTPATIENT PHARMACY;**23**;AUGUST 1993
+2 DO WAIT^DICD
WRITE "Checking Prescriptions."
+3 SET SDATE=2921028
SET FILL=""
SET (PN,RX)=0
FOR
SET SDATE=$ORDER(^PSRX("AD",SDATE))
if 'SDATE
QUIT
Begin DoDot:1
+4 FOR
SET RX=$ORDER(^PSRX("AD",SDATE,RX))
if 'RX
QUIT
FOR
SET FILL=$ORDER(^PSRX("AD",SDATE,RX,FILL))
if FILL=""
QUIT
SET DFN=+$PIECE($GET(^PSRX(RX,0)),"^",2)
IF DFN
SET X=$$RXST^IBARXEU(DFN)
if +X=1
Begin DoDot:2
+5 WRITE "."
IF 'FILL
IF $DATA(^PSRX(RX,"IB"))
KILL ^PSRX(RX,"IB")
SET PN=PN+1
QUIT
+6 IF FILL
IF $DATA(^PSRX(RX,1,FILL,"IB"))
KILL ^PSRX(RX,1,FILL,"IB")
SET PN=PN+1
End DoDot:2
End DoDot:1
+7 WRITE !!,"Finished. "_PN_" Prescriptions Found.",!
KILL PN,FILL,SDATE,RX,SUS,DFN,X
QUIT
