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 Oct 16, 2024@18:33:40 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
