- 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 Feb 18, 2025@23:55:52 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
