source: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOFIXDT.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.8 KB
Line 
1PSOFIXDT ;BHAM ISC/RTR - COSIGNER AND FILL DATE CLEAN UP;7/29/94
2 ;;6.0;OUTPATIENT PHARMACY;**124**;APRIL 1993
3 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
4 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
5 W @IOF W !,"This routine will queue three separate jobs.",!
6 W !,"One job will generate a mail message listing prescriptions with missing",!,"Fill dates or Refill dates.",!
7 W !,"A second job will generate a mail message listing entries in your Suspense",!,"File (#52.5) with missing Suspense dates.",!
8 W !,"A third job will look through your prescription file for any -1 entries",!,"in your Cosigning Physician field.",!
9 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"
10 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.",!
11 S X1=PSOSTART,X2=-1 D C^%DTC S PSOSTART=X
12 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
13 S ZTIO="",ZTRTN="BEG^PSOFIXDT",ZTDTH=PSOQTIME,ZTDESC="CHECK BAD PROVIDER ENTRIES",ZTSAVE("PSOSTART")=PSOSTART D ^%ZTLOAD
14 S ZTIO="",ZTRTN="SUS^PSOFIXDT",ZTDTH=PSOQTIME,ZTDESC="CHECK FOR MISSING SUSPENSE DATES" D ^%ZTLOAD
15 S ZTIO="",ZTRTN="START^PSOFIXDT",ZTDTH=PSOQTIME,ZTDESC="CHECK FOR MISSING FILL DATES",ZTSAVE("PSOSTART")=PSOSTART D ^%ZTLOAD W !!,"TASKS QUEUED!",! G END
16BEG 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)=" "
17 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
18 .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
19 .I PSCOS S DIE="^PSRX(",DA=BBB,DR="109////"_PSCNUM D ^DIE S CNT=CNT+1 Q
20 .I 'PSCOS S DIE="^PSRX(",DA=BBB,DR="109////"_"@" D ^DIE S PSOCNT=PSOCNT+1 Q
21 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)
22 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)
23 S XMSUB="Invalid -1 entries for Cosigning Physician" D MAIL G END
24START 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)=" "
25 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
26 S PSOCOUNT=0,PSSUB=3 F PPP=RXSTART:0 S PPP=$O(^PSRX(PPP)) Q:'PPP D
27 .Q:$P($G(^PSRX(PPP,0)),"^",15)=3
28 .S RXNUM=$P($G(^PSRX(PPP,0)),"^")
29 .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
30 .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
31 I 'PSOCOUNT S ^TMP($J,"TRANS",3,0)="NO MISSING FILL DATES WERE FOUND!"
32 S XMSUB="Missing Fill Dates" D MAIL G END
33SUS 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."
34 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)=" "
35 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
36 I SUSCOUNT=4 S ^TMP($J,"TRANS",5,0)="NO MISSING SUSPENSE DATES FOUND!"
37 S XMSUB="Missing suspense dates" D MAIL
38END 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
39MAIL S XMDUZ=.5,XMY(DUZ)="",XMY(DUZ,1)="I",XMTEXT="^TMP($J,""TRANS""," D ^XMD Q
Note: See TracBrowser for help on using the repository browser.