PSOFIXDT ;BHAM ISC/RTR - COSIGNER AND FILL DATE CLEAN UP;7/29/94
;;6.0;OUTPATIENT PHARMACY;**124**;APRIL 1993
S PSOSTART=$O(^PS(59.7,0)) I +$P(^PS(59.7,PSOSTART,49.99),"^")<6 W !,"It appears from your version entry in your Pharmacy System File (#59.7)",!,"that you are not running Outpatient V 6.0.!",! G END
S PSOSTART=$O(^PS(59.7,0)),PSOSTART=$P($G(^PS(59.7,PSOSTART,49.99)),"^",2) I 'PSOSTART W !,"There is a problem with the Date OP Installed field in your Pharmacy",!,"System File (#59.7), check entry and start again!",!! G END
W @IOF W !,"This routine will queue three separate jobs.",!
W !,"One job will generate a mail message listing prescriptions with missing",!,"Fill dates or Refill dates.",!
W !,"A second job will generate a mail message listing entries in your Suspense",!,"File (#52.5) with missing Suspense dates.",!
W !,"A third job will look through your prescription file for any -1 entries",!,"in your Cosigning Physician field.",!
W "If we find any, we will update that field with the appropriate entry,",!,"based on the Usual Cosigner field in the New Person File for the",!,"provider of the prescription. If there is a problem with the Usual Cosigner"
W !,"entry in the New Person File, we will set that field to null.",!,"A mail message will be sent to you with the number of entries changed.",!
S X1=PSOSTART,X2=-1 D C^%DTC S PSOSTART=X
D NOW^%DTC S %DT="RAEX",%DT(0)=%,%DT("B")="NOW",%DT("A")="QUEUE JOBS TO RUN AT WHAT TIME: " D ^%DT S PSOQTIME=Y I $D(DTOUT)!(Y=-1) W !,"Try again later!",! G END
S ZTIO="",ZTRTN="BEG^PSOFIXDT",ZTDTH=PSOQTIME,ZTDESC="CHECK BAD PROVIDER ENTRIES",ZTSAVE("PSOSTART")=PSOSTART D ^%ZTLOAD
S ZTIO="",ZTRTN="SUS^PSOFIXDT",ZTDTH=PSOQTIME,ZTDESC="CHECK FOR MISSING SUSPENSE DATES" D ^%ZTLOAD
S ZTIO="",ZTRTN="START^PSOFIXDT",ZTDTH=PSOQTIME,ZTDESC="CHECK FOR MISSING FILL DATES",ZTSAVE("PSOSTART")=PSOSTART D ^%ZTLOAD W !!,"TASKS QUEUED!",! G END
BEG K ^TMP($J,"TRANS") S ^TMP($J,"TRANS",1,0)="Following are counts for the -1 entries found in the Prescription File (#52).",^TMP($J,"TRANS",2,0)=" ",^TMP($J,"TRANS",3,0)=" "
S (PSOTOT,CNT,PSOCNT)=0 F AAA=PSOSTART:0 S AAA=$O(^PSRX("AD",AAA)) Q:'AAA F BBB=0:0 S BBB=$O(^PSRX("AD",AAA,BBB)) Q:'BBB I $P($G(^PSRX(BBB,3)),"^",3)=-1 K DA,DR,PSUS,PSPRV S PSCOS=0,PSPRV=+$P($G(^PSRX(BBB,0)),"^",4) D
.I PSPRV,+$P($G(^VA(200,PSPRV,"PS")),"^",7),+$P($G(^("PS")),"^",8) S PSCNUM=$P(^("PS"),"^",8) I $D(^VA(200,PSCNUM,"PS")),$P(^("PS"),"^"),'$P(^("PS"),"^",7),$S('$P(^("PS"),"^",4):1,1:$P(^("PS"),"^",4)'<DT) S PSCOS=1
.I PSCOS S DIE="^PSRX(",DA=BBB,DR="109////"_PSCNUM D ^DIE S CNT=CNT+1 Q
.I 'PSCOS S DIE="^PSRX(",DA=BBB,DR="109////"_"@" D ^DIE S PSOCNT=PSOCNT+1 Q
S PSOTOT=CNT+PSOCNT,^TMP($J,"TRANS",4,0)="Number of -1 entries changed to a provider based on the Usual Provider entry in the New Person File (#200): "_$G(CNT)
S ^TMP($J,"TRANS",5,0)=" ",^TMP($J,"TRANS",6,0)="Number of -1 entries changed to null: "_$G(PSOCNT),^TMP($J,"TRANS",7,0)=" ",^TMP($J,"TRANS",8,0)="Total entries changed: "_$G(PSOTOT)
S XMSUB="Invalid -1 entries for Cosigning Physician" D MAIL G END
START K ^TMP($J,"TRANS") S ^TMP($J,"TRANS",1,0)="Following are Rx fills that are missing either a Fill Date or a Refill Date:",^TMP($J,"TRANS",2,0)=" "
F CCC=1:1 S X1=PSOSTART,X2=CCC D C^%DTC I $O(^PSRX("AD",X,0)) S RXSTART=$O(^PSRX("AD",X,0)) Q
S PSOCOUNT=0,PSSUB=3 F PPP=RXSTART:0 S PPP=$O(^PSRX(PPP)) Q:'PPP D
.Q:$P($G(^PSRX(PPP,0)),"^",15)=3
.S RXNUM=$P($G(^PSRX(PPP,0)),"^")
.I $D(^PSRX(PPP,2)),'$P($G(^(2)),"^",2) S ^TMP($J,"TRANS",PSSUB,0)="Rx number: "_$G(RXNUM)_" Original fill" S PSSUB=PSSUB+1,PSOCOUNT=PSOCOUNT+1
.F LLL=0:0 S LLL=$O(^PSRX(PPP,1,LLL)) Q:'LLL I $D(^PSRX(PPP,1,LLL,0)),'$P($G(^(0)),"^") S ^TMP($J,"TRANS",PSSUB,0)="Rx number: "_$G(RXNUM)_" Refill number: "_$G(LLL) S PSSUB=PSSUB+1,PSOCOUNT=PSOCOUNT+1
I 'PSOCOUNT S ^TMP($J,"TRANS",3,0)="NO MISSING FILL DATES WERE FOUND!"
S XMSUB="Missing Fill Dates" D MAIL G END
SUS S SUSCOUNT=4 K ^TMP($J,"TRANS") S ^TMP($J,"TRANS",1,0)="Following are entries in your suspense file (#52.5) that are missing a suspense date."
S ^TMP($J,"TRANS",2,0)="The Internal Rx Number is the .01 field in the Suspense File (#52.5).",^TMP($J,"TRANS",3,0)=" "
F RRR=0:0 S RRR=$O(^PS(52.5,RRR)) Q:'RRR I '$P($G(^PS(52.5,RRR,0)),"^",2) S ^TMP($J,"TRANS",SUSCOUNT,0)="Rx Number: "_$P($G(^PSRX($P($G(^PS(52.5,RRR,0)),"^"),0)),"^")_" Internal Rx number: "_$P($G(^PS(52.5,RRR,0)),"^") S SUSCOUNT=SUSCOUNT+1
I SUSCOUNT=4 S ^TMP($J,"TRANS",5,0)="NO MISSING SUSPENSE DATES FOUND!"
S XMSUB="Missing suspense dates" D MAIL
END K ^TMP($J),XMDUZ,PSPRV,CNT,PSCOS,PSCNUM,PSOCNT,PSOTOT,PSOQTIME,PSOSTART,AAA,BBB,%DT,Y,DIE,DA,DR,PSSUB,PSOCOUNT,CCC,PPP,RRR,SUSCOUNT,RXNUM,DTOUT,DUOUT,XMDUZ,XMSUB,XMY,XMTEXT,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE S:$D(ZTQUEUED) ZTREQ="@" Q
MAIL S XMDUZ=.5,XMY(DUZ)="",XMY(DUZ,1)="I",XMTEXT="^TMP($J,""TRANS""," D ^XMD Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOFIXDT 4926 printed Apr 09, 2024@21:32:35 Page 2
PSOFIXDT ;BHAM ISC/RTR - COSIGNER AND FILL DATE CLEAN UP;7/29/94
+1 ;;6.0;OUTPATIENT PHARMACY;**124**;APRIL 1993
+2 SET PSOSTART=$ORDER(^PS(59.7,0))
IF +$PIECE(^PS(59.7,PSOSTART,49.99),"^")<6
WRITE !,"It appears from your version entry in your Pharmacy System File (#59.7)",!,"that you are not running Outpatient V 6.0.!",!
GOTO END
+3 SET PSOSTART=$ORDER(^PS(59.7,0))
SET PSOSTART=$PIECE($GET(^PS(59.7,PSOSTART,49.99)),"^",2)
IF 'PSOSTART
WRITE !,"There is a problem with the Date OP Installed field in your Pharmacy",!,"System File (#59.7), check entry and start again!",!!
GOTO END
+4 WRITE @IOF
WRITE !,"This routine will queue three separate jobs.",!
+5 WRITE !,"One job will generate a mail message listing prescriptions with missing",!,"Fill dates or Refill dates.",!
+6 WRITE !,"A second job will generate a mail message listing entries in your Suspense",!,"File (#52.5) with missing Suspense dates.",!
+7 WRITE !,"A third job will look through your prescription file for any -1 entries",!,"in your Cosigning Physician field.",!
+8 WRITE "If we find any, we will update that field with the appropriate entry,",!,"based on the Usual Cosigner field in the New Person File for the",!,"provider of the prescription. If there is a problem with the Usual Cosigner"
+9 WRITE !,"entry in the New Person File, we will set that field to null.",!,"A mail message will be sent to you with the number of entries changed.",!
+10 SET X1=PSOSTART
SET X2=-1
DO C^%DTC
SET PSOSTART=X
+11 DO NOW^%DTC
SET %DT="RAEX"
SET %DT(0)=%
SET %DT("B")="NOW"
SET %DT("A")="QUEUE JOBS TO RUN AT WHAT TIME: "
DO ^%DT
SET PSOQTIME=Y
IF $DATA(DTOUT)!(Y=-1)
WRITE !,"Try again later!",!
GOTO END
+12 SET ZTIO=""
SET ZTRTN="BEG^PSOFIXDT"
SET ZTDTH=PSOQTIME
SET ZTDESC="CHECK BAD PROVIDER ENTRIES"
SET ZTSAVE("PSOSTART")=PSOSTART
DO ^%ZTLOAD
+13 SET ZTIO=""
SET ZTRTN="SUS^PSOFIXDT"
SET ZTDTH=PSOQTIME
SET ZTDESC="CHECK FOR MISSING SUSPENSE DATES"
DO ^%ZTLOAD
+14 SET ZTIO=""
SET ZTRTN="START^PSOFIXDT"
SET ZTDTH=PSOQTIME
SET ZTDESC="CHECK FOR MISSING FILL DATES"
SET ZTSAVE("PSOSTART")=PSOSTART
DO ^%ZTLOAD
WRITE !!,"TASKS QUEUED!",!
GOTO END
BEG KILL ^TMP($JOB,"TRANS")
SET ^TMP($JOB,"TRANS",1,0)="Following are counts for the -1 entries found in the Prescription File (#52)."
SET ^TMP($JOB,"TRANS",2,0)=" "
SET ^TMP($JOB,"TRANS",3,0)=" "
+1 SET (PSOTOT,CNT,PSOCNT)=0
FOR AAA=PSOSTART:0
SET AAA=$ORDER(^PSRX("AD",AAA))
if 'AAA
QUIT
FOR BBB=0:0
SET BBB=$ORDER(^PSRX("AD",AAA,BBB))
if 'BBB
QUIT
IF $PIECE($GET(^PSRX(BBB,3)),"^",3)=-1
KILL DA,DR,PSUS,PSPRV
SET PSCOS=0
SET PSPRV=+$PIECE($GET(^PSRX(BBB,0)),"^",4)
Begin DoDot:1
+2 IF PSPRV
IF +$PIECE($GET(^VA(200,PSPRV,"PS")),"^",7)
IF +$PIECE($GET(^("PS")),"^",8)
SET PSCNUM=$PIECE(^("PS"),"^",8)
IF $DATA(^VA(200,PSCNUM,"PS"))
IF $PIECE(^("PS"),"^")
IF '$PIECE(^("PS"),"^",7)
IF $SELECT('$PIECE(^("PS"),"^",4):1,1:$PIECE(^("PS"),"^",4)'<DT)
SET PSCOS=1
+3 IF PSCOS
SET DIE="^PSRX("
SET DA=BBB
SET DR="109////"_PSCNUM
DO ^DIE
SET CNT=CNT+1
QUIT
+4 IF 'PSCOS
SET DIE="^PSRX("
SET DA=BBB
SET DR="109////"_"@"
DO ^DIE
SET PSOCNT=PSOCNT+1
QUIT
End DoDot:1
+5 SET PSOTOT=CNT+PSOCNT
SET ^TMP($JOB,"TRANS",4,0)="Number of -1 entries changed to a provider based on the Usual Provider entry in the New Person File (#200): "_$GET(CNT)
+6 SET ^TMP($JOB,"TRANS",5,0)=" "
SET ^TMP($JOB,"TRANS",6,0)="Number of -1 entries changed to null: "_$GET(PSOCNT)
SET ^TMP($JOB,"TRANS",7,0)=" "
SET ^TMP($JOB,"TRANS",8,0)="Total entries changed: "_$GET(PSOTOT)
+7 SET XMSUB="Invalid -1 entries for Cosigning Physician"
DO MAIL
GOTO END
START KILL ^TMP($JOB,"TRANS")
SET ^TMP($JOB,"TRANS",1,0)="Following are Rx fills that are missing either a Fill Date or a Refill Date:"
SET ^TMP($JOB,"TRANS",2,0)=" "
+1 FOR CCC=1:1
SET X1=PSOSTART
SET X2=CCC
DO C^%DTC
IF $ORDER(^PSRX("AD",X,0))
SET RXSTART=$ORDER(^PSRX("AD",X,0))
QUIT
+2 SET PSOCOUNT=0
SET PSSUB=3
FOR PPP=RXSTART:0
SET PPP=$ORDER(^PSRX(PPP))
if 'PPP
QUIT
Begin DoDot:1
+3 if $PIECE($GET(^PSRX(PPP,0)),"^",15)=3
QUIT
+4 SET RXNUM=$PIECE($GET(^PSRX(PPP,0)),"^")
+5 IF $DATA(^PSRX(PPP,2))
IF '$PIECE($GET(^(2)),"^",2)
SET ^TMP($JOB,"TRANS",PSSUB,0)="Rx number: "_$GET(RXNUM)_" Original fill"
SET PSSUB=PSSUB+1
SET PSOCOUNT=PSOCOUNT+1
+6 FOR LLL=0:0
SET LLL=$ORDER(^PSRX(PPP,1,LLL))
if 'LLL
QUIT
IF $DATA(^PSRX(PPP,1,LLL,0))
IF '$PIECE($GET(^(0)),"^")
SET ^TMP($JOB,"TRANS",PSSUB,0)="Rx number: "_$GET(RXNUM)_" Refill number: "_$GET(LLL)
SET PSSUB=PSSUB+1
SET PSOCOUNT=PSOCOUNT+1
End DoDot:1
+7 IF 'PSOCOUNT
SET ^TMP($JOB,"TRANS",3,0)="NO MISSING FILL DATES WERE FOUND!"
+8 SET XMSUB="Missing Fill Dates"
DO MAIL
GOTO END
SUS SET SUSCOUNT=4
KILL ^TMP($JOB,"TRANS")
SET ^TMP($JOB,"TRANS",1,0)="Following are entries in your suspense file (#52.5) that are missing a suspense date."
+1 SET ^TMP($JOB,"TRANS",2,0)="The Internal Rx Number is the .01 field in the Suspense File (#52.5)."
SET ^TMP($JOB,"TRANS",3,0)=" "
+2 FOR RRR=0:0
SET RRR=$ORDER(^PS(52.5,RRR))
if 'RRR
QUIT
IF '$PIECE($GET(^PS(52.5,RRR,0)),"^",2)
SET ^TMP($JOB,"TRANS",SUSCOUNT,0)="Rx Number: "_$PIECE($GET(^PSRX($PIECE($GET(^PS(52.5,RRR,0)),"^"),0)),"^")_" Internal Rx number: "_$PIECE($GET(^PS(52.5,RRR,0)),"^")
SET SUSCOUNT=SUSCOUNT+1
+3 IF SUSCOUNT=4
SET ^TMP($JOB,"TRANS",5,0)="NO MISSING SUSPENSE DATES FOUND!"
+4 SET XMSUB="Missing suspense dates"
DO MAIL
END KILL ^TMP($JOB),XMDUZ,PSPRV,CNT,PSCOS,PSCNUM,PSOCNT,PSOTOT,PSOQTIME,PSOSTART,AAA,BBB,%DT,Y,DIE,DA,DR,PSSUB,PSOCOUNT,CCC,PPP,RRR,SUSCOUNT,RXNUM,DTOUT,DUOUT,XMDUZ,XMSUB,XMY,XMTEXT,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
MAIL SET XMDUZ=.5
SET XMY(DUZ)=""
SET XMY(DUZ,1)="I"
SET XMTEXT="^TMP($J,""TRANS"","
DO ^XMD
QUIT
