- PSOPRI ;BIR/JLC - INTERNET PRESCRIPTION REFILL PROCESSOR ;3/27/06 2:23pm
- ;;7.0;OUTPATIENT PHARMACY;**116,204,242,264,300,674**;DEC 1997;Build 1
- ;
- ;Reference to ^PSSLOCK supported by DBIA 2789
- ;Reference to DIC(19 supported by DBIA 2246
- ;
- ;PSO*242 do not init PSODFN, it should only be set by label print
- ;
- START L +^XTMP("PSOATRF"):5 I '$T D Q
- .D BMES^XPDUTL("The scheduled job is currently running - Please try it later.")
- .D MES^XPDUTL("")
- L -^XTMP("PSOATRF") S PSOVEX=1
- K PSOVEXI,PSOISITE,PSOVEXFL,PSONOF
- S PSOVX=0 F S PSOVX=$O(^PS(59,PSOVX)) Q:'PSOVX I $P($G(^PS(59,PSOVX,"I")),"^"),DT>$P($G(^("I")),"^") S PSOVEXI(PSOVX)=""
- I $O(PSOVEXI(0)) W !,"Looking for refill requests for inactive Outpatient divisions..." D
- . S PSOVIN=0 F S PSOVIN=$O(^PS(52.43,"AINST",PSOVIN)) Q:'PSOVIN S PSOVXLP="" F S PSOVXLP=$O(^PS(52.43,"AINST",PSOVIN,PSOVXLP)) Q:PSOVXLP="" D
- .. S PSOIEN=$O(^PS(52.43,"AINST",PSOVIN,PSOVXLP,""))
- .. S PSOISITE=$P($G(^PSRX(PSOVXLP,2)),"^",9) Q:$G(PSOVEXI(+$G(PSOISITE)))
- .. I PSOISITE,$D(PSOVEXI(PSOISITE)),$P($G(^PS(52.43,PSOIEN,0)),"^",5)="" S PSOVEXI(PSOISITE)=1,PSOVEXFL=1
- . I '$G(PSOVEXFL) W ".none found.",!
- I $G(PSOVEXFL) W !!,"The following Inactive Outpatient sites have refill requests:",! D I Y'=1 G END
- . S PSOVX=0 F S PSOVX=$O(PSOVEXI(PSOVX)) Q:'PSOVX I $G(PSOVEXI(PSOVX)) W !?5,$P($G(^PS(59,+$G(PSOVX),0)),"^")
- . K DIR W ! S DIR(0)="E",DIR("A")="Press Return to Continue, '^' to exit" D ^DIR W ! I Y'=1 Q
- D:'$D(PSOPAR) ^PSOLSET G:'$D(PSOPAR) END
- W !!!?20,"Division: "_$P(^PS(59,PSOSITE,0),"^"),!!
- S PSOBBC1("FROM")="REFILL",PSOBBC("QFLG")=0,PSOBBC("DFLG")=0
- S:'$G(PSOINST) PSOINST=$P($G(^PS(59,PSOSITE,"INI")),"^") S:'PSOINST PSOINST=0 ;p674
- I '$D(^PS(52.43,"AINST",PSOINST)) S PSOANS="N" W !!?7,$C(7),"There are no internet refills to process." G END
- D ASK^PSOBBC W:PSOBBC("QFLG")=1 !?7,$C(7),"No internet refills were processed." G:PSOBBC("QFLG")=1 END
- IPR W ! S DIR("B")="YES",DIR("A")="Process internet refill requests at this time",DIR(0)="Y" D ^DIR K DIR S PSOANS="N" I $G(DIRUT) S PSOPTRX="" G END
- G:Y=0 END S PSOPTRX="" I Y=1 S PSOANS="Y"
- I PSOANS["Y" S DIR("B")="NO",DIR("A")="Process internet refills for all divisions",DIR(0)="Y" D ^DIR K DIR S PSOANS2="S" S:Y=1 PSOANS2="M" I $G(DIRUT) S PSOANS="N" G END
- IPR6 I PSOANS["Y",$G(PSOPTRX),'$G(PSOMHV) D IPR5 ;MARK PROCESSED NODES
- D IPR3 I $G(PSOANS)="N" D ULK G END
- ;I $P(X,"-")'=PSOINST W !?7,$C(7),$C(7),$C(7),"Not from this institution.",! D ULK G IPR6
- S (PSOBBC("IRXN"),PSOBBC("OIRXN"))=$P(X,"-",2)
- I $G(^PSRX(PSOBBC("IRXN"),0))']"" W !,$C(7),"Rx data is not on file!",! D ULK G IPR6
- I $P($G(^PSRX(PSOBBC("IRXN"),"STA")),"^")=13 W !,$C(7),"Rx has already been deleted." D ULK G IPR6
- I $G(PSOBBC("DONE"))[PSOBBC("IRXN")_"," W !,$C(7),"Rx has already been entered." D ULK G IPR6
- K X,Y D:PSOBBC("QFLG") PROCESSX^PSOBBC
- S PSOSELSE=0 I $G(PSODFN)'=$P(^PSRX(PSOBBC("IRXN"),0),"^",2) S PSOSELSE=1 D PT^PSOBBC I $G(PSOBBC("DFLG")) K PSOSELSE D ULK G IPR6
- I '$G(PSOSELSE) D PTC^PSOBBC I $G(PSOBBC("DFLG")) K PSOSELSE D ULK G IPR6
- K PSOSELSE D PROFILE^PSORX1
- S PSOBBC("DONE")=PSOBBC("IRXN")_",",PSOMHV=0 D REFILL^PSOBBC D ULK G IPR6
- Q
- IPR3 K PSOBBC("IRXN"),PSOXFLAG F S PSOPTRX=$O(^PS(52.43,"AINST",PSOINST,PSOPTRX)) D Q:PSOANS="N"!($G(PSOXFLAG))
- .I PSOPTRX="" S PSOANS="N" Q
- .S PSOIEN=$O(^PS(52.43,"AINST",PSOINST,PSOPTRX,""))
- .I '$D(^PSRX(+PSOPTRX,0)),$P(^PS(52.43,PSOIEN,0),"^",5)="" S PSONOF=1 D IPR5 K PSONOF Q ;SKIPS ERRONEOUS ENTRIES
- IPR4 .I PSOANS["Y" Q:$P(^PS(52.43,PSOIEN,0),"^",5)'="" S X=PSOINST_"-"_PSOPTRX ;SKIPS ENTRIES ALREADY PROCESSED AND FORMATS VARIABLE X
- IPR10 .I PSOANS2["S",$D(^PSRX(+PSOPTRX,0)),PSOSITE'=$P($G(^PSRX(+PSOPTRX,2)),"^",9) Q
- .S PSOPSORX=+$G(PSOPTRX) I PSOPSORX D PSOL^PSSLOCK(PSOPSORX) I '$G(PSOMSG) K PSOPSORX,PSOMSG Q
- .K PSOMSG S PSOXFLAG=1
- Q
- ;LINES CALLED TO MARK PROCESSED NODES
- IPR5 K DA,DR,DIE S DA=$O(^PS(52.43,"AINST",PSOINST,PSOPTRX,""))
- S DIE="^PS(52.43,",DR="5////"_DT_";6///"_$S($G(PSOBBC("DFLG"))=1:"NOT FILLED",$G(PSONOF)=1:"NOT FILLED",1:"FILLED") D ^DIE ; MARKS NODE AS PROCESSED
- K ^PS(52.43,"AINST",PSOINST,PSOPTRX,DA)
- Q
- END D PROCESSX^PSOBBC
- I $P($G(^PS(59,+$G(PSOSITE),"I")),"^"),DT>$P($G(^("I")),"^") D FINAL^PSOLSET W !!,"Your Outpatient Site parameters have been deleted because you selected an",!,"inactive Outpatient Site!",!
- K DIR,PSOBBC,PSOBBC1,PSOVIN,PSOISITE,PSOVEXFL,PSOVXLP,PSOVEX,PSOVX,PSOVEXI,PSOANS,PSOANS2,PSOPTRX,PSOXFLAG,PSOPSORX,X,Y,PSODFN,PSOMHV
- Q
- ULK ;
- I '$G(PSOPSORX) Q
- D PSOUL^PSSLOCK(PSOPSORX)
- K PSOPSORX
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOPRI 4613 printed Dec 13, 2024@02:33:02 Page 2
- PSOPRI ;BIR/JLC - INTERNET PRESCRIPTION REFILL PROCESSOR ;3/27/06 2:23pm
- +1 ;;7.0;OUTPATIENT PHARMACY;**116,204,242,264,300,674**;DEC 1997;Build 1
- +2 ;
- +3 ;Reference to ^PSSLOCK supported by DBIA 2789
- +4 ;Reference to DIC(19 supported by DBIA 2246
- +5 ;
- +6 ;PSO*242 do not init PSODFN, it should only be set by label print
- +7 ;
- START LOCK +^XTMP("PSOATRF"):5
- IF '$TEST
- Begin DoDot:1
- +1 DO BMES^XPDUTL("The scheduled job is currently running - Please try it later.")
- +2 DO MES^XPDUTL("")
- End DoDot:1
- QUIT
- +3 LOCK -^XTMP("PSOATRF")
- SET PSOVEX=1
- +4 KILL PSOVEXI,PSOISITE,PSOVEXFL,PSONOF
- +5 SET PSOVX=0
- FOR
- SET PSOVX=$ORDER(^PS(59,PSOVX))
- if 'PSOVX
- QUIT
- IF $PIECE($GET(^PS(59,PSOVX,"I")),"^")
- IF DT>$PIECE($GET(^("I")),"^")
- SET PSOVEXI(PSOVX)=""
- +6 IF $ORDER(PSOVEXI(0))
- WRITE !,"Looking for refill requests for inactive Outpatient divisions..."
- Begin DoDot:1
- +7 SET PSOVIN=0
- FOR
- SET PSOVIN=$ORDER(^PS(52.43,"AINST",PSOVIN))
- if 'PSOVIN
- QUIT
- SET PSOVXLP=""
- FOR
- SET PSOVXLP=$ORDER(^PS(52.43,"AINST",PSOVIN,PSOVXLP))
- if PSOVXLP=""
- QUIT
- Begin DoDot:2
- +8 SET PSOIEN=$ORDER(^PS(52.43,"AINST",PSOVIN,PSOVXLP,""))
- +9 SET PSOISITE=$PIECE($GET(^PSRX(PSOVXLP,2)),"^",9)
- if $GET(PSOVEXI(+$GET(PSOISITE)))
- QUIT
- +10 IF PSOISITE
- IF $DATA(PSOVEXI(PSOISITE))
- IF $PIECE($GET(^PS(52.43,PSOIEN,0)),"^",5)=""
- SET PSOVEXI(PSOISITE)=1
- SET PSOVEXFL=1
- End DoDot:2
- +11 IF '$GET(PSOVEXFL)
- WRITE ".none found.",!
- End DoDot:1
- +12 IF $GET(PSOVEXFL)
- WRITE !!,"The following Inactive Outpatient sites have refill requests:",!
- Begin DoDot:1
- +13 SET PSOVX=0
- FOR
- SET PSOVX=$ORDER(PSOVEXI(PSOVX))
- if 'PSOVX
- QUIT
- IF $GET(PSOVEXI(PSOVX))
- WRITE !?5,$PIECE($GET(^PS(59,+$GET(PSOVX),0)),"^")
- +14 KILL DIR
- WRITE !
- SET DIR(0)="E"
- SET DIR("A")="Press Return to Continue, '^' to exit"
- DO ^DIR
- WRITE !
- IF Y'=1
- QUIT
- End DoDot:1
- IF Y'=1
- GOTO END
- +15 if '$DATA(PSOPAR)
- DO ^PSOLSET
- if '$DATA(PSOPAR)
- GOTO END
- +16 WRITE !!!?20,"Division: "_$PIECE(^PS(59,PSOSITE,0),"^"),!!
- +17 SET PSOBBC1("FROM")="REFILL"
- SET PSOBBC("QFLG")=0
- SET PSOBBC("DFLG")=0
- +18 ;p674
- if '$GET(PSOINST)
- SET PSOINST=$PIECE($GET(^PS(59,PSOSITE,"INI")),"^")
- if 'PSOINST
- SET PSOINST=0
- +19 IF '$DATA(^PS(52.43,"AINST",PSOINST))
- SET PSOANS="N"
- WRITE !!?7,$CHAR(7),"There are no internet refills to process."
- GOTO END
- +20 DO ASK^PSOBBC
- if PSOBBC("QFLG")=1
- WRITE !?7,$CHAR(7),"No internet refills were processed."
- if PSOBBC("QFLG")=1
- GOTO END
- IPR WRITE !
- SET DIR("B")="YES"
- SET DIR("A")="Process internet refill requests at this time"
- SET DIR(0)="Y"
- DO ^DIR
- KILL DIR
- SET PSOANS="N"
- IF $GET(DIRUT)
- SET PSOPTRX=""
- GOTO END
- +1 if Y=0
- GOTO END
- SET PSOPTRX=""
- IF Y=1
- SET PSOANS="Y"
- +2 IF PSOANS["Y"
- SET DIR("B")="NO"
- SET DIR("A")="Process internet refills for all divisions"
- SET DIR(0)="Y"
- DO ^DIR
- KILL DIR
- SET PSOANS2="S"
- if Y=1
- SET PSOANS2="M"
- IF $GET(DIRUT)
- SET PSOANS="N"
- GOTO END
- IPR6 ;MARK PROCESSED NODES
- IF PSOANS["Y"
- IF $GET(PSOPTRX)
- IF '$GET(PSOMHV)
- DO IPR5
- +1 DO IPR3
- IF $GET(PSOANS)="N"
- DO ULK
- GOTO END
- +2 ;I $P(X,"-")'=PSOINST W !?7,$C(7),$C(7),$C(7),"Not from this institution.",! D ULK G IPR6
- +3 SET (PSOBBC("IRXN"),PSOBBC("OIRXN"))=$PIECE(X,"-",2)
- +4 IF $GET(^PSRX(PSOBBC("IRXN"),0))']""
- WRITE !,$CHAR(7),"Rx data is not on file!",!
- DO ULK
- GOTO IPR6
- +5 IF $PIECE($GET(^PSRX(PSOBBC("IRXN"),"STA")),"^")=13
- WRITE !,$CHAR(7),"Rx has already been deleted."
- DO ULK
- GOTO IPR6
- +6 IF $GET(PSOBBC("DONE"))[PSOBBC("IRXN")_","
- WRITE !,$CHAR(7),"Rx has already been entered."
- DO ULK
- GOTO IPR6
- +7 KILL X,Y
- if PSOBBC("QFLG")
- DO PROCESSX^PSOBBC
- +8 SET PSOSELSE=0
- IF $GET(PSODFN)'=$PIECE(^PSRX(PSOBBC("IRXN"),0),"^",2)
- SET PSOSELSE=1
- DO PT^PSOBBC
- IF $GET(PSOBBC("DFLG"))
- KILL PSOSELSE
- DO ULK
- GOTO IPR6
- +9 IF '$GET(PSOSELSE)
- DO PTC^PSOBBC
- IF $GET(PSOBBC("DFLG"))
- KILL PSOSELSE
- DO ULK
- GOTO IPR6
- +10 KILL PSOSELSE
- DO PROFILE^PSORX1
- +11 SET PSOBBC("DONE")=PSOBBC("IRXN")_","
- SET PSOMHV=0
- DO REFILL^PSOBBC
- DO ULK
- GOTO IPR6
- +12 QUIT
- IPR3 KILL PSOBBC("IRXN"),PSOXFLAG
- FOR
- SET PSOPTRX=$ORDER(^PS(52.43,"AINST",PSOINST,PSOPTRX))
- Begin DoDot:1
- +1 IF PSOPTRX=""
- SET PSOANS="N"
- QUIT
- +2 SET PSOIEN=$ORDER(^PS(52.43,"AINST",PSOINST,PSOPTRX,""))
- +3 ;SKIPS ERRONEOUS ENTRIES
- IF '$DATA(^PSRX(+PSOPTRX,0))
- IF $PIECE(^PS(52.43,PSOIEN,0),"^",5)=""
- SET PSONOF=1
- DO IPR5
- KILL PSONOF
- QUIT
- IPR4 ;SKIPS ENTRIES ALREADY PROCESSED AND FORMATS VARIABLE X
- IF PSOANS["Y"
- if $PIECE(^PS(52.43,PSOIEN,0),"^",5)'=""
- QUIT
- SET X=PSOINST_"-"_PSOPTRX
- IPR10 IF PSOANS2["S"
- IF $DATA(^PSRX(+PSOPTRX,0))
- IF PSOSITE'=$PIECE($GET(^PSRX(+PSOPTRX,2)),"^",9)
- QUIT
- +1 SET PSOPSORX=+$GET(PSOPTRX)
- IF PSOPSORX
- DO PSOL^PSSLOCK(PSOPSORX)
- IF '$GET(PSOMSG)
- KILL PSOPSORX,PSOMSG
- QUIT
- +2 KILL PSOMSG
- SET PSOXFLAG=1
- End DoDot:1
- if PSOANS="N"!($GET(PSOXFLAG))
- QUIT
- +3 QUIT
- +4 ;LINES CALLED TO MARK PROCESSED NODES
- IPR5 KILL DA,DR,DIE
- SET DA=$ORDER(^PS(52.43,"AINST",PSOINST,PSOPTRX,""))
- +1 ; MARKS NODE AS PROCESSED
- SET DIE="^PS(52.43,"
- SET DR="5////"_DT_";6///"_$SELECT($GET(PSOBBC("DFLG"))=1:"NOT FILLED",$GET(PSONOF)=1:"NOT FILLED",1:"FILLED")
- DO ^DIE
- +2 KILL ^PS(52.43,"AINST",PSOINST,PSOPTRX,DA)
- +3 QUIT
- END DO PROCESSX^PSOBBC
- +1 IF $PIECE($GET(^PS(59,+$GET(PSOSITE),"I")),"^")
- IF DT>$PIECE($GET(^("I")),"^")
- DO FINAL^PSOLSET
- WRITE !!,"Your Outpatient Site parameters have been deleted because you selected an",!,"inactive Outpatient Site!",!
- +2 KILL DIR,PSOBBC,PSOBBC1,PSOVIN,PSOISITE,PSOVEXFL,PSOVXLP,PSOVEX,PSOVX,PSOVEXI,PSOANS,PSOANS2,PSOPTRX,PSOXFLAG,PSOPSORX,X,Y,PSODFN,PSOMHV
- +3 QUIT
- ULK ;
- +1 IF '$GET(PSOPSORX)
- QUIT
- +2 DO PSOUL^PSSLOCK(PSOPSORX)
- +3 KILL PSOPSORX
- +4 QUIT