3:01 PM 7-OCT-99 Pharmacy V6.0 Cumulative patch 2 APSDALV APSDALV ;IHS/DSD/ENM/JCM ; FIX PHARM LINKS TO VMED FILE; [ 05/14/1998 4:04 PM ] ;;V6.0;IHS PHARMACY MODIFICATIONS;**1**;09/03/97 ;;V5.06;APSP;MAY 07, 1990 ; This routine will go through the prescription file beginning ; between a site manager specified date interval. It will check ; to see the prescriptions have links to the PCC VMED file and if ; not it will create an entry. If no visit has been made for that ; date a visit with the time stamp of noon will be created, otherwise ; it will attach the V MED entry to the first visit encountered that ; day. TaskMan must be running to use this utility. ; ;------------------------------------------------------------------ START ; D ^XBKSET D ASK G:'$D(ED) END D DATE END D EOJ Q ;------------------------------------------------------------------- ASK ; S APSDALV("DUZ(0)")=DUZ(0) S DUZ(0)="MPp" S %DT("A")="PLEASE ENTER BEGINNING DATE: " S %DT="AE" D ^%DT I Y=-1 G ASKX S BD=Y S %DT("A")="PLEASE ENTER ENDING DATE: " D ^%DT I Y=-1 G:X="" ASK G ASKX S ED=Y TYPE ; S DIR(0)="9000010,.03" S DIR("A")="TYPE OF VISIT TO CREATE" D ^DIR K DIR I $D(DIRUT) K DIRUT,DTOUT,DUOUT,BD,ED G ASK S APSDALV("APCDTYPE")=Y K X,Y CAT ; S DIR(0)="Y" S DIR("A")="DO YOU WANT TO CREATE HISTORICAL VISITS" D ^DIR K DIR I $D(DIRUT) K DIRUT,DTOUT,DUOUT,BD,ED G TYPE I Y S APSDALV("APCDCAT")="E" K X,Y ASKX ; Q DATE ; W ! F DATE=(BD-1):0 S DATE=$O(^PSRX("AD",DATE)) Q:(DATE>ED)!(DATE="") D RX S DUZ(0)=APSDALV("DUZ(0)") W !!,"All done ..." Q RX ; ;IRXN IS THE SUBSCRIPT PRESCRIPTION NUMBER F IRXN=0:0 S IRXN=$O(^PSRX("AD",DATE,IRXN)) Q:IRXN="" S RFN=$O(^(IRXN,"")) D CHECK Q CHECK ; I RFN>0,$S('$D(^PSRX(IRXN,1,RFN,999999911)):1,^(999999911)=""!(^(999999911)=" "):1,1:0) D . S APCDALVR("APCDCAT")=$S($D(APSDALV("APCDCAT")):"E",$P(^PSRX(IRXN,0),U,3)'=1:"I",1:"A") . S APSRX=IRXN,APSRCT=RFN . S APCDALVR("APCDPAT")=$P(^PSRX(IRXN,0),U,2) . S APCDALVR("APCDLOC")=DUZ(2) . S APCDALVR("APCDTYPE")=APSDALV("APCDTYPE") . S APC("PRV")=$P(^PSRX(IRXN,0),U,4) . S APSPDOC1=$P($G(^VA(200,APC("PRV"),0)),U,16),APCDALVR("APCDTPRV")=$S($P($G(^AUTTSITE(1,0)),U,22):APC("PRV"),1:APSPDOC1) ;IHS/DSD/ENM 09/03/97 . S APCDALVR("APCDDATE")=$P(^PSRX(IRXN,1,RFN,0),U,1) . D ^APSDALVR . W "." ; I RFN=0,$S('$D(^PSRX(IRXN,999999911)):1,^(999999911)=""!(^(999999911)=" "):1,1:0) D . S APSRX0=^PSRX(IRXN,0) . S APCDALVR("APCDLOC")=DUZ(2) . S APCDALVR("APCDTYPE")=APSDALV("APCDTYPE") . S APCDALVR("APCDPAT")=$P(APSRX0,U,2) . S APSRX=IRXN,APCDALVR("APCDDATE")=$P(APSRX0,U,13) . S APC("PRV")=$P(^PSRX(IRXN,0),U,4) . S APSPDOC1=$P($G(^VA(200,APC("PRV"),0)),U,16),APCDALVR("APCDTPRV")=$S($P($G(^AUTTSITE(1,0)),U,22):APC("PRV"),1:APSPDOC1) ;IHS/DSD/ENM 09/03/97 . S APCDALVR("APCDCAT")=$S($D(APSDALV("APCDCAT")):"E",$P(APSRX0,U,3)'=1:"I",1:"A") . D ^APSDALVN . W "." K RFN,APSRX,APSRCT,APSRX0,APCDALVR Q EOJ ; K BD,ED,IRXN,DATE,APSDALV Q APSDALV1 APSDALV1 ;IHS/DSD/ENM ; FIX PHARM/VMED LINKS ; [ 05/15/1998 9:57 AM ] ;;V6.0;IHS PHARMACY MODIFICATIONS;**1**;09/03/97 D ^APSDALV Q APSDALVN APSDALVN ;IHS/DSD/ENM/JCM ; CREATE PCC NEW RX LINKAGE ; [ 05/14/1998 4:04 PM ] ;;V6.0;IHS PHARMACY MODIFICATIONS;**1**;09/03/97 ;;V5.06;APSP;MAY 07, 1990 ; NOTE: CALLED FROM APSDALV1 ; S %=APSRX0 D ^APSPCCP ;S APCDALVR("APCDDATE")=$P(%,U,13) VISIT I '$D(APCDALVR("APCDVSIT")) D GVISIT G:'$D(APCDALVR("APCDVSIT")) EXIT VMED K APCDALVR("APCDADFN") D GVMED G:'$D(APCDALVR("APCDADFN")) EXIT RX ; I $D(^PSRX(APSRX)),APCDALVR("APCDADFN") NEW DIE,DR,DA S DIE="^PSRX(",DR="9999999.11////"_APCDALVR("APCDADFN"),DA=APSRX D ^DIE K DA,DIE,DR ;IHS/OHPRD/JCM 6/11/90 EXIT K % Q ; GVISIT ; ;W !,"Creating a visit to which prescriptions will link .. " S APCDALVR("APCDAUTO")="",APCDALVR("APCDANE")="" S AUPNTALK="" S:$D(^APSPCCTM) (^APSPCCTM,APSPCCTM)=^APSPCCTM+1,^APSPCCTM(APSPCCTM,1)=$H_"^V" D ^APCDALV I $D(APSPCCTM) S ^APSPCCTM(APSPCCTM,2)=$H K APSPCCTM K APCDALVR("APCDAUTO"),APCDALVR("APCDANE"),AUPNTALK G:$D(APCDALVR("APCDAFLG")) @("V"_APCDALVR("APCDAFLG")) Q ; GVMED ; S %=APSRX0 S APCDALVR("APCDTRX")="`"_$P(%,U,6) S X=$P(%,U,10),APCDALVR("APCDTSIG")=$S($L(X)<33:X,1:$E(X,1,31)_"~") S APCDALVR("APCDTQTY")=+$P(%,U,7)\1 S APCDALVR("APCDTDAY")=$P(%,U,8) S APCDALVR("APCDTDIS")="" ; S APCDALVR("APCDATMP")="[APCDALVR 9000010.14 (ADD)]" K APCDALVR("APCDAFLG") S:$D(^APSPCCTM) (^APSPCCTM,APSPCCTM)=^APSPCCTM+1,^APSPCCTM(APSPCCTM,1)=$H_"^N" D ^APCDALVR I $D(APSPCCTM) S ^APSPCCTM(APSPCCTM,2)=$H K APSPCCTM G:$D(APCDALVR("APCDAFLG")) @APCDALVR("APCDAFLG") Q ; V2 S APSERROR="inability to create visit",APSBN="V" G LBULL V3 S APSERROR="invalid visit parameters (date, location, etc.)",APSBN="V" G LBULL ; 1 S APSERROR="incorrect template specification",APSBN="VMED" G LBULL 2 S APSERROR="invalid values being passed to V MED",APSBN="VMED" G LBULL ; LBULL ; SEND BULLETIN - LINK FAILURE K XMB S XMB(1)=+APSRX0 S APSPAT=$P(APSRX0,U,2) S XMB(2)=$P(^DPT(APSPAT,0),U,1)_" (DFN "_APSPAT_")" S XMB(3)="established" S Y=DT X ^DD("DD") S XMB(4)=Y S XMB(5)=APSERROR S XMB="APSP LINK FAIL "_APSBN S APSDUZ=DUZ,DUZ=.5 D ^XMB S DUZ=APSDUZ K XMB,APSDUZ,APSERROR,APSBN,APSPAT Q APSDALVR APSDALVR ;IHS/DSD/ENM/JCM ; CREATE PCC REFILL RX LINKAGE ; [ 05/14/1998 4:04 PM ] ;;V6.0;IHS PHARMACY MODIFICATIONS;**1**;09/03/97 ;;V5.06;APSP;MAY 07, 1990 ; NOTE: CALLED FROM APSDALV1 ; IHS/OHPRD/JCM 6/16/89 Changed GVMED+10 by adding a \1 ; S APSRX0=^PSRX(APSRX,0) S APSRCT0=^PSRX(APSRX,1,APSRCT,0) S %=APSRCT0 VISIT I '$D(APCDALVR("APCDVSIT")) D GVISIT G:'$D(APCDALVR("APCDVSIT")) EXIT VMED K APCDALVR("APCDADFN") D GVMED G:'$D(APCDALVR("APCDADFN")) EXIT RX ; I $D(^PSRX(APSRX,1,APSRCT)),APCDALVR("APCDADFN") N DR,DA,DIE S DIE="^PSRX(APSRX,1,",DA(1)=APSRX,DA=APSRCT,DR="9999999.11////"_APCDALVR("APCDADFN") D ^DIE K DIE,DA,DR ;IHS/OHPRD/JCM 6/11/90 EXIT K %,APSRCT0 Q ; GVISIT ; S APCDALVR("APCDAUTO")="",APCDALVR("APCDANE")="" S AUPNTALK="" S:$D(^APSPCCTM) (^APSPCCTM,APSPCCTM)=^APSPCCTM+1,^APSPCCTM(APSPCCTM,1)=$H_"^V" D ^APCDALV I $D(APSPCCTM) S ^APSPCCTM(APSPCCTM,2)=$H K APSPCCTM K APCDALVR("APCDAUTO"),APCDALVR("APCDANE"),AUPNTALK G:$D(APCDALVR("APCDAFLG")) @("V"_APCDAFLG) Q ; GVMED ; S %=APSRX0 S APCDALVR("APCDTRX")="`"_$P(%,U,6) S X=$P(%,U,10),APCDALVR("APCDTSIG")=$S($L(X)<33:X,1:$E(X,1,31)_"~") S APCDALVR("APCDTQTY")=+$P(%,U,7) S APCDALVR("APCDTDAY")=$P(%,U,8) S APCDALVR("APCDTDIS")="" ; S %=APSRCT0 S APCDALVR("APCDTDAY")=(APCDALVR("APCDTDAY")*($P(%,U,4)/APCDALVR("APCDTQTY")))+.5\1 S APCDALVR("APCDTQTY")=+$P(%,U,4)\1 ;IHS/OHPRD/JCM 6/16/89 ; S APCDALVR("APCDATMP")="[APCDALVR 9000010.14 (ADD)]" K APCDALVR("APCDAFLG") S:$D(^APSPCCTM) (^APSPCCTM,APSPCCTM)=^APSPCCTM+1,^APSPCCTM(APSPCCTM,1)=$H_"^R" D ^APCDALVR I $D(APSPCCTM) S ^APSPCCTM(APSPCCTM,2)=$H K APSPCCTM G:$D(APCDALVR("APCDAFLG")) @APCDALVR("APCDAFLG") Q ; V2 S APSERROR="inability to create visit",APSBN="V" G LBULL V3 S APSERROR="invalid visit parameters (date, location, etc.)",APSBN="V" G LBULL ; 1 S APSERROR="incorrect template specification",APSBN="VMED" G LBULL 2 S APSERROR="invalid values being passed to V MED",APSBN="VMED" G LBULL ; LBULL ; SEND BULLETIN - LINK FAILURE K XMB S XMB(1)=+APSRX0 S APSPAT=$P(APSRX0,U,2) S XMB(2)=$P(^DPT(APSPAT,0),U,1)_" (DFN "_APSPAT_")" S XMB(3)="refilled" S Y=DT X ^DD("DD") S XMB(4)=Y S XMB(5)=APSERROR S XMB="APSP LINK FAIL "_APSBN S APSDUZ=DUZ,DUZ=.5 D ^XMB S DUZ=APSDUZ K XMB,APSDUZ,APSERROR,APSBN,APSPAT Q APSPCCE APSPCCE ; IHS/DSD/ENM - CREATE PCC EDIT RX LINKAGE ; [ 05/15/1998 11:33 AM ] ;;6.0;IHS PHARMACY MODIFICATIONS;**1**;09/03/97 ; NOTE: CALLED FROM PSRXEDIT,PSORENW1 ;IHS/OHPRD/JCM 6/16/89 ADDED \1 TO EDITRX+7,EDITREF+5 ;IHS/OHPRD/JCM 6/16/89 CHANGED 999999911 TO 9999999 IN SETALVRC+5&6 ;IHS/OHPRD/JCM 6/18/90 SETALVRC+1&2 Changed logic to always set ; PSDFN irregardless of whether it exists or not. ; EN ; NORMAL ENTRY POINT FROM PHARMACY ROUTINES ;I APSRCT,'$D(^PSRX(APSRX,1,APSRCT,999999911)) D SETALVR2 G ^APSPCCR ;I 'APSRCT,'$D(^PSRX(APSRX,999999911)) D SETALVR1 G ^APSPCCN ;IHS/DSD/ENM/POC 02/3/98 2 LINES ABOVE COM/OUT NX 10 LINES ADDED NEW/REF/PCC EDIT VAR S APSPSVRX=APSRX ;SAVE VAR S APSPSVRF=APSRCT ;" " S (APSPNEW,APSPKILL,APSPREF)=0 I $D(^PSRX(APSRX,0))#10 S APSDVRXI=$G(^PSRX(APSRX,999999911),"NONE") I '$D(^AUPNVMED(APSDVRXI,0))#10 S APSPNEW=1 D SETALVR1,VR1,^APSPCCN ;IHS/DSD/ENM 05/15/98 S APSRX=APSPSVRX ;IN CASE GETS KILLED S APSRCT=APSPSVRF ;" " " " ;ABOVE SAYS GOT RX BUT NO ENTRY IN V MED FILE I $D(^PSRX(APSRX,1,APSRCT,0))#10 S APSDVREF=$G(^PSRX(APSRX,999999911),"NONE") I '$D(^AUPNVMED(APSDVREF,0))#10 S APSPREF=1 D SETALVR2,VR2,^APSPCCR ;IHS/DSD/ENM 05/15/98 ;ABOVE SAYS GOT REFILL BUT NO ENTRY IN V MED FILE S APSRX=APSPSVRX,APSRCT=APSPSVRF ;IN CASE GETS KILLED ;END OF MODES ; ; TASKMAN SETUP I APSRCT S APSRCTL=+^PSRX(APSRX,1,APSRCT,999999911),APSRCT0=^PSRX(APSRX,1,APSRCT,0) I 'APSRCT S APSRCTL="",APSRCT0="" S APSL=$S($D(^PSRX(APSRX,999999911))#2:+^(999999911),1:0) S APSRX0=^PSRX(APSRX,0) K ZTSAVE F %="APSRX","APSRX0","APSRCT","APSRCT0","APSL","APSRCTL","APCDALVR(" S ZTSAVE(%)="" F %="APSPKILL","APSPNEW","APSPREF" S ZTSAVE(%)="" ;IHS/DSD/ENM/POC 02/3/98 S ZTRTN="ZTSK^APSPCCE",ZTDESC="EDIT PRESCRIPTION LINK TO PCC FROM PHARMACY",ZTIO="",ZTDTH=DT D ^%ZTLOAD K ZTSK K APSRX,APSRX0,APSRCT,APSRCT0,APSL,APSRCTL,ZTRTN,ZTDESC,ZTIO,ZTDTH Q ; SETALVR1 ; SET UP APCDALVR FOR ORIGINAL RX S APSED=$P(^PSRX(APSRX,0),U,13) G SETALVRC SETALVR2 ; SET UP APCDALVR FOR REFILL S APSED=$P(^PSRX(APSRX,1,APSRCT,0),U,1) G SETALVRC SETALVRC ; S APSDFN=$S($D(PSDFN):1,1:0) ;IHS/OHPRD/JCM 6/18/90 S PSDFN=$P(^PSRX(APSRX,0),U,2) ;IHS/OHPRD/JCM 6/18/90 D ^APSPCCV S APCDALVR("APCDPAT")=PSDFN S APSEDI=9999999-$P(APSED,".",1)-1_".99999" ;IHS/OHPRD/JCM 6/16/89 S APSEDI=$O(^AUPNVSIT("AA",PSDFN,APSEDI)) S APSEDI=9999999-$P(APSEDI,".",1)_"."_$P(APSEDI,".",2) ;IHS/OHPRD/JCM 5/25/89 I $P(APSEDI,".",1)=$P(APSED,".",1) S APSED=APSEDI S:$P(APSED,".",2)="" APSED=+APSED_".12" S APCDALVR("APCDDATE")=APSED K:'APSDFN PSDFN K APSDFN,APSED,APSEDI Q ; ZTSK ; TASKMAN ENTRY POINT (IN BACKGROUND) D ^APSPCCLQ ; HANG IN QUEUE EDIT ;D EDITRX:APSL,EDITREF:APSRCT ;IHS/DSD/ENM/POC 02/05/98 ;IHS/DSD/ENM/POC 02/05/98 NX TWO LINES ADDED I APSL,'APSPNEW D EDITRX ;RX WITH NO CALL TO APSPCCN I APSRCT,'APSPREF D EDITREF ;REFILL W NO CALL TO APSPCCR AND NOT DELETED I '$D(Y) D K^APSPCCLQ S:$D(ZTQUEUED) ZTREQ="@" ZTSKX K %,APSRX,APSRX0,APSRCT,APSRCT0,APSL,APSRCTL Q ; EDITRX K DIE,DR S DIE="^AUPNVMED(",DA=APSL S %=APSRX0 S DR=".01///`"_$P(%,U,6) ;S APCDALVR("APCDTRX")="`"_$P(%,U,6) ; NEED TO CHECK IF VISIT CHANGED S APSX=$P(%,U,10),APSS=$S($L(APSX)<33:APSX,1:$E(APSX,1,31)_"~") S DR=DR_";.05///"_APSS K APSX,APSS S DR=DR_";.06///"_(+$P(%,U,7)\1) ;IHS/OHPRD/JCM 6/16/89 S DR=DR_";.07///"_+$P(%,U,8) ;IHS/DSD/ENM/POC 03/02/98 NEXT 3 LINES CK FOR PROV @ 200 OR 16 S APSPPROV=$P(%,U,4) S APSPPROV=$S($P(^DD(9000010.14,1202,0),"^",3)="DIC(6,":$P(^VA(200,APSPPROV,0),"^",16),1:APSPPROV) S DR=DR_";1202////"_APSPPROV ;S APC("PRV")=$P(%,U,4) ;IHS/DSD/ENM 01/02/98 ;S APSPDOC1=$P($G(^VA(200,APC("PRV"),0)),U,16),APCDALVR("P")=$S($P($G(^AUTTSITE(1,0)),U,22):APC("PRV"),1:APSPDOC1) ;IHS/DSD/ENM 01/02/98 ;S DR=DR_";.09////"_APCDALVR("P") ;IHS/OHPRD/JCM 01/02/98 ;S DR=DR_";.09////"_$P(%,U,4) ;IHS/OHPRD/JCM 10/10/89 D CHKDC I APSDC S DR=DR_";.08////"_APSDCDT K APSDC,APSDCDT S:$D(^APSPCCTM) (^APSPCCTM,APSPCCTM)=^APSPCCTM+1,^APSPCCTM(APSPCCTM,1)=$H_"^D" DIE1 D ^DIE K DIE,DR I $D(APSPCCTM) S ^APSPCCTM(APSPCCTM,2)=$H K APSPCCTM D:$D(Y) RXERR Q ; CHKDC ; CHECK FOR DISCONTINUED RX S APSDC=0 S APSI=0 F APSQ=0:0 S APSI=$O(^PSRX(APSRX,"A",1,APSI)) Q:APSI="" S APSCOM=$P(^(APSI),U,5) I (APSCOM["CANCELLED")!(APSCOM["DISCONTINUED")!(APSCOM?.E1P1"DC"1P.E) S APSDC=1,APSDCDT=+^(APSI) Q K APSI,APSQ,APSCOM Q ; EDITREF K DIE,DR S DIE="^AUPNVMED(",DA=APSRCTL S %=APSRX0 S DR=".01///`"_$P(%,U,6) ;S APCDALVR("APCDTRX")="`"_$P(%,U,6) ; NEED TO CHECK IF VISIT CHANGED S X=$P(%,U,10),DR=DR_";.05///"_$S($L(X)<33:X,1:$E(X,1,31)_"~") S APSQTY=+$P(%,U,7)\1 ;IHS/OHPRD/JCM 6/16/89 S APSDAY=$P(%,U,8) ; S %=APSRCT0 S DR=DR_";.07///"_((APSDAY*($P(%,U,4)/APSQTY))+.5\1) S DR=DR_";.06///"_(+$P(%,U,4)\1) ;IHS/OHPRD/JCM 6/16/89 ;IHS/DSD/ENM/POC 03/02/98 NEXT 3 LINES GET PROV FOR REFILLS S APSPDOC=$P(^PSRX(APSRX,1,APSRCT,0),"^",17) ;S APSPDOC=$S($P(^DD(9000010.14,1202,0),"^",3)="DIC(6,":$P(^VA(200,APSPDOC,0),"^",16),1:X) S APSPDOC=$S($P(^DD(9000010.14,1202,0),"^",3)="DIC(6,":$P(^VA(200,APSPDOC,0),"^",16),1:APSPDOC) S DR=DR_";1202////"_APSPDOC K APSDAY,APSQTY ; S:$D(^APSPCCTM) (^APSPCCTM,APSPCCTM)=^APSPCCTM+1,^APSPCCTM(APSPCCTM,1)=$H_"^D" DIE2 D ^DIE K DIE,DR I $D(APSPCCTM) S ^APSPCCTM(APSPCCTM,2)=$H K APSPCCTM D:$D(Y) REFERR Q ; RXERR S APSBR="" G LBULL REFERR S APSBR=" (refill #"_APSRCT_")" G LBULL ; LBULL ; SEND BULLETIN - LINK FAILURE K XMB S XMB(1)=+^PSRX(APSRX,0)_APSBR S APSPAT=$P(^PSRX(APSRX,0),U,2) S XMB(2)=$P(^DPT(APSPAT,0),U,1)_" (DFN "_APSPAT_")" S XMB(3)="edited" S Y=DT X ^DD("DD") S XMB(4)=Y S XMB(5)="Edit" S XMB="APSP ED FAIL" S APSDUZ=DUZ,DUZ=.5 D ^XMB S DUZ=APSDUZ K XMB,APSDUZ,APSBR,APSPAT S Y=-1 Q VR1 ;IHS/DSD/ENM/POC 03/02/98 NEW SUB ROUTINE S APSERDOC=$P(^PSRX(APSRX,0),U,4) S APSERDOC=$S($P(^DD(9000010.14,1202,0),"^",3)="DIC(6,":$P(^VA(200,APSERDOC,0),U,16),1:APSERDOC) S APCDALVR("APCDTPRV")=APSERDOC Q VR2 ;IHS/DSD/ENM/POC 03/02/98 NEW SUB ROUTINE S APSEFDOC=$P(^PSRX(APSRX,1,APSRCT,0),U,17) S APSEFDOC=$S($P(^DD(9000010.14,1202,0),"^",3)="DIC(6,":$P(^VA(200,APSEFDOC,0),U,16),1:APSEFDOC) S APCDALVR("APCDTPRV")=APSEFDOC Q APSPCP1 APSPCP1 ; IHS/DSD/ENM - CHRONIC MED PROFILE ; [ 09/22/1999 7:51 AM ] ;;6.0;IHS PHARMACY MODIFICATIONS;**2**;09/03/97 ;This routine is a modified version of PSOZCP created by ENM ;All calls to Utility are now set to TMP ;THIS ROUTINE PRINTS A SUMMARY PROFILE OF ALL CURRENT CHRONIC ;MEDICATIONS TO PUT IN THE PATIENT'S CHART ;This routine is called by 'APSP CHRONIC MED PROFILE' Option ; ;INPUT VARIABLES- DFN ;OUTPUT VARIABLES- DA,DFN,DOB,DT,I,ISDZ,J,LRXD,PSZNAME,RFZ,RXNZ,SIG ;TMP("PSOZCP"),X,X1,X2,PSOZCP("PAGE"),^TMP("PSOZCP",$J,DFN) ;%ZIS,DIC,DIC(0) ; ;EXTERNAL CALLS- C^%DTC,^%ZIS,^DIC,^%ZTLOAD,^TMP("PSOZCP",$J) K DFN S DFN="",APSPCNT=0 ;IHS/DSD/ENM 08/05/99 S APSP("XSTAT")="" ;IHS/DSD/ENM 02/12/99 D FMTO I $D(PSOZCP("FLG")) G EXIT1 ;IHS/DSD/ENM 02/05/99 S APSPASS=1 ;IHS/DSD/ENM 02/05/99 ;K DFN,^TMP("PSOZCP",$J) ;IHS/DSD/ENM 08/05/99 ;IHS/DSD/ENM 08/05/99 NEXT LINE COPIED/MODIFIED ;S PSOZCP="" F I=0:0 S DIC="^AUPNPAT(",DIC(0)="QEAM" D ^DIC Q:Y<0 S DFN=+Y S:$D(^PS(55,DFN,"P","CP")) ^TMP("PSOZCP",$J,DFN)="" W:'$D(^PS(55,DFN,"P","CP")) !,?20,*7,"PATIENT DOES NOT HAVE ANY CHRONIC MEDICATIONS" S PSOZCP="" F I=0:0 S DIC="^AUPNPAT(",DIC(0)="QEAM" D ^DIC Q:Y<0 S DFN=+Y,APSPCNT=APSPCNT+1 S:$D(^PS(55,DFN,"P","CP")) APSP1(DFN)="",ZTSAVE("APSP1(")="" W:'$D(^PS(55,DFN,"P","CP")) !,?20,*7,"PATIENT DOES NOT HAVE ANY CHRONIC MEDICATIONS" ;G:'$D(^TMP("PSOZCP",$J)) EXIT1 ;G:'$D(APSP1(DFN)) EXIT1 G:APSPCNT'>0 EXIT1 ;IHS/DSD/ENM 08/24/99 ; INIT ;ENTRY POINT IF DFN ALREADY DEFINED D COPIES ; Asks number of copies D:$G(APSPASS)'=1 FMTO ;IHS/DSD/ENM 02/05/99 ASK FOR NUMBER OF DAYS I $D(PSOZCP("FLG")) G EXIT1 ;IHS/DSD/ENM 08/05/99 ;S:'$D(^TMP("PSOZCP",$J)) ^TMP("PSOZCP",$J,DFN)="" S:'$D(APSP1(DFN)) APSP1(DFN)="" ;IHS/DSD/ENM 08/05/99 S %ZIS="QM" S %ZIS("A")="Please enter PROFILE device: " D ^%ZIS I POP G EXIT1 I $D(IO("Q")),IO=IO(0) W !!,"Sorry, you cannot queue to your screen or to a slave printer.",! K IO("Q") D ^%ZISC G INIT I IO=IO(0)!('$D(IO("Q"))) G EN ;S ZTRTN="EN^APSPCP1",ZTIO=ION,ZTSAVE("^TMP(""PSOZCP"",$J,")="" S ZTRTN="EN^APSPCP1",ZTIO=ION S ZTSAVE("PSOZCP(""COPIES"")")="",ZTSAVE("%APSITE")="",ZTSAVE("PSOSITE")="" ;IHS/DSD/ENM 09/02/96 %APSITE,PSOSITE SAVED ;S ZTSAVE("APSPBD")="",ZTSAVE("APSPED")="",ZTSAVE("APSP(""LAST FILL"")")="",ZTSAVE("APSP(""XSTAT"")")="" ;IHS/DSD/ENM 02/05/99 S ZTSAVE("APSPBD")="",ZTSAVE("APSPED")="",ZTSAVE("APSP(""XSTAT"")")="" ;IHS/DSD/ENM 02/05/99 S ZTDESC="CHRONIC MEDICATION PROFILE" D ^%ZTLOAD G EXIT ; FMTO ;EP ;------------------------------------------------------------------- ;IHS/DSD/ENM 02/08/99 CHRONIC MED DATE SET ;IHS/DSD/LWJ 09/10/99 V6.0,patch 2 - if the user enters the program ; from other than the main pharmacy menu we need to prompt for the div, ; days for report..nxt line of code added I '$D(PSOPAR) D ^PSOLSET S PSOZCP("DAYS")=PSOZZCP("DAYS") G CMEDXA ;/IHS/DSD/LWJ 09/10/99 S PSOZCP("DAYS")="" K PSOZP("FLG"),DIRUT,DTOUT S DIR(0)="NO^1:999:0" S DIR("B")=90,DIR("A")="Number of Days For Chronic Med Profile" D ^DIR I $D(DIRUT)!($D(DTOUT)) S PSOZCP("FLG")="" G CMEDX S PSOZCP("DAYS")=$S(+Y>0:+Y,1:90) CMEDXA S X1=DT,X2=-PSOZCP("DAYS") D C^%DTC S APSPBD=X-1_".2359",APSPED=DT_".2359" ;IHS/DSD/LWJ 9/10/99 label added to line CMEDX Q ;--------------------------------------------------------------------- EN ; I $G(PSOSITE)]"" S APSPZITE=$P(^PS(59,PSOSITE,0),"^") ;IHS/DSD/ENM 09/06/96 F PSOZCP("I")=1:1:PSOZCP("COPIES") D PATIENT D EXIT Q ; PATIENT ; S (DX,DY)=1 X:$D(^%ZOSF("XY"))#2 ^("XY") U IO S DA="" K ^TMP("PSOZCP",$J) ;IHS/DSD/ENM 08/05/99 D GETMP K APSPTDFN ;IHS/DSD/ENM 08/05/99 F I=0:0 S DA=$O(^TMP("PSOZCP",$J,DA)) Q:DA'=+DA D START W:$E(IOST,1,2)="P-" @IOF I PSOZCP("I")=PSOZCP("COPIES"),$D(ZTQUEUED) S ZTREQ="@" Q GETMP ;CREATE TMP DATA - NEW MODULE IHS/DSD/ENM 08/05/99 S APSPTDFN=0 F S APSPTDFN=$O(APSP1(APSPTDFN)) Q:'APSPTDFN S ^TMP("PSOZCP",$J,APSPTDFN)="" Q EXIT ; D ^%ZISC EXIT1 K SIG,DA,DFN,DOB,I,ISDZ,J,LRXD,PSZNAME,RFZ,RXNZ,TMP,DIC K PSOZCP,X,POP,IO("Q"),%ZIS,ZTSAVE,ZTRTN,ZTDESC,ZTIO,ZTSK,Y K ^TMP("PSOZCP",$J),DX,DY,APSPBD,APSPED,APSPASS,APSP("LAST FILL"),APSP("XSTAT"),APSPTDFN ;IHS/DSD/ENM 02/05/99 ;IHS/DSD/LWJ 09/10/99 V6.0 patch 2- variable clean up- next line added K APSP1,AGE,APSPCNT,APSPZITE ;IHS/DSD/LWJ 09/10/99 Q START ; K TMP("PSOZCP") S PSOZCP("PAGE")=0 D HEADER ; ;PRESCRIPTION DFN NUMBER S J="" F I=0:0 S J=$O(^PS(55,DA,"P","CP",J)) Q:J'=+J D BUILD ; ;START OF PRINTING I $D(TMP("PSOZCP"))>0 D PRINT Q BUILD ; ;BUILDS PRESCRIPTION DATA ; IHS/DSD/LWJ 9/21/99 - eliminate the cross reference if the ; prescription no longer exists - added next line of code I (('$D(^PSRX(J,0)))&('$D(^PSRX(J,3)))) K ^PS(55,DA,"P","CP",J) G ENDBLD ; IHS/DSD/LWJ 9/21/99 I $D(^PSRX(J,0)),$D(^PSRX(J,3)) S APSP("LAST FILL")=$P(^PSRX(J,3),"^",1) ;IHS/DSD/ENM 02/05/99 Q:APSP("LAST FILL")APSPED) ;IHS/DSD/ENM 02/05/99 I $D(^PSRX(J,0)) S APSP("XSTAT")=$P(^PSRX(J,0),"^",15) ;IHS/DSD/ENM 02/11/99 Q:APSP("XSTAT")=13 ;IHS/DSD/ENM 05/12/99 DELETED STATUS CHECK Q:APSP("XSTAT")=12 ;IHS/DSD/ENM 06/14/99 CANCELLED STATUS CHECK I $D(^PSRX(J,0)),$D(^PSDRUG(+$P(^(0),"^",6),0)) S TMP("PSOZCP",$P(^(0),"^",1))=J_"^"_^PSRX(J,0) ; ENDBLD Q ;IHS/DSD/LWJ/9/21/99 label added to the line PRINT ; S PSZNAME=0 F I=0:0 S PSZNAME=$O(TMP("PSOZCP",PSZNAME)) Q:PSZNAME="" D PRINT1 I $E(IOST,1,2)'="P-",$Y+6>IOSL S DIR(0)="E" D ^DIR Q:X="^"!($D(DTOUT)) W @IOF Q PRINT1 ; I $E(IOST,1,2)="P-",$Y+6>IOSL W @IOF D HEADER I $E(IOST,1,2)="C-",$Y+6>IOSL W @IOF D HEADER ;IHS/DSD/ENM 09/05/96 S RXNZ=$P(TMP("PSOZCP",PSZNAME),"^",2) ;SETS PRESCRIPTION(RX) NUMBER W !?60,"| | | |" W !,RXNZ W ?8,PSZNAME ;DRUG NAME AND STRENGTH W ?42,$P(TMP("PSOZCP",PSZNAME),"^",8) ;QUANTITY S LRXD=^PSRX($P(TMP("PSOZCP",PSZNAME),"^",1),3) ;SETS LAST ISSUE DATE W ?50,$E(LRXD,4,5),"-",$E(LRXD,6,7),"-",$E(LRXD,2,3)," " F I=1:1:3 W "|_____" W "|" ; ;W !,?10,$P(TMP("PSOZCP",PSZNAME),"^",11) ;SIG S SIG="" S X=$P(TMP("PSOZCP",PSZNAME),"^",11) D:X]"" ^APSPCP W !,?10,SIG I $D(^PSRX($P(TMP("PSOZCP",PSZNAME),"^",1),1,0)) W !,"FILLED: " D FILL ;CHECKS FOR REFILLS Q FILL ; S ISDZ=$P(TMP("PSOZCP",PSZNAME),"^",14) ;SETS ORIGINAL ISSUE DATE W $E(ISDZ,4,5),"-",$E(ISDZ,6,7),"-",$E(ISDZ,2,3) F RFZ=0:0 S RFZ=$O(^PSRX($P(TMP("PSOZCP",PSZNAME),"^",1),1,RFZ)) Q:'RFZ W " ",$E(^(RFZ,0),4,5),"-",$E(^(0),6,7),"-",$E(^(0),2,3) ;IHS/DSD/ENM 05/24/96 $O ADDED Q ; HEADER ;HEADER S PSOZCP("PAGE")=PSOZCP("PAGE")+1 W !!!!,?27,"CHRONIC MEDICATION PROFILE" W ?60,"DATE : ",$E(DT,4,5),"-",$E(DT,6,7),"-",$E(DT,2,3) W !,?27,"SITE: ",APSPZITE ;IHS/DSD/ENM 09/06/96 W !!,$P(^DPT(DA,0),"^",1) ;PATIENTS NAME W ?40,"CHART # ",$P(^AUPNPAT(DA,41,DUZ(2),0),"^",2) ;CHART NO. W ?70,"Page ",PSOZCP("PAGE") S DOB=$S($L(+$P(^DPT(DA,0),"^",3)):+$P(^DPT(DA,0),"^",3),1:"") ;DATE OF BIRTH W !,?40,"DOB: ",$S(DOB:$E(DOB,4,5)_"-"_$E(DOB,6,7)_"-"_$E(DOB,2,3),1:"UNKNOWN") D GMR ;GET ALLERGY DATA W !!,"RX# DRUG",?42,"QTY",?50,"LAST FILLED",!! Q ; COPIES ; K PSOZP("FLG"),DIRUT,DTOUT S DIR(0)="NO^1:10:0" S DIR("B")=1,DIR("A")="Number of Chronic Med Profile copies" D ^DIR K DIR ;IHS/DSD/ENM 08/02/96 I $D(DIRUT)!($D(DTOUT)) S PSOZCP("FLG")="" G COPIESX S PSOZCP("COPIES")=$S(+Y>0:+Y,1:1) COPIESX ; Q ;GET ALLERGY INFORMATION IHS/DSD/ENM 4.25.95 GMR X "N X S X=""GMRADPT"" X ^%ZOSF(""TEST"") Q" I $T D:'$D(PSOPTPST) GMRA Q K SC,I1,VAROOT,Y,AL,I,X,Y,PSCNT,PSLC,PSDIS Q GMRA W !,"REACTIONS: " D ^GMRADPT S I1=0 F I=0:0 S I=$O(GMRAL(I)) Q:I'>0 W:I1 ", " S AL=$P(GMRAL(I),"^",2) W:$X+$L(AL)>75 !?5 W AL S I1=1 K GMRA,GMRAL Q APSPCP2 APSPCP2 ;IHS/OHPRD/JCM - CHRONIC MED PROFILE; [ 09/23/1999 9:49 AM ] ;;6.0;IHS PHARMACY MODIFICATIONS;**2**;09/03/97 ;THIS ROUTINE PRINTS A SUMMARY PROFILE OF ALL CURRENT CHRONIC ;MEDICATIONS TO PUT IN THE PATIENT'S CHART ;This routine is called by APSPNE4, APSPCP1 is called by option ; ;INPUT VARIABLES- DFN ;OUTPUT VARIABLES- DA,DFN,DOB,DT,I,ISDZ,J,LRXD,PSZNAME,RFZ,RXNZ,SIG ;TMP("PSOZCP"),X,X1,X2,PSOZCP("PAGE"),^TMP("PSOZCP",$J,DFN) ;%ZIS,DIC,DIC(0) ; ;EXTERNAL CALLS- C^%DTC,^%ZIS,^DIC,^%ZTLOAD,^TMP("PSOZCP",$J) ; ;Gets DFN and checks for CP's in Pharm Pat file ;K DFN,^TMP("PSOZCP",$J) K DFN ;IHS/DSD/ENM 08/06/99 ;IHS/DSD/ENM 07/30/90 ;S PSOZCP="" F I=0:0 S DIC="^AUPNPAT(",DIC(0)="QEAM" D ^DIC Q:Y<0 S DFN=+Y S:$D(^PS(55,DFN,"P","CP")) ^TMP("PSOZCP",$J,DFN)="" W:'$D(^PS(55,DFN,"P","CP")) !,?20,*7,"PATIENT DOES NOT HAVE ANY CHRONIC MEDICATIONS" S PSOZCP="" F I=0:0 S DIC="^AUPNPAT(",DIC(0)="QEAM" D ^DIC Q:Y<0 S DFN=+Y S:$D(^PS(55,DFN,"P","CP")) APSP1(DFN)="",ZTSAVE("APSP1(")="" W:'$D(^PS(55,DFN,"P","CP")) !,?20,*7,"PATIENT DOES NOT HAVE ANY CHRONIC MEDICATIONS" ;G:'$D(^TMP("PSOZCP",$J)) EXIT1 G:'$D(APSP1(DFN)) EXIT1 ; INIT ;ENTRY POINT IF DFN ALREADY DEFINED ;NOTE: THIS EP IS CALLED BY CPCK^APSPNE4+1 ;D:PSOZCP("COPIES")']"" COPIES ; Asks number of copies S APSP("XSTAT")="" D FMTO ;IHS/DSD/ENM 02/08/99 I $D(PSOZCP("FLG")) G EXIT1 ;S:'$D(^TMP("PSOZCP",$J)) ^TMP("PSOZCPP",$J,DFN)="" S:'$D(APSP1(DFN)) APSP1(DFN)="" ;IHS/DSD/ENM 08/06/99 S %ZIS="QM" S %ZIS("A")="Please enter PROFILE device: " D ^%ZIS I POP G EXIT1 I $D(IO("Q")),IO=IO(0) W !!,"Sorry, you cannot queue to your screen or to a slave printer.",! K IO("Q") D ^%ZISC G INIT I IO=IO(0)!('$D(IO("Q"))) G EN ;S ZTRTN="EN^APSPCP2",ZTIO=ION,ZTSAVE("^TMP(""PSOZCP"",$J,")="" S ZTRTN="EN^APSPCP2",ZTIO=ION ;IHS/DSD/ENM 06/14/99 ;S ZTSAVE("PSOZCP(""COPIES"")")="" ;S ZTSAVE("APSPBD")="",ZTSAVE("APSPED")="",ZTSAVE("APSP(""LAST FILL"")")="",ZTSAVE("APSP(""XSTAT"")")="" ;F G="PSOZCP(""COPIES"")","APSPBD","APSPED","APSP(""LAST FILL"")","APSP(""XSTAT"")","^TMP(""PSOZCP"",$J," S:$D(@G) ZTSAVE(G)="" ;IHS/DSD/ENM 06/14/99 ;IHS/DSD/LWJ 9/22/99 - next line remarked out, line following added ; this was done to correct an error in the queuing process ;F G="PSOZCP(""COPIES"")","APSPBD","APSPED","APSP(""LAST FILL"")","APSP(""XSTAT"")" S ZTSAVE(G)="" ;IHS/DSD/ENM 06/14/99 F G="PSOZCP(""COPIES"")","APSPBD","APSPED","APSP(","APSP1(","PSOSITE" S ZTSAVE(G)="" ;IHS/DSD/LWJ 9/22/99 - changed APSP to be an open array reference, added PSOSITE and APSP1 open array S ZTDESC="CHRONIC MEDICATION PROFILE" D ^%ZTLOAD G EXIT FMTO ;EP ;------------------------------------------------------------------- ;IHS/DSD/ENM 02/08/99 CHRONIC MED DATE SET ;S PSOZCP("DAYS")="" ;K PSOZP("FLG"),DIRUT,DTOUT ;S DIR(0)="NO^1:999:0" ;S DIR("B")=180,DIR("A")="Number of Days For Chronic Med Profile" ;D ^DIR ;I $D(DIRUT)!($D(DTOUT)) S PSOZCP("FLG")="" G CMEDX ;S PSOZCP("DAYS")=$S(+Y>0:+Y,1:180) ;PSOZZCP("DAYS") IS SET IN PSOLSET S X1=DT,X2=-PSOZZCP("DAYS") D C^%DTC S APSPBD=X-1_".2359",APSPED=DT_".2359" CMEDX Q EMPRT ;EP CALLED BY CPCK^APSPNE4+2 ;IHS/DSD/ENM 10/24/94 NON-QUEUE PRINT MODULE S:'$D(^TMP("PSOZCP",$J)) ^TMP("PSOZCP",$J,DFN)="" D FMTO ;IHS/DSD/ENM 08/04/99 GET FM/TO DATE I $G(APSPCPP)']"" W ! K POP,ZTSK S %ZIS="M",%ZIS("A")="Enter Profile Device: " D ^%ZIS K %ZIS("A") G:POP EXIT S APSPCPP=ION S IOP=APSPCPP D ^%ZIS G:POP EXIT EN ; I $G(PSOSITE)]"" S APSPZITE=$P(^PS(59,PSOSITE,0),"^") ;IHS/DSD/ENM 09/06/96 F PSOZCP("I")=1:1:PSOZCP("COPIES") D PATIENT D EXIT Q ; PATIENT ; S (DX,DY)=1 X:$D(^%ZOSF("XY"))#2 ^("XY") U IO S DA="" D GETMP K APSPTDFN ;IHS/DSD/ENM 07/30/99 F I=0:0 S DA=$O(^TMP("PSOZCP",$J,DA)) Q:DA'=+DA D START W:$E(IOST,1,2)="P-" @IOF I PSOZCP("I")=PSOZCP("COPIES"),$D(ZTSK) K ZTSK,IO("Q") ;IHS/DSD/ENM 01/09/97 Q GETMP ;CREATE TMP DATA - NEW MODULE 07/30/99 S APSPTDFN=0 F S APSPTDFN=$O(APSP1(APSPTDFN)) Q:'APSPTDFN S ^TMP("PSOZCP",$J,APSPTDFN)="" Q EXIT ; D ^%ZISC EXIT1 K SIG,DA,DFN,DOB,I,ISDZ,J,LRXD,PSZNAME,RFZ,RXNZ,TMP,DIC K PSOZCP,X,POP,IO("Q"),ZTSAVE,ZTRTN,ZTDESC,ZTIO,ZTSK,Y K ^TMP("PSOZCP",$J),DX,DY,APSPBD,APSPED,APSPASS,APSP("LAST FILL"),APSP("XSTAT"),APSPTDFN ;IHS/DSD/ENM 02/08/99 Q START ; K TMP("PSOZCP") S PSOZCP("PAGE")=0 D HEADER ; ;PRESCRIPTION DFN NUMBER S J="" F I=0:0 S J=$O(^PS(55,DA,"P","CP",J)) Q:J'=+J D BUILD ; ;START OF PRINTING I $D(TMP("PSOZCP"))>0 D PRINT Q BUILD ; ;BUILDS PRESCRIPTION DATA ;IHS/DSD/LWJ 9/21/99 - eliminate the cross reference if the ;prescription no longer exists - added next line of code I (('$D(^PSRX(J,0)))&('$D(^PSRX(J,3)))) K ^PS(55,DA,"P","CP",J) G ENDBLD ;IHS/DSD/LWJ 9/21/99 I $D(^PSRX(J,0)),$D(^PSRX(J,3)) S APSP("LAST FILL")=$P(^PSRX(J,3),"^",1) ;IHS/DSD/ENM 02/08/99 Q:APSP("LAST FILL")APSPED) ;IHS/DSD/ENM 02/08/99 I $D(^PSRX(J,0)) S APSP("XSTAT")=$P(^PSRX(J,0),"^",15) ;IHS/DSD/ENM 02/11/99 Q:APSP("XSTAT")=13 ;IHS/DSD/ENM 05/12/99 STATUS CHECK Q:APSP("XSTAT")=12 ;IHS/DSD/ENM 06/14/99 STATUS CHECK I $D(^PSRX(J,0)),$D(^PSDRUG(+$P(^(0),"^",6),0)) S TMP("PSOZCP",$P(^(0),"^",1))=J_"^"_^PSRX(J,0) ; ENDBLD Q ;IHS/DSD/LWJ 9/21/99 label added to the quit line PRINT ; S PSZNAME=0 ;IHS/DSD/ENM 01/13/97 DIR ADDED TO NEXT LINE F I=0:0 S PSZNAME=$O(TMP("PSOZCP",PSZNAME)) Q:PSZNAME="" D PRINT1 I $Y+4>IOSL,IOST["C-" S DIR("A")="ENTER '^' TO HALT",DIR(0)="FO" D ^DIR Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT)) W @IOF Q PRINT1 ; I $E(IOST,1,2)="P-",$Y+6>IOSL W @IOF D HEADER S RXNZ=$P(TMP("PSOZCP",PSZNAME),"^",2) ;SETS PRESCRIPTION(RX) NUMBER W !?60,"| | | |" W !,RXNZ W ?8,PSZNAME ;DRUG NAME AND STRENGTH W ?42,$P(TMP("PSOZCP",PSZNAME),"^",8) ;QUANTITY S LRXD=^PSRX($P(TMP("PSOZCP",PSZNAME),"^",1),3) ;SETS LAST ISSUE DATE W ?50,$E(LRXD,4,5),"-",$E(LRXD,6,7),"-",$E(LRXD,2,3)," " F I=1:1:3 W "|_____" W "|" ; ;W !,?10,$P(TMP("PSOZCP",PSZNAME),"^",11) ;SIG ;S SIG="" S X=$P(TMP("PSOZCP",PSZNAME),"^",11) X:X]"" ^DD(52,10,9.2) S SIG="" S X=$P(TMP("PSOZCP",PSZNAME),"^",11) D:X]"" ^APSPSIG W !,?10,SIG I $D(^PSRX($P(TMP("PSOZCP",PSZNAME),"^",1),1,0)) W !,"FILLED: " D FILL ;CHECKS FOR REFILLS Q FILL ; S ISDZ=$P(TMP("PSOZCP",PSZNAME),"^",14) ;SETS ORIGINAL ISSUE DATE W $E(ISDZ,4,5),"-",$E(ISDZ,6,7),"-",$E(ISDZ,2,3) F RFZ=0:0 S RFZ=$O(^PSRX($P(TMP("PSOZCP",PSZNAME),"^",1),1,RFZ)) Q:'RFZ W " ",$E(^(RFZ,0),4,5),"-",$E(^(0),6,7),"-",$E(^(0),2,3) Q ; HEADER ;HEADER S PSOZCP("PAGE")=PSOZCP("PAGE")+1 W !!!!,?27,"CHRONIC MEDICATION PROFILE" W ?60,"DATE : ",$E(DT,4,5),"-",$E(DT,6,7),"-",$E(DT,2,3) W !,?27,"SITE: ",APSPZITE ;IHS/DSD/ENM 09/06/96 W !!,$P(^DPT(DA,0),"^",1) ;PATIENTS NAME W ?40,"CHART # ",$P(^AUPNPAT(DA,41,DUZ(2),0),"^",2) ;CHART NO. W ?70,"Page ",PSOZCP("PAGE") S DOB=$S($L(+$P(^DPT(DA,0),"^",3)):+$P(^DPT(DA,0),"^",3),1:"") ;DATE OF BIRTH W !,?40,"DOB: ",$S(DOB:$E(DOB,4,5)_"-"_$E(DOB,6,7)_"-"_$E(DOB,2,3),1:"UNKNOWN") ;GET ALLERGY DATA D GMR W !!,"RX# DRUG",?42,"QTY",?50,"LAST FILLED",!! Q ; COPIES ;EP K PSOZP("FLG"),DIRUT,DTOUT S DIR(0)="NO^1:10:0" S DIR("B")=1,DIR("A")="Number of Chronic Med Profile copies" D ^DIR I $D(DIRUT)!($D(DTOUT)) S PSOZCP("FLG")="" G COPIESX S PSOZCP("COPIES")=$S(+Y>0:+Y,1:1) COPIESX ; Q GMR X "N X S X=""GMRADPT"" X ^%ZOSF(""TEST"") Q" I $T D:'$D(PSOPTPST) GMRA Q K SC,I1,VAROOT,Y,AL,I,X,Y,PSCNT,PSLC,PSDIS Q GMRA W !,"REACTIONS: " D ^GMRADPT S I1=0 F I=0:0 S I=$O(GMRAL(I)) Q:I'>0 W:I1 ", " S AL=$P(GMRAL(I),"^",2) W:$X+$L(AL)>75 !?5 W AL S I1=1 K GMRA,GMRAL Q APSPCTR APSPCTR ; IHS/DSD/ENM - CONTROLLED DRUG LIST BY DIV 03-22-93 ; [ 09/08/1999 3:10 PM ] ;;6.0;IHS PHARMACY MODIFICATIONS;**1,2**;09/03/97 EN ;EP K ^TMP("APSP",$J) W @IOF,!!,"Pharmacy Controlled Drug List by Division",!,*7,?10,"132 Character Format!",! ;S %DT("A")="Beginning Date: ",%DT="AEP" D ^%DT S APSPBD=Y_.0001 Q:Y<0 S %DT("A")="Beginning Date: ",%DT="AEP" D ^%DT S APSPBD=Y-1 Q:Y<0 ;IHS/DSD/ENM 07/28/97 ;S %DT("A")="Ending Date: ",%DT("B")="TODAY",%DT="AEP" D ^%DT S APSPED=Y_".2359" Q:Y<0 S %DT("A")="Ending Date: ",%DT("B")="TODAY",%DT="AEP" D ^%DT S APSPED=Y Q:Y<0 ;IHS/DSD/ENM 07/28/97 ;SELECT DIVISION S DIR(0)="Y",DIR("A")="Would you like all divisions",DIR("B")="YES",DIR("?")="Enter 'Yes' or 'No'" D ^DIR K DIR Q:$D(DTOUT) I X="YES" S APSPANS="A" G DDD S DIR(0)="PO^59:EMZ",DIR("A")="Select Division",DIR("?")="Enter the Division Name or Number " D ^DIR G:$D(DTOUT)!$D(DUOUT) ZAP K DIR S APSPANS=+Y DDD ;Select by date/drug S DIR(0)="S^1:DATE;2:DRUG;",DIR("A")="By Date or Drug" D ^DIR K DIR G:$D(DUOUT)!$D(DIRUT) ZAP S APSPDTDR=Y S U="^" D MENU I APSPOP=""!(APSPOP["^") G ZAP S APSPGO=$P($T(MEN+APSPOP),"^",2,3) DEV S %ZIS="QM",%ZIS("A")="Select Printer: " D ^%ZIS K %ZIS I POP G ZAP I $D(IO("Q")),IO=0 W !,"QUEUEING TO YOUR SCREEN IS NOT ALLOW! " K IO("Q") G DEV I IO=IO(0)!('$D(IO("Q"))) G LOOP S ZTRTN="LOOP^APSPCTR" S ZTDESC="Control Drug List" F X="ZTDESC","U","APSPBD","APSPED","APSPGO","APSPANS","APSPDTDR" S ZTSAVE(X)="" D ^%ZTLOAD G ZAP MENU F APSPZZ=1:1 D MENU1 Q:APSPDES="" S APSPITM=APSPZZ-1 MENU2 ;R !!,"Enter the Option Number: ",APSPOP:DTIME ;IHS/DSD/ENM 05/24/96 S DIR("A")="Enter the Option Number",DIR(0)="S^1:C-2'S;2:C-3'S to C5'S;3:All;" D ^DIR S APSPOP=X ;IHS/DSD/ENM 05/24/96 I '$T!(APSPOP["^")!(APSPOP="") Q I (APSPOP<1)!(APSPOP>APSPITM)!(APSPOP="?") W !!,"Select a '1' for C-2's or '2' for C-3's to C5's...or",!,"Enter ""3"" for 'All'" ;I W !!,?10,"Press Return to Continue...",APSPOP:DTIME G MENU2 ;IHS/DSD/ENM 5/24/96 READ STMT REMOVED Q MENU1 S APSPDES=$P($T(MEN+APSPZZ),";;",2) I APSPDES'="" W !,APSPZZ,$P(APSPDES,"^",1) Q LOOP S (APSPN,APSPX)="" I +APSPANS,APSPDTDR=2 S APSPD=APSPANS-1 G LOOP1 I APSPANS="A" S APSPD=0 G LOOP1 G LOOP2 Q LOOP1 F APSPD=APSPD:0 S APSPD=$O(^PSRX("AD2",APSPD)) Q:'APSPD F APSPX=APSPBD:0 S APSPX=$O(^PSRX("AD2",APSPD,APSPX)) Q:'APSPX!(APSPX>APSPED) F S APSPN=$O(^PSRX("AD2",APSPD,APSPX,APSPN)) Q:'APSPN D .Q:$P($G(^PSRX(APSPN,0)),U,15)=13 ;IHS/DSD/ENM/POC 05/11/98 DELETED .S APSPRX=$P($G(^PSRX(APSPN,0)),U,6) Q:APSPRX="" .S APSPSH=$P($G(^PSDRUG(APSPRX,0)),U,3) D @APSPGO D ^APSPCTR1,ZAP Q LOOP2 ; F APSPX=APSPBD:0 S APSPX=$O(^PSRX("AD2",APSPANS,APSPX)) Q:'APSPX!(APSPX>APSPED) F S APSPN=$O(^PSRX("AD2",APSPANS,APSPX,APSPN)) Q:'APSPN D .Q:$P($G(^PSRX(APSPN,0)),U,15)=13 ;IHS/DSD/ENM/POC 05/11/98 DELETED .S APSPRX=$P($G(^PSRX(APSPN,0)),U,6) Q:APSPRX="" .S APSPSH=$P($G(^PSDRUG(APSPRX,0)),U,3),APSPD=APSPANS D @APSPGO D ^APSPCTR1,ZAP Q C2 ;Search for c-subs C2. S APSPMSG="Special Handling Code ""2"" Drugs" I "2"[+APSPSH D APSPSET Q C3 ;Search for c-subs (C3 to C5) S APSPMSG="Special Handling Code(s) ""3"" to ""5"" Drugs" I "345"[+APSPSH D APSPSET Q C4 ;Search for 'All' c-sub drugs S APSPMSG="Special Handling Code(s) ""2"" to ""5"" Drugs" I "2345"[+APSPSH D APSPSET Q APSPSET ; ;RX DATA S APSPRN=$O(^PSRX("AD2",APSPD,APSPX,APSPN,-1)) ;REFILL NUMBER ;IHS/DSD/ENM/POC 05/21/98 NEXT 2 LINES ADDED I 'APSPRN Q:$P(^PSRX(APSPN,2),U,15)]"" ;ORIGINAL RX RTN TO STOCK ;I APSPRN Q:$P($G(^PSRX(APSPN,1,+APSPRN,0)),U,16)]"" ;REFILL RTN TO STOCK I APSPRN Q:$P(^PSRX(APSPN,1,APSPRN,0),U,16)]"" ;REFILL RTN TO STOCK S APSPRXN=$P(^PSRX(APSPN,0),"^",1) ;RX NUMBER ON FILE I APSPRN>0&(APSPRN'["P") S APSPRXN=APSPRXN_" RF# "_APSPRN I APSPRN>0&(APSPRN["P") S APSPRXN=APSPRXN_" Partial# "_+APSPRN S APSPAT=$P(^PSRX(APSPN,0),"^",2) ;PATIENT NBR FOR PERSON FILE S APSPATN=$P(^DPT(APSPAT,0),"^",1) ;PATIENT NAME S APSPCHN="UNKNOWN" I '$D(DUZ(2)) S DUZ(2)=$O(^DIC(59,0)) I DUZ(2)>0,$D(^(DUZ(2),0)) S DUZ(2)=$P(^(0),"^",6) I DUZ(2)>0,$D(^AUPNPAT(APSPAT,41,DUZ(2),0)) S APSPCHN=$P(^(0),"^",2) I APSPRN=0 S APSPQTY=+$P(^PSRX(APSPN,0),"^",7) ;QTY I APSPRN>0&(APSPRN'["P") S APSPQTY=+$P(^PSRX(APSPN,1,+APSPRN,0),U,4) I APSPRN>0&(APSPRN["P") S APSPQTY=+$P(^PSRX(APSPN,"P",+APSPRN,0),U,4) I APSPRN=0 S APSPCLER=$P(^PSRX(APSPN,0),U,16) ;CLERK CODE I APSPRN>0&(APSPRN'["P") S APSPCLER=$P(^PSRX(APSPN,1,APSPRN,0),U,7) I APSPRN>0&(APSPRN["P") S APSPCLER=$P(^PSRX(APSPN,"P",+APSPRN,0),U,7) S APSPC9=$P($G(^VA(200,APSPCLER,0)),U,2) ;IHS/DSD/ENM 01/09/96 S APSPDIV=APSPD S APSPDRUG=$P(^PSDRUG(APSPRX,0),"^",1) ;DRUG NAME S APSPMD=$P(^VA(200,$P(^PSRX(APSPN,0),"^",4),0),"^",1) ;MD NAME I APSPMD?1.A1",".E S APSPMD=$E(APSPMD,1,$F(APSPMD,","))_"." ;SET ARRAY I APSPDTDR=1 D S1 Q I +APSPANS,APSPDTDR=2 Q:APSPDIV'=APSPANS SS ; S ^TMP("APSP",$J,APSPDIV,APSPRX,+APSPSH,APSPX,APSPN)=APSPATN_U_APSPCHN_U_APSPX_U_APSPDRUG_U_APSPQTY_U_APSPRXN_U_APSPMD_U_APSPC9 ;IHS/DSD/ENM 01/09/96 Q S1 ;SET ARRAY IN DIV/DATE ORD S ^TMP("APSP",$J,APSPDIV,APSPX,+APSPSH,APSPRX,APSPN)=APSPATN_U_APSPCHN_U_APSPX_U_APSPDRUG_U_APSPQTY_U_APSPRXN_U_APSPMD_U_APSPC9 ;IHS/DSD/ENM 01/09/95 Q MEN ;MENU TX AND LINE TAG ;;..........Controlled Drug List (C-2 Only)^C2^APSPCTR ;;..........Controlled Drug List (C-3 to C-5)^C3^APSPCTR ;;..........Controlled Drug List (All)^C4^APSPCTR Q ZAP ;Kill variables K %DT("B"),%DT("A"),APSP("PAGE"),APSPAT,APSPATN,APSPBD,APSPCHN,APSPD,APSPDES,APSPDR,APSPBD,APSPED,APSPX,APSPN,APSPRX,APSPSH,DIC,APSPANS,APSPDTDR K APSPDRUG,APSPED,APSPGO,APSPITM,APSPMD,APSPMSG,APSPOP,APSPQTY,APSPRN,APSPRXN,APSPZZ,APSPBD,^TMP("APSP",$J),APSPCLER,APSPDIV,APSPDV K APSP(2),APSP("3-5"),APSPGT,APSPT(2),APSPT(35),APSPC9 Q APSPDR3 APSPDR3 ;IHS/OHPRD/JCM - PHARMACY DRUG RECALL; [ 10/07/1999 9:11 AM ] ;;6.0;IHS PHARMACY MODIFICATIONS;**1**;09/03/97 ;THIS ROUTINE BUILDS THE PHARMACY DRUG RECALL LIST ;IT RUNS AND THEN CALLS PSOZDR1 TO PRINT THE ACTUAL LIST ;**NOTE** MOD MADE TO EXCLUDE 'RETURN TO STOCK DRUGS' 02/08/96 ;OUTPUT VARIABLES: AD1,AD2,AD3,BD,ED,BDN,CITY,DATE,DRUNAME,HPHONE, ;IRXN,PAT,PATN,PSZCHN,PSZDRUG,QTY,RXN,STATE,STATEN,WPHONE,ZIP,DN ;^TMP("PSOZDR",$J,PAT,DATE,IRXN),^TMP("PSODR",$J, ;I,X,Y ; ;EXTERNAL CALLS: ^%DT,^DIR,^APSPDR4,^%ZTLOAD,^DIC,^%ZIS INIT ; ;K ^TMP("PSOZDR",$J),^TMP("PSODR",$J) K ^TMP("PSOZDR"),^TMP("PSODR") ;IHS/DSD/ENM 05/29/97 W @IOF W !,"Pharmacy Drug Recall List",!! S %DT("A")="PLEASE ENTER BEGINNING DATE: " S %DT="AE" D ^%DT I Y=-1 G EXIT S BD=Y_.0001 S %DT("A")="PLEASE ENTER ENDING DATE: " D ^%DT I Y=-1 G:X="" INIT G EXIT S ED=Y_.2359 LKUP ; K DIC S DIC="^PSDRUG(" S DIC(0)="QEMA" S DIC("A")="SELECT THE DRUG NAME: " D ^DIC I Y=-1 G:X="" INIT G:X="^" EXIT G LKUP S ^TMP("PSODR",$J,+Y)="" QUEST ; S DIR(0)="YO",DIR("A")="Want to Select Another Drug" S DIR("B")="NO" S DIR("?")="Enter a 'Y' or 'YES' to include more drugs in your search." D ^DIR K DIR G:Y=1 LKUP G:$D(DIRUT) EXIT QUE ; W ! S %ZIS="QM" D ^%ZIS I POP G EXIT I $D(IO("Q")),IO=IO(0) W !!,"Sorry, you can't queue to your screen or a slave device.",! K IO("Q") G QUE I IO=IO(0)!('$D(IO("Q"))) G DATE S ZTRTN="DATE^APSPDR3",ZTIO=ION,ZTSAVE("BD")="",ZTSAVE("ED")="" S ZTSAVE("^TMP(""PSODR"",$J,")="",ZTDESC="PHARMACY DRUG RECALL LISTING" D ^%ZTLOAD G EXIT DATE ; ;IHS/DSD/ENM 02/08/96 LOOP ON "ZAL" S (IRXN,APSPNOD,APSPNOD1)="" F DATE=BD:0 S DATE=$O(^PSRX("ZAL",DATE)) Q:DATE=""!(DATE>ED) D .F S IRXN=$O(^PSRX("ZAL",DATE,IRXN)) Q:'IRXN D ..F S APSPNOD=$O(^PSRX("ZAL",DATE,IRXN,APSPNOD)) Q:APSPNOD="" D ...F S APSPNOD1=$O(^PSRX("ZAL",DATE,IRXN,APSPNOD,APSPNOD1)) Q:APSPNOD1="" D CHECK D ^APSPDR4 K:$D(ZTSK) ZTSK ;IHS/DSD/ENM 01/14/97 EXIT ; K PATN,STATEN,^TMP("PSOZDR",$J),BDN,QTY,RXN,IRXN,DRUNAME K PSOZDN,PSZCHN,PSZDRUG,DATE,AD1,AD2,AD3,CITY,STATE,ZIP,HPHONE,WPHONE K PAT,BD,ED,ZTRTN,ZTIO,ZTSAVE("ED"),ZTSAVE("BD"),DN,IO("C"),I,X,Y K ZTSAVE("^TMP(""PSODR"",$J,"),ZTDESC,IO("Q"),%ZIS,POP,ZTIO,ZTSK K DIC,DFOUT,DLOUT,DTOUT,DUOUT,%DT,DIRUT,DIR,APSPNOD,APSPNOD1 Q CHECK ; Q:'$D(^PSRX(IRXN,0)) S DRUNAME=$P($G(^PSRX(IRXN,0)),"^",6) Q:$G(DRUNAME)']"" ;DRUG NUMBER FOR THE DRUG FILE I '$D(^PSDRUG(DRUNAME,0)) Q I $D(^TMP("PSODR",$J,DRUNAME)) D RXN Q RXN ; I $P($G(^PSRX(IRXN,0)),"^",15)=13 Q ;IHS/DSD/ENM 02/09/96 CK FOR CANCELLED I APSPNOD1="N"&($P($G(^PSRX(IRXN,2)),"^",15)]"") Q ;IHS/DSD/ENM 02/08/96 CK RETURN TO STOCK FOR NEW RX ;IHS/DSD/ENM 05/18/98 NEXT 2 LINES COPIED MODIFIED ;I APSPNOD1="R"&($P($G(^PSRX(IRXN,1,APSPNOD,0)),"^",18)]"") Q ;IHS/DSD/ENM 02/08/96 CK RTN TO STOCK FOR REFILL RX ;I APSPNOD1="P"&($P($G(^PSRX(IRXN,"P",APSPNOD,0)),"^",19)]"") Q ;IHS/DSD/ENM 02/08/96 CK RTN TO STOCK FOR PARTIAL I APSPNOD1="R"&($P($G(^PSRX(IRXN,1,APSPNOD,0)),"^",16)]"") Q ;IHS/DSD/ENM 02/08/96 CK RTN TO STOCK FOR REFILL RX I APSPNOD1="P"&($P($G(^PSRX(IRXN,"P",APSPNOD,0)),"^",16)]"") Q ;IHS/DSD/ENM 02/08/96 CK RTN TO STOCK FOR PARTIAL S RXN=$P(^PSRX(IRXN,0),"^",1) ;PRESCRIPTION NUMBER ON FILE S PAT=$P(^PSRX(IRXN,0),"^",2) ;PATIENT NUMBER FOR THE PERSON FILE S PATN=$P(^DPT(PAT,0),"^",1) ;PATIENTS ACTUAL NAME ;PATIENTS ADDRESS S AD1=$S($D(^DPT(PAT,.11)):$P(^DPT(PAT,.11),"^",1),1:"ADDRESS UNKNOWN") S AD2=$S(AD1'["UNKNOWN":$P(^DPT(PAT,.11),"^",2),1:"") S AD3=$S(AD1'["UNKNOWN":$P(^DPT(PAT,.11),"^",3),1:"") S CITY=$S(AD1'["UNKNOWN":$P(^DPT(PAT,.11),"^",4),1:"") S STATEN=$S(AD1'["UNKNOWN":$P(^DPT(PAT,.11),"^",5),1:"") S STATE=$S(AD1'["UNKNOWN":$P(^DIC(5,STATEN,0),"^",2),1:"") S ZIP=$S(AD1'["UNKNOWN":$P(^DPT(PAT,.11),"^",6),1:"") ;PHONE NUMBER S HPHONE="UNKNOWN",WPHONE="UNKNOWN" I $D(^DPT(PAT,.13)) S:$P(^DPT(PAT,.13),"^",1)'="" HPHONE=$P(^DPT(PAT,.13),"^",1) I $D(^DPT(PAT,.13)) S:$P(^DPT(PAT,.13),"^",2)'="" WPHONE=$P(^DPT(PAT,.13),"^",2) S BDN=$P(^DPT(PAT,0),"^",3) ;BIRTH DATE S BDN=$E(BDN,4,5)_"-"_$E(BDN,6,7)_"-"_$E(BDN,2,3) ; ;TO GET PATIENTS CHART NUMBER S PSZCHN="UNKNOWN" I '$D(DUZ(2)) S DUZ(2)=$O(^DIC(59,0)) I DUZ(2)>0,$D(^(DUZ(2),0)) S DUZ(2)=$P(^(0),"^",6) I DUZ(2)>0,$D(^AUPNPAT(PAT,41,DUZ(2),0)) S PSZCHN=$P(^(0),"^",2) ; S QTY=+$P(^PSRX(IRXN,0),"^",7) ;QTY OF MEDICATION ISSUED S PSZDRUG=$P(^PSDRUG(DRUNAME,0),"^",1) ;DRUG NAME ;SET ARRAY S ^TMP("PSOZDR",$J,PAT,DATE,IRXN)=PATN_"^"_PSZCHN_"^"_BDN_"^"_DATE_"^"_PSZDRUG_"^"_QTY_"^"_RXN_"^"_AD1_"^"_AD2_"^"_AD3_"^"_CITY_"^"_STATE_"^"_ZIP_"^"_HPHONE_"^"_WPHONE Q APSPDRX APSPDRX ; IHS/DSD/ENM - DAILY RX LOG 5.13.94 ; [ 08/23/1999 12:37 PM ] ;;6.0;IHS PHARMACY MODIFICATIONS;**2**;09/03/97 EP ;ENTRY POINT INIT ; D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) W !,"No Site Param's Defined!..quitting." Q ;IHS/DSD/ENM 01/28/96 S APSPDIV=$S($D(^PS(59,PSOSITE,0)):$P(^(0),U,6),1:"") ;SITE NBR W @IOF W "Pharmacy Daily Rx Report",!! S %DT("A")="Enter the Start Date: " S %DT="AE" D ^%DT I Y=-1 G EXIT S APSPFD=Y_.0001 S %DT("A")="Ending Date: " S %DT("B")="TODAY",%DT="AEP" D ^%DT I Y=-1 G EXIT S APSPED=Y_.2359 Q:Y<0 ;SELECT DIVISION S DIR(0)="Y",DIR("A")="Would you like all divisions",DIR("B")="YES",DIR("?")="Enter 'Yes' or 'No'" D ^DIR K DIR Q:$D(DTOUT) I X="YES" S APSPANS="A" G ZZ S DIR(0)="PO^59:EMZ",DIR("A")="Select Division",DIR("?")="Enter the Division Name or Number " D ^DIR G:$D(DTOUT)!$D(DUOUT) EXIT K DIR I Y=-1 G EXIT ;IHS/DSD/ENM 01/29/96 S APSPANS=+Y ZZ ;ZIS CALL IHS/DSD/ENM 03/30/99 NEXT 8 LINES MODIFIED K %ZIS,IOP,ZTSK,POP S %ZIS="QM",%ZIS("A")="Select Printer: " D ^%ZIS K %ZIS I POP G EXIT I $D(IO("Q")),IO=0 W !,"QUEUEING TO YOUR SCREEN IS NOT ALLOWED! " K IO("Q") G ZZ I IO=IO(0)!('$D(IO("Q"))) G FST S ZTDESC="DAILY RX REPORT",ZTRTN="FST^APSPDRX" F G="ZTDESC","APSPDIV","PSOSITE","APSPFD","APSPED","APSPANS" S ZTSAVE(G)="" D ^%ZTLOAD W:$D(ZTSK) !,"REPORT QUEUED TO PRINT !",! K ZTSK G EXIT ;K PSOION I $D(IO("Q")) S ZTDESC="DAILY RX REPORT",ZTRTN="FST^APSPDRX" F G="ZTDESC","APSPDIV","PSOSITE","APSPFD","APSPED","APSPANS" S:$D(@G) ZTSAVE(G)="" D ^%ZTLOAD W:$D(ZTSK) !,"REPORT QUEUED TO PRINT !",! K ZTSK G EXIT FST U IO K ^TMP($J,"APSPX") S (APSPG,APSPDT,APSPRN,APSPLN,APSPTY)=0,APSPOUT="" F APSPDT=APSPFD:0 S APSPDT=$O(^PSRX("ZAL",APSPDT)) Q:'APSPDT!(APSPDT>APSPED) D PRT D PRNT W !!,"End of Report" G EXIT PRT ; F S APSPRN=$O(^PSRX("ZAL",APSPDT,+APSPRN)) Q:'APSPRN D PR1 Q PR1 F S APSPLN=$O(^PSRX("ZAL",APSPDT,APSPRN,+APSPLN)) Q:'APSPLN D PR2 Q PR2 F S APSPTY=$O(^PSRX("ZAL",APSPDT,APSPRN,APSPLN,APSPTY)) Q:APSPTY="" D DSET Q DSET ; S APSPRX=$P($G(^PSRX(APSPRN,0)),U),APSPDFN=$P($G(^(0)),U,2),APSPDG=$P($G(^(0)),U,6) ;S APSPN=$P($G(^DPT(APSPDFN,0)),U),APSPDRG=$P($G(^PSDRUG(APSPDG,0)),U),APSPCN=$P($G(^AUPNPAT(APSPDFN,41,APSP("DIV"),0)),U,2) S APSPN=$P($G(^DPT(APSPDFN,0)),U),APSPDRG=$P($G(^PSDRUG(APSPDG,0)),U) I APSPTY="N" D NRX Q I APSPTY="R" D RRX Q I APSPTY="P" D PRX Q Q NRX ;GRAB NEW RX DATA S APSPD=$P($G(^PSRX(APSPRN,0)),U,4),APSPQ=$P($G(^(0)),U,7),APSPP=$P($G(^VA(200,APSPD,0)),U),APSP("DIV")=$P($G(^PSRX(APSPRN,2)),U,9) S APSP("D")=$P($G(^PS(59,APSP("DIV"),0)),U,6) S APSPCN=$P($G(^AUPNPAT(APSPDFN,41,APSP("D"),0)),U,2) I APSPANS="A" S ^TMP($J,"APSPX",APSP("DIV"),APSPDT,APSPRX)=APSPRX_U_APSPN_U_APSPDRG_U_APSPP_U_APSPQ_U_APSPCN_U_APSPTY Q I +APSPANS=APSP("DIV") S ^TMP($J,"APSPX",APSP("DIV"),APSPDT,APSPRX)=APSPRX_U_APSPN_U_APSPDRG_U_APSPP_U_APSPQ_U_APSPCN_U_APSPTY Q RRX ;GRAB REFILL RX DATA S APSPD=$P($G(^PSRX(APSPRN,1,APSPLN,0)),U,17),APSPQ=$P($G(^(0)),U,4),APSPP=$P($G(^VA(200,APSPD,0)),U),APSP("DIV")=$P($G(^PSRX(APSPRN,1,APSPLN,0)),U,9) S APSP("D")=$P($G(^PS(59,APSP("DIV"),0)),U,6) S APSPCN=$P($G(^AUPNPAT(APSPDFN,41,APSP("D"),0)),U,2) I APSPANS="A" S ^TMP($J,"APSPX",APSP("DIV"),APSPDT,APSPRX)=APSPRX_U_APSPN_U_APSPDRG_U_APSPP_U_APSPQ_U_APSPCN_U_APSPTY Q I +APSPANS=APSP("DIV") S ^TMP($J,"APSPX",APSP("DIV"),APSPDT,APSPRX)=APSPRX_U_APSPN_U_APSPDRG_U_APSPP_U_APSPQ_U_APSPCN_U_APSPTY Q PRX ;GRAB PARTIAL RX DATA S APSPD=$P($G(^PSRX(APSPRN,"P",APSPLN,0)),U,17),APSPQ=$P($G(^(0)),U,4),APSPP=$P($G(^VA(200,APSPD,0)),U),APSP("DIV")=$P($G(^PSRX(APSPRN,"P",APSPLN,0)),U,9) S APSP("D")=$P($G(^PS(59,APSP("DIV"),0)),U,6) S APSPCN=$P($G(^AUPNPAT(APSPDFN,41,APSP("D"),0)),U,2) I APSPANS="A" S ^TMP($J,"APSPX",APSP("DIV"),APSPDT,APSPRX)=APSPRX_U_APSPN_U_APSPDRG_U_APSPP_U_APSPQ_U_APSPCN_U_APSPTY Q I +APSPANS=APSP("DIV") S ^TMP($J,"APSPX",APSP("DIV"),APSPDT,APSPRX)=APSPRX_U_APSPN_U_APSPDRG_U_APSPP_U_APSPQ_U_APSPCN_U_APSPTY Q PRNT S (APSPDP,APSPZX)="" D HDR,DSPL Q DSPL ;GET DATA FROM TMP GBL S APSP("DIV")="" F S APSP("DIV")=$O(^TMP($J,"APSPX",APSP("DIV"))) Q:'APSP("DIV") D ;GET DIVISION .S APSP("DV")=$P($G(^PS(59,APSP("DIV"),0)),U) .F S APSPDP=$O(^TMP($J,"APSPX",APSP("DIV"),APSPDP)) Q:'APSPDP!($G(APSPOUT)) F S APSPZX=$O(^TMP($J,"APSPX",APSP("DIV"),APSPDP,APSPZX)) Q:'APSPZX!($G(APSPOUT)) D DSPS Q:$G(APSPOUT) Q DSPS S APSP=^TMP($J,"APSPX",APSP("DIV"),APSPDP,APSPZX),APSPN=$P(APSP,U,2),APSPDRG=$P(APSP,U,3),APSPP=$P(APSP,U,4),APSPQ=$P(APSP,U,5),APSPCN=$P(APSP,U,6) S APSPTY=$P(APSP,U,7),APSPTYP=$S(APSPTY="N":"NEW RX",APSPTY="R":"REFILL",APSPTY="P":"PARTIAL",1:"") D:$Y+4>IOSL HDR Q:$G(APSPOUT) S Y=$P(APSPDP,".")_"."_$E($P(APSPDP,".",2),1,4) X ^DD("DD") S APSPDT=Y W !,"Rx #: "_APSPZX,?12,"Name: "_APSPN,?37,"Chart #: "_APSPCN,?53,"D/Time: "_APSPDT,!,"DRUG: "_APSPDRG,?37,"Qty: "_APSPQ,?47,"Provider: "_APSPP,!,"Division: "_APSP("DV"),?37,APSPTYP,! Q HDR I APSPG,$E(IOST)="C" K DIR S DIR(0)="FO",DIR("A")="Press Return to Continue or ""^"" to Exit" D ^DIR I X["^" S APSPOUT=1 Q S APSPG=APSPG+1 D NOW^%DTC W @IOF,?38,"(",APSPG,")",!,"DAILY PRESCRIPTION ACTIVITY REPORT" S Y=$P(%,".",1)_"."_$E($P(%,".",2),1,4) X ^DD("DD") W ?51,"Date: ",?59,Y,! F I=1:1:80 W "." S Y=APSPFD X ^DD("DD") S APSPFDZ=Y,Y=APSPED X ^DD("DD") S APSPEDZ=Y W !,?10,"For Rx's dispensed from "_APSPFDZ_" to "_APSPEDZ,!! Q EXIT ; W ! D ^%ZISC K %DT("A"),%DT("B"),APSPFD,APSPED,APSPRN,APSP,APSPCN,APSPD,APSPDFN,APSPDG,APSPDIV,APSPDP,APSPDRG,APSPDT,APSPED,APSPTYP,ZZ K DIR,APSPG,APSPOUT,APSPEDZ,APSPFD,APSPFDZ,APSPLN,APSPN,APSPP,APSPQ,APSPRN,APSPRX,APSPTY,APSPZX Q APSPLBL APSPLBL ; IHS/DSD/ENM - MOD VER OF PSOLBL/BHAM - SETS VAR TO PRINT LABEL ; [ 10/07/1999 2:48 PM ] ;;6.0;IHS PHARMACY MODIFICATIONS;**1**;09/03/97 ;This rtn calls APSPLBLC which was a part of this rtn ;4.3.95 DQ I $D(PSOIOS),PSOIOS]"" F J=0,1 I $D(^%ZIS(2,^%ZIS(1,PSOIOS,"SUBTYPE"),"BAR"_J)) S @("PSOBAR"_J)=^("BAR"_J) I $G(PSOBAR0)]"",$G(PSOBAR1)]"",$D(^PS(59,PSOSITE,1)) S PSOBARS=1 DQ1 ;EP D PARM,ENLBL^PSOBSET F PI=1:1 Q:$P(PPL,",",PI)="" S RX=$P(PPL,",",PI) D C ;I $D(PSZK),PSZK S L=PSZL+PSZE+PSZB*PSZK F I=1:1:L W ! ;IHS/DSD/ENM 10/02/96 Q:($G(PX)["B")!($G(PX)["S") I $D(PSZK),PSZK S L=PSZL+PSZE+PSZB*PSZK F I=1:1:L W ! ;IHS/DSD/ENM/POC 01/20/98 Q ADDED TO ALLOW 1 LBL IF SUM LBL PRINT ;I $G(PSOTRAIL),$P(^PS(59,PSOSITE,1),"^",28) D MAIL^PSOLBLS K RXPI,PSORX,RXP,PSOIOS,XXX,TECH,COPAYVAR,TECH,PHYS,MFG,NURSE,STATE,SIDE,COPIES,EXDT,ISD,PSOINST,RXN,RXY,VADT,DEA,WARN,FDT,QTY,PATST,PDA,PS,PS1,PS2,PSL,PSNP,INRX,PSMPEX,XTYPE,SSNP,PNM,ADDR,PSODBQ,PSOTRAIL S ZTREQ="@" Q C ;EP U IO S X=$S('$P(^PS(59,PSOSITE,1),"^",28):132,1:158) X ^%ZOSF("RM") Q:'$D(^PSRX(RX,0)) S:$G(RXY)']"" RXY=^PSRX(RX,0) I $P(RXY,"^",15)=12&('$G(RXP))!('$P(RXY,"^",2)) K RXY Q I $G(PSODBQ) S RR=$O(^PS(52.5,"B",RX,0)) Q:'RR I $G(^PS(52.5,RR,"P"))=1 Q I $P(RXY,"^",15)'=4 D:$G(PSOSUSPR) AREC^PSOSUTL D:$G(PSOPULL) AREC^PSOSUTL ;IHS/DSD/ENM 09/09/97 S PSOINST="000" I $D(^DD("SITE",1)),^(1)]"" S PSOINST=^(1) S RXN=$P(RXY,"^"),ISD=$P(RXY,"^",13),RXF=0,DFN=+$P(RXY,"^",2),SIG=$P(RXY,"^",10),ISD=$E(ISD,4,5)_"/"_$E(ISD,6,7)_"/"_$E(ISD,2,3),ZY=0,LINE="" F J=1:1:28 S LINE=LINE_"_" S FDT=$P(^PSRX(RX,2),"^",2),PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:""),PS1=$S($D(^(1)):^(1),1:""),PSOSITE7=$P(^PS(59,PSOSITE,"IB"),"^") S PS2=$P(PS,"^")_"^"_$P(PS,"^",6) I $P(PSOSYS,"^",4),$D(^PS(59,+$P($G(PSOSYS),"^",4),0)) S PS=^PS(59,$P($G(PSOSYS),"^",4),0) ;OLD EXPIRATIOND DATE REMOVED 12.23.94 APSPM ; get Mfg data 12.23.94 I $G(APSPLTYP)="P" G ZCP ; 2-16-95 S (APSP("LOT"),APSP("MANF"),APSP("MANXDT"))="" D LBL^APSPMAN ZCP S:'$D(COPIES) COPIES=$S($P(RXY,"^",18)]"":$P(RXY,"^",18),1:1) S:COPIES>99 COPIES=99 I $O(^PSRX(RX,1,0)),'$G(RXP) S XTYPE=1 D REF G STA I $G(RXP) S XTYPE="P" D REF G STA S (APSPZ,APSPZZ)="" ; 4.19.94 ORIG S TECH=$P($G(^VA(200,+$P(^PSRX(RX,0),"^",16),0)),"^",2),QTY=$P(^PSRX(RX,0),"^",7),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UNKNOWN") D 6^VADPT,PID^VADPT ;S:PHYS'="UNKNOWN" APSPZ=$P(^VA(200,+$P(^PSRX(RX,0),"^",4),"PS"),"^",5),APSPZZ=$P($G(^DIC(7,APSPZ,0)),"^",2) ;IHS/DSD/ENM 08/25/97 S:PHYS'="UNKNOWN" APSPZ=$P(^VA(200,+$P(^PSRX(RX,0),"^",4),"PS"),"^",5) I APSPZ="" S APSPZZ="UNK" I APSPZ]"" S APSPZZ=$P($G(^DIC(7,APSPZ,0)),"^",2) S:PHYS'="UNKNOWN" PHYS=$P(PHYS,",",1)_","_$E($P(PHYS,",",2),1)_"."_" "_APSPZZ S DAYS=$P(^PSRX(RX,0),"^",8),MFG=$S($P(^(2),"^",8)]"":$P(^(2),"^",8),1:"________ "),LOT=$S($P(^(2),"^",4):$P(^(2),"^",4),1:"_________") STA S STATE=$S($D(^DIC(5,+$P(PS,"^",8),0)):$P(^(0),"^",2),1:"UNKNOWN") S (DRUG,DEA,WARN)="" I $D(^PSDRUG(+$P(RXY,"^",6),0)) S DRUG=$P(^(0),"^"),DEA=$P(^(0),"^",3),WARN=$P(^(0),"^",8) I $D(^PSRX(RX,"TN")),^("TN")]"",^("TN")'?1." " S DRUG=^("TN") ;S SIDE=$S($G(SIDE)]"":SIDE,1:0) ;IHS/DSD/ENM 02/25/97 S APS("DISP UNITS")="" S:$D(^PSDRUG(+$P(RXY,U,6),660)) APS("DISP UNITS")=$P(^(660),U,8) I $G(^PSRX(RX,"P",+$G(RXP),0))]"" S RXPI=RXP D .S RXP=^PSRX(RX,"P",RXP,0),RXY=$P(RXP,"^")_"^"_$P(RXY,"^",2,6)_"^"_$P(RXP,"^",4)_"^"_$P(RXP,"^",10)_"^"_$P(RXY,"^",9,10)_"^"_$P(RXP,"^",2)_"^"_$P(RXY,"^",12,15)_"^"_$P(RXP,"^",7)_"^"_$P(RXY,"^",17,99),FDT=$P(RXP,"^") S MW=$P(RXY,"^",11) F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I S RXF=RXF+1 S:'$G(RXP) MW=$P(^PSRX(RX,1,I,0),"^",2) I +^PSRX(RX,1,I,0)'30) .K PSMP(PSI) S X=$S($D(^PS(55,DFN,0)):^(0),1:""),PSCAP=$P(X,"^",2) S:MW="M" MW=$S(+$P(X,"^",3):"R",1:MW) S MW=$S(MW="M":"REGULAR",MW="R":"CERTIFIED",1:"WINDOW") S DATE=$E(FDT,1,7),REF=$P(RXY,"^",9)-RXF S:'$G(RXP) $P(^PSRX(RX,3),"^")=FDT S:REF<1 REF=0 S PSZRM=" MRx"_REF D ^APSPLBL2 S II=RX D ^PSORFL S PATST=^PS(53,$P(RXY,"^",3),0) S PRTFL=1 I REF=0 S:('$P(PATST,"^",5))!(DEA["A"&(DEA'["B"))!(DEA["W") PRTFL=0 S VRPH=$P(^PSRX(RX,2),"^",10),PSCLN=+$P(RXY,"^",5),PSCLN=$S($D(^SC(PSCLN,0)):$P(^(0),"^",2),1:"UNKNOWN") S PATST=$P(PATST,"^",2),X1=DT,X2=$P(RXY,"^",8)-10 D C^%DTC:REF I $D(^PSRX(RX,2)),$P(^(2),"^",6),REF,X'<$P(^(2),"^",6) S REF=0,VRPH=$P(^(2),"^",10) ;D ^APSPLBLC I $P(^PSRX(RX,0),"^",15)>0,$P(^(0),"^",15)'=2,'$G(PSODBQ) G LBL LBL ;USE IHS LABEL RTN G ^APSPLBL1 REF F XXX=0:0 S XXX=$O(^PSRX(RX,XTYPE,XXX)) Q:+XXX'>0 D .S TECH=$P($G(^VA(200,+$P(^PSRX(RX,XTYPE,XXX,0),"^",7),0)),"^",2) .S QTY=$P(^PSRX(RX,XTYPE,XXX,0),"^",4),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,XTYPE,XXX,0),"^",17),0)):$P(^(0),"^"),$D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UNKNOWN") D 6^VADPT,PID^VADPT .S:PHYS'="UNKNOWN" APSPZ=$P(^VA(200,+$P(^PSRX(RX,0),"^",4),"PS"),"^",5),APSPZZ=$P($G(^DIC(7,APSPZ,0)),"^",2) .S:PHYS'="UNKNOWN" PHYS=$P(PHYS,",",1)_","_$E($P(PHYS,",",2),1)_"."_" "_APSPZZ .S DAYS=$P(^PSRX(RX,XTYPE,XXX,0),"^",10),LOT=$S($P(^(0),"^",6):$P(^(0),"^",6),1:"UNKNOWN") .I XTYPE=1 S MFG=$S($P(^PSRX(RX,XTYPE,XXX,0),"^",14)]"":$P(^(0),"^",14),1:"UNKNOWN") .E S MFG=$S($P($G(^PSRX(RX,2)),"^",8)]"":$P(^(2),"^",8),1:"UNKNOWN") Q EN01 I $D(PSOIOS),PSOIOS]"" F J=0,1 I $D(^%ZIS(2,^%ZIS(1,PSOIOS,"SUBTYPE"),"BAR"_J)) S @("PSOBAR"_J)=^("BAR"_J) I $G(PSOBAR0)]"",$G(PSOBAR1)]"",$D(^PS(59,PSOSITE,1)) S PSOBARS=1 D PARM F PI=1:1 Q:$P(PPL,",",PI)="" S RX=$P(PPL,",",PI) D C Q PARM ;EP ;SET LBL WTH/LN/MAR & GET DATA FROM FILE #9009033 S X=$S($D(^APSPCTRL(PSOSITE,0)):^(0),1:""),PSZW=$P(X,U,4),PSZL=$P(X,U,5),PSZB=$P(X,U,6),PSZE=$P(X,U,7),PSZK=$P(X,U,9),PSZTAB=$P(X,U,10) ;IHS/DSD/ENM 08/01/96 Q APSPLBL1 APSPLBL1 ; IHS/DSD/ENM - PRINTS LABEL ; [ 04/29/1999 11:53 AM ] ;;6.0;IHS PHARMACY MODIFICATIONS;**1**;09/03/97 ;NOTE: VA Patches 31,66,60,59 not installed in this rtn IHS/DSD/ENM 3.9.94 EP ; This IHS routine is a rewrite of and not the same as the ; VA PSOLBL1 rtn. Z S L=$L(PSZRM) I $L(SGY(SGC))+L+1PSZLA) F II=1:1:(PSZL-2-I) W ! ;IHS/BAO/JCM 2/3/89 I '$D(SGY(DR+1)) G NEXT:F&(I'>PSZLA) ;IHS/BAO/JCM 2/3/89 W !,?PSZTAB,"**** CONTINUED ****" S F=1 ;IHS/DSD/ENM 12/22/97 F I=1:1:PSZE+PSZB W ! W !,?PSZTAB,"**** CONTINUED ****" S PSZM=$S(PSZLA-(SGC-DR)'<0:PSZLA-(SGC-DR),1:0) F I=1:1:PSZM W ! ;IHS/BAO/JCM 2/3/89 G C1:DR0 S SIDE=1 G START ZZE ;IHS/DSD/ENM NEXT 6 LINES ADDED FOR LBL NODE 12/1/95 ;STORE LABEL PRINT NODE D NOW^%DTC S NOW=% K %,%H,%I S RXF=0 F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I S RXF=I S IR=0 F FDA=0:0 S FDA=$O(^PSRX(RX,"L",FDA)) Q:'FDA S IR=FDA S IR=IR+1,^PSRX(RX,"L",0)="^52.032A^"_IR_"^"_IR S ^PSRX(RX,"L",IR,0)=NOW_"^"_$S($G(RXP):99-RXPI,1:RXF)_"^"_$S($G(PCOMX)]"":$G(PCOMX),1:"From RX number "_$P(^PSRX(RX,0),"^"))_$S($G(RXP):" (PARTIAL)",1:"")_$S($D(REPRINT):" (REPRINT)",1:"")_"^"_DUZ S ^PSRX(RX,"TYPE")=0 K RXF,IR,FDA,NOW,I ;I $P(PS1,"^",2) S ^PIM("I",RX,$S($D(RXP):6,1:RXF))=RX,^(0)=$P(^PSRX(RX,0),"^",1,14)_"^"_$S(RXF:2,1:1)_"^"_$P(^(0),"^",16,99) END K %DT,ADDR,DEA,DR,DR1,DRX,DRUG,FDT,SGY,RXY,RXZ,RYY,RFLMSG,RFL,%H,COPIES,DOB,DRUG,LIM,LMI,LINE,PS,PS1,PS2,PSZZL,PSZLA,II,PSZM,INT,ISD,I1,MW,MAIL,STATE,SIDE,SSNP,SS,ST,ST1,PATST,PRTFL,PHYS,PNM,S,SL,SGC,APS("DISP UNITS") Q ;IHS/BAO/JCM 2/3/89 Q ; SIG1 S X=$S($D(SGY(DR)):SGY(DR),1:"") W !,?PSZTAB,X Q SUMMARY ;IHS/BAO/JCM;FEB 15,1988 ;THESE LINES BUILD THE ARRAY FOR PRINTING A SUMMARY LABEL TO ;PLACE IN THE CHART OF REFILLS AND PARTIAL PRESCRIPTIONS. ; ;$E(PNM,1,PSZW-8) = THE PATIENTS NAME ; ;FDT = THE FILL DATE FOR THE PARTIAL OR REFILL ; ;THE NEXT THREE LINES SET UP THE DRUG NAME TAKING OFF ;ANY TAB,CAP,SOLN ABBREVIATIONS TO SAVE LENGTH F FIND=" TAB"," CAP"," SUSP"," SOLN"," SYRUP" I DRUG[FIND S END=$F(DRUG,FIND)-($L(FIND)+1) Q S:'$D(END) END=99 S PSZDRUG=$E(DRUG,1,END) ; = THE DRUG NAME S APSHRN=$S($G(^AUPNPAT(DFN,41,DUZ(2),0)):$P(^(0),U,2),1:"") ; ;RXN = THE PRESCRIPTION NUMBER ; ;$P(RXY,"^",10) = THE DIRECTIONS FOR THE ;PRESCRIPTION BEFORE EXPANSION FROM THE QUICK CODE ; ;$P(RXY,"^",7) = THE QUANTITY ISSUED ; S:'$D(ARRAY) N=0,APSPZZN=0 ;IHS/DSD/ENM 07/31/96 S N=N+1,APSPZZN=APSPZZN+1 ;S ARRAY(N)=$E(PNM,1,PSZW-8)_"^"_RXN_"^"_PSZDRUG_"^"_$P(RXY,"^",10)_"^"_+$P(RXY,"^",7)_"^"_+FDT_"^"_APSHRN S ARRAY(APSPZZN)=$E(PNM,1,PSZW-8)_"^"_RXN_"^"_PSZDRUG_"^"_$P(RXY,"^",10)_"^"_+$P(RXY,"^",7)_"^"_+FDT_"^"_APSHRN ;IHS/DSD/ENM 07/31/96 ; K FIND,END,PSZDRUG Q APSPMAN1 APSPMAN1 ; IHS/DSD/ENM - MANUFACTURER DATA FOR REFILL RX'S ; [ 10/07/1999 2:49 PM ] ;;6.0;IHS PHARMACY MODIFICATIONS;**1**;09/03/97 EP ;ENTRY POINT - FOR REFILL RX (W/edit 'all' mfg data set to 'yes') I APSPMAN'=1 Q S (APSPMM,APSPL,APSPD)="" ;I $D(^PSRX(PSOREF("IRXN"),1,0)) S LASTRF=$P(^(0),"^",3) D LAST I $P($G(^PSRX(PSOREF("IRXN"),1,0)),"^",3)]"" S LASTRF=$P(^(0),"^",3) D LAST ;IHS/DSD/ENM/POC 01/20/98 PREVENTS ERR WHEN REF DELETED I APSPMM]""!(APSPL]"")!(APSPD]"") G WR S APSPLTYP="R" I $G(PSOREF("RX2"))']"" G ACT S APSPMM=$P($G(PSOREF("RX2")),"^",8),APSPL=$P($G(PSOREF("RX2")),"^",4),APSPD=$P($G(PSOREF("RX2")),"^",11) G WR LAST ;CK MAN DATA IN LAST REFILL S APSPLRF=^PSRX(PSOREF("IRXN"),1,LASTRF,0) S APSPMM=$P(APSPLRF,"^",14),APSPL=$P(APSPLRF,"^",6),APSPD=$P(APSPLRF,"^",15) Q DTO ;EP FOR REFILL RX (W/mfg 'date only' set) IHS/DSD/ENM 01/29/96 S APSPRXX=$P($G(^PSRX(PSOREF("IRXN"),0)),"^",6) Q:APSPRXX']"" S DA=APSPRXX,DR="9999999.26",DIE="^PSDRUG(" D ^DIE ;SET VARIABLES FOR PSOR52 GLOBAL SET S PSOREF("LOT #")="",PSOREF("MANUFACTURER")="",PSOREF("EXPIRATION DATE")=$P($G(^PSDRUG(APSPRXX,999999924)),"^",3) ;GET LABEL VARIABLE DATA S APSPMF="",APSPLOT="" I PSOREF("EXPIRATION DATE")']"" S APSPDY="" Q S APSPDY=$E(PSOREF("EXPIRATION DATE"),4,5)_"/"_$E(PSOREF("EXPIRATION DATE"),2,3) Q NMFG ;EP FOR REFILL RX (W/no mfg set) IHS/DSD/ENM 02/15/96 ;SET VARIABLES FOR PSOR52 GLOBAL SET S PSOREF("LOT #")="",PSOREF("MANUFACTURER")="",PSOREF("EXPIRATION DATE")="" ;GET LABEL VARIABLE DATA S APSPMF="",APSPLOT="" S APSPDY="" Q WR W !,"Manufacturer: ",APSPMM,?30,"Lot #: ",APSPL,?50,"Mfg Expiration Date: "_$E(APSPD,4,5)_"/"_$E(APSPD,2,3) ACT I APSPMAN=1 S DIR(0)="Y",DIR("A")="Edit Manufacturer Data? :",DIR("B")="N",DIR("?")="Answer 'Yes' if the Manufacturer, Lot # or Expiration date has changed" D ^DIR K DIR I Y=1 S APSPRXX=$P(PSOREF("RX0"),U,6) D ASK^APSPMAN G OUT S APSPRXX=$P(PSOREF("RX0"),U,6) D MAN2^APSPMAN OUT ;SET VARIABLES FOR PSOR52 GLOBAL SET S PSOREF("LOT #")=PSONEW("LOT #"),PSOREF("MANUFACTURER")=PSONEW("MANUFACTURER"),PSOREF("EXPIRATION DATE")=PSONEW("EXPIRATION DATE") ;GET LABEL VARIABLE DATA S APSPMF=$E(PSONEW("MANUFACTURER"),1,5),APSPLOT=$E(PSONEW("LOT #"),1,8),APSPDY=$E(PSONEW("EXPIRATION DATE"),4,5)_"/"_$E(PSONEW("EXPIRATION DATE"),2,3) D EXIT Q EP1 ;ENTRY POINT FOR EDIT RX OPT Q:APSPMAN'=1 I $G(APSPLTYP)="V",$G(RX2)']"" S (APSPL,APSPMM,APSPD)="" Q ;IHS/DSD/ENM 09/02/96 I $G(APSPLTYP)="V" S APSPMM=$P($G(RX2),"^",8),APSPL=$P($G(RX2),"^",4),APSPD=$P($G(RX2),"^",11) Q I $G(PSORXED("RX2"))']"" S (APSPL,APSPMM,APSPD)="" Q S APSPMM=$P($G(PSORXED("RX2")),"^",8),APSPL=$P($G(PSORXED("RX2")),"^",4),APSPD=$P($G(PSORXED("RX2")),"^",11) ;I APSPLTYP="V" D WR1 I $G(APSPLTYP)="E" D WR1,ACT1 ;IHS/DSD/ENM 09/02/96 Q ; WR1 W !,"Manufacturer: ",APSPMM,?30,"Lot #: ",APSPL,?50,"Mfg Expiration Date: "_$E(APSPD,4,5)_"/"_$E(APSPD,2,3) Q ACT1 ;EP I APSPMAN=1 S DIR(0)="Y",DIR("A")="Edit Manufacturer Data? :",DIR("B")="N",DIR("?")="Answer 'Yes' if the Manufacturer, Lot # or Expiration date has changed" D ^DIR K DIR S APSPYN=Y I Y=1 D ASK^APSPMAN G OUT1 I PS="PARTIAL",$G(APSPYN)'=1 S PSONEW("LOT #")=$G(APSP("PL")),PSONEW("MANUFACTURER")=$G(APSP("PM")),PSONEW("EXPIRATION DATE")=$G(APSP("PD")) ;IHS/DSD/ENM 09/05/96 ;W !,"Mfg Expiration Date is required!",! I APSPMAN=""!(APSPMAN=3) D NOMAN^APSPMAN ;IHS/DSD/ENM 02/15/96 I APSPMAN=2 D MAN2^APSPMAN ;IHS/DSD/ENM 02/15/96 OUT1 ;SET VARIABLES FOR GLOBAL SET S PSOREF("LOT #")=PSONEW("LOT #"),PSOREF("MANUFACTURER")=PSONEW("MANUFACTURER"),PSOREF("EXPIRATION DATE")=PSONEW("EXPIRATION DATE") ;GET LABEL VARIABLE DATA I APSPMAN=""!(APSPMAN=3) S (APSPMF,APSPLOT,APSPDY)="" G EXIT ;IHS/DSD/ENM 02/15/96 I APSPMAN=2 S APSPMF="",APSPLOT="",APSPDY=$E(PSONEW("EXPIRATION DATE"),4,5)_"/"_$E(PSONEW("EXPIRATION DATE"),2,3) G EXIT ;IHS/DSD/ENM 02/15/96 S APSPMF=$E(PSONEW("MANUFACTURER"),1,5),APSPLOT=$E(PSONEW("LOT #"),1,8),APSPDY=$E(PSONEW("EXPIRATION DATE"),4,5)_"/"_$E(PSONEW("EXPIRATION DATE"),2,3) G EXIT DCQ ;CHECK FOR CHNG'ed DATA AFTER EDITING AN RX Q:APSPMAN<1 S (APSPXED,APSPXMF,APSPXLT)="" I APSPMAN=1 D ALLCK G DCQX I APSPMAN=""!(APSPMAN=2) D DTCK DCQX Q ALLCK I PSONEW("EXPIRATION DATE")'=$P($G(PSORXED("RX2")),"^",11) S APSPXED=PSONEW("EXPIRATION DATE") I PSONEW("LOT #")'=$P($G(PSORXED("RX2")),"^",4) S APSPXLT=PSONEW("LOT #") I PSONEW("MANUFACTURER")'=$P($G(PSORXED("RX2")),"^",8) S APSPXMF=PSONEW("MANUFACTURER") I APSPXED]"" S DR="29///^S X=APSPXED",COM=COM_$P(^DD(52,29,0),"^")_" ("_APSPXED_")," I APSPXLT]"" S DR=DR_";24///^S X=APSPXLT",COM=COM_$P(^DD(52,24,0),"^")_" ("_APSPXLT_")," I APSPXMF]"" S DR=DR_";28///^S X=APSPXMF",COM=COM_$P(^DD(52,28,0),"^")_" ("_APSPXMF_")," I DR]"" S DIE="^PSRX(",DA=PSORXED("IRXN") D ^DIE K DIE,DR,DA,X,Y Q DTCK ;MFG DATE CHECK FOR CHANGE I PSOREF("EXPIRATION DATE")'=$P($G(PSORXED("RX2")),"^",11) S APSPXED=PSOREF("EXPIRATION DATE") I APSPXED]"" S DR="29///^S X=APSPXED",COM=COM_$P(^DD(52,29,0),"^")_" ("_APSPXED_"),",DIE="^PSRX(",DA=PSORXED("IRXN") D ^DIE K DIE,DR,DA,X,Y Q EXIT ;K APSPN,APSPL,APSPM,APSPMM,APSPD,PSONEW("LOT #"),PSONEW("MANUFACTURER"),PSONEW("EXPIRATION DATE") ;K APSPN,APSPL,APSPM,APSPMM,APSPD Q ZPAR ;GET MFG DATA FOR PARTIAL RX OPT ;S APSPN=$G(^PSRX(RX0,"P")) I APSPN']"" S (APSPL,APSPM,APSPD)="" Q ;S APSPM=$P($G(APSPN),"^",1),APSPL=$P($G(APSPN),"^",2),APSPD=$P($G(APSPN),"^",3) Q APSPMAN2 APSPMAN2 ; IHS/DSD/ENM - MANUFACTURER DATA FOR RENEWED RX'S ; [ 05/26/1998 11:36 AM ] ;;6.0;IHS PHARMACY MODIFICATIONS;**1**;09/03/97 EP ;ENTRY POINT FOR RENEWING RX I APSPMAN'=1 Q S (APSPMM,APSPL,APSPD)="" I $D(^PSRX(PSORENW("OIRXN"),1,0)) S LASTRF=$P(^(0),"^",3) D LAST I APSPMM]""!(APSPL]"")!(APSPD]"") G WR I $G(PSORENW("RX2"))']"" G ACT S APSPMM=$P($G(PSORENW("RX2")),"^",8),APSPL=$P($G(PSORENW("RX2")),"^",4),APSPD=$P($G(PSORENW("RX2")),"^",11) G WR ;************************************************************ LAST ;CK MAN DATA IN LAST REFILL S APSPLRF=^PSRX(PSORENW("OIRXN"),1,LASTRF,0) S APSPMM=$P(APSPLRF,"^",14),APSPL=$P(APSPLRF,"^",6),APSPD=$P(APSPLRF,"^",15) Q ;************************************************************ WR W !,"Manufacturer: ",APSPMM,?30,"Lot #: ",APSPL,?50,"Mfg Expiration Date: "_$E(APSPD,4,5)_"/"_$E(APSPD,2,3) ACT S DIR(0)="Y",DIR("A")="Edit Manufacturer Data? :",DIR("B")="N",DIR("?")="Answer 'Yes' if the Manufacturer, Lot # or Expiration date has changed" D ^DIR K DIR I Y=1 S APSPRXX=$P(PSORENW("RX0"),U,6) D ASK^APSPMAN G OUT DTO ;S APSPRXX=$P(PSORENW("RX0"),U,6) D MAN2^APSPMAN ;IHS/DSD/ENM 10/29/97 S APSPRXX=$P(PSORENW("RX0"),U,6) D EP1^APSPMAN ;IHS/DSD/ENM 05/26/98 OUT ;SET VARIABLES FOR PSOR52 GLOBAL SET S PSORENW("LOT #")=PSONEW("LOT #"),PSORENW("MANUFACTURER")=PSONEW("MANUFACTURER"),PSORENW("EXPIRATION DATE")=PSONEW("EXPIRATION DATE") ;GET LABEL VARIABLE DATA S APSPMF=$E(PSONEW("MANUFACTURER"),1,5),APSPLOT=$E(PSONEW("LOT #"),1,8),APSPDY=$E(PSONEW("EXPIRATION DATE"),4,5)_"/"_$E(PSONEW("EXPIRATION DATE"),2,3) Q APSPMDD APSPMDD ;IHS/DSD/KML/ENM - NDC XREF CREATE IN DRUG FILE [ 08/25/1999 3:10 PM ] ;;6.1;IHS PHARMACY AWP;**1,2**;03/13/98 XREF ;EP ; callable subroutine executed by VA FILEMAN trigger when creating the ; ZNDC cross-reference for file # 50 ; dashes will be removed from the NDC string ;Q:'+X ;IHS/DSD/ENM 11/27/98 S APSPNDC=$TR(X,"-") S APSPNDC=$TR(APSPNDC,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") ;IHS/DSD/ENM 11/27/98 S X=APSPNDC Q APSPMED1 APSPMED1 ; IHS/DSD/ENM - OUTPATIENT MED PROFILE MOD ; [ 05/14/1998 4:04 PM ] ;;6.0;IHS PHARMACY MODIFICATIONS;**1**;09/03/97 ; GET FROM AND TO DATES AND MULTIPLE PATIENT SELECTION EP1 ;EP S APSPAGE=0,APSP=0,APSPDEL="" S %DT("A")="Select Beginning Date: ",%DT="AEP" D ^%DT Q:Y<0 S X1=Y,X2=-1 D C^%DTC S APSPBD=X_.2359 ;IHS/DSD/ENM/POC 05/11/98 S %DT("A")="Ending Date: ",%DT("B")="TODAY",%DT="AEP" D ^%DT S APSPED=Y_".2359" Q:Y<0 ;IHS/DSD/ENM/POC 05/11/98 EP ;EP - Entry point to Select 1 or more patients S DIC=2,DIC(0)="QEAM" D ^DIC I X="^" K APSPDPT,APSPAGE Q I +Y>0 D PASS G EP I '$D(APSPDPT)&((+Y["^")!(+Y<0)) Q ;LIST NAMES AND ALLOW DE-SELECTION I $D(APSPDPT) D SELDEL K APSPX1,APSPEM,APSPCTR,APSPXA,APSPZAP,DIR,DIC Q SELDEL ;SELECT/DE-SELECT PATIENT FROM LIST............................ S APSPDEL="" ;IHS/DSD/ENM 010595 W !,"So far, you've selected...." S APSPX1="",APSPCTR=0 F I=1:1 S APSPX1=$O(APSPDPT(APSPX1)) Q:'APSPX1 S APSPEM(I)=APSPX1,APSPCTR=APSPCTR+1 W ?30,"("_I_") "_APSPDPT(APSPX1),! RETRY S DIR("A")="Would you like to De-select a patient from this list",DIR(0)="Y",DIR("?")="Enter a ""Y"" for ""Yes"" or an ""N"" for ""No""" S DIR("B")="No" D ^DIR K DIR S APSPXA=X K X Q:"Nn"[$E(APSPXA) ;IHS/DSD/ENM 08/23/96 DEL ; I "Yy"[$E(APSPXA) S DIR(0)="NO^1:"_APSPCTR,DIR("A")="Delete Number" D ^DIR S APSPDEL=X ;IHS/DSD/ENM 08/23/96 I APSPDEL["^"!(APSPDEL="") Q I APSPDEL<1!(APSPDEL>APSPCTR) W !,"Enter a number from 1 to ",APSPCTR G DEL I APSPDEL'>APSPCTR!(APSPDEL'<1) S APSPZAP=APSPEM(APSPDEL) K APSPDPT(APSPZAP) G DEL Q PASS D DT^DICRW S (FN,DFN,D0,DA)=+Y I '$D(^PS(55,+Y,"P")),'$D(^PS(55,+Y,"ARC")) W !?20,*7,"NO PHARMACY INFORMATION" H 2 D ^APSPMED2 G APSPMED1 I '$O(^PS(55,+Y,"P",0)),$D(^PS(55,+Y,"ARC")) D ^APSPMED2 W !!,"PATIENT HAS ARCHIVED PRESCRIPTIONS",! D ^APSPMED2 G APSPMED1 S:+Y>0 APSPDPT(+Y)=$P(Y,"^",2) Q XIT K APSPDEL Q APSPNE4 APSPNE4 ; IHS/DSD/ENM - OUTPATIENT LABEL ASK OPTION 11/10/93 ; [ 05/14/1998 4:04 PM ] ;;6.0;IHS PHARMACY MODIFICATIONS;**1**;09/03/97 ;NOTE: THIS RTN IS A REWRITE OF PSONEW4 (V5.06) ;OPT MODULE REDESIGNED BY ENM 11/10/93 OUT ; S:'$D(PPL) PPL=$G(PSORX("PSOL",1)) ;IHS/DSD/ENM 10/07/93 I $G(PSORX("PSOL",1))]"" S PPL=PSORX("PSOL",1) ;IHS/DSD/ENM 02/14/97 OPT ;ASK PRINT OPTION S APSPZ1=$P($G(^APSPCTRL(PSOSITE,0)),"^",12),APSPZ2=$S(APSPZ1=1:"Summary",1:""),APSPZ3=$S(APSPZ1=1:"B=Sum+Cpro",1:"") ;IHS/DSD/ENM 08/01/96 S DIR(0)="SA^P:Print Label;Q:Queue Labels;C:Labels & Chronic Med Profile;R:Refill Rx;CA:Cancel Rx" ;_";"_APSPZ2_";"_APSPZ3 I APSPZ2]""!APSPZ3]"" S DIR(0)=DIR(0)_";S:"_APSPZ2_";B:"_APSPZ3 S DIR("A")="Print/Queue/Cpro/Refill/CAncel"_"/"_APSPZ2_"/"_APSPZ3_"/'^'=Exit: ",DIR("B")="P" S DIR("?",1)="Enter 'P' to Immediately Print Label(s) only",DIR("?",2)="Enter 'Q' to Queue Label(s) to a Printer",DIR("?",3)="Enter 'C' to Print Label(s) and Chronic Med Profile" S DIR("?",4)="Enter 'R' to Refill Prescription",DIR("?",5)="Enter 'CA' to Cancel Prescription",DIR("?",6)="*Enter 'S' to Print Labels + Summary Labels" S DIR("?",7)="*Enter 'B' to Print Label(s) + Chronic Med Profiles + Summary Labels" S DIR("?",8)="*Note: Summary labels depend on parameter setting in APSP CONTROL FILE" S DIR("?")="ENTER '^' TO EXIT" W !! D ^DIR K DIR S PX=Y,APSPXQ="" ;IHS/DSD/ENM 10/16/97 I "^"[Y D EXCK G CQ:"^"[PX ;IHS/DSD/ENM 02/23/96 OUT1 ;I $E(PX,1)="R" S PSOFROM="REFILL",PSOFROM("PTLKUP")=1,PX="" G EN^PSORX ;IHS/DSD/ENM 08/13/96 I $E(PX,1)="R" S PSORX("DO REFILL")=1,PX="",APSPZIT=1 D G OUT ;IHS/DSD/ENM 02/14/97 .I $G(PSORX("DO REFILL")),'PSORX("REFILL") W !,*7,"No prescriptions with refills allowed ",! G OUT ;IHS/DSD/ENM 02/14/97 .I $G(PSORX("DO REFILL")),$D(PSOSD)>1,PSORX("REFILL") W !,"Now entering Refill Option",! N PSOOPT S PSOOPT=4 D ^PSOREF .K APSPFLG,PSORX("DO REFILL") ;IHS/DSD/ENM 02/14/97 .W !,*7,"<--- RETURNING TO 'NEW RX' OPTION",! Q ;I $E(PX,1,2)="CA" D ^PSOZCAN W !! G OUT I $E(PX,1,2)="CA" D ^APSPCAN W !! G OUT I "P"[PX D P^PSORXL G CQ I "C"[PX D PCOPY,P^PSORXL,CPCK G CQ ;I "C"[PX,$G(APSPCP)=2 D PCOPY,P^PSORXL,INIT^APSPCP2 G CQ I "S"[PX K ARRAY D P^PSORXL,EP2^APSPSLBL:$D(ARRAY(1)) G CQ ;IHS/DSD/ENM 08/02/96 ;I "B"[PX D P^PSORXL,EP2^APSPSLBL:$D(ARRAY(1)),INIT^APSPCP2 G CQ I "B"[PX K ARRAY D PCOPY,P^PSORXL,EP2^APSPSLBL:$D(ARRAY(1)),CPCK G CQ ;IHS/DSD/ENM 08/02/96 ;I "Q"[PX D Q^PSORXL G CQ I "Q"[PX S APSPXQ="1" D Q^PSORXL G CQ ;IHS/DSD/ENM 10/16/97 S PX=PX_"^PSORXL" F PI=1:1 Q:$P(PPL,",",PI)="" S DA=$P(PPL,",",PI),ZD=$P(^PSRX(DA,2),"^",2),RXF=0 D @PX CQ K NEW1,NEW11 D ^%ZISC U IO(0) K APSEFDT,APSZFDT,ARRAY,SPFL1,AL,PSD,PS(53),PC,PL,PY,PI,PNM,DFN,NOW,PR,IOP,RX,SIG,SIGD,RXM,RX0,RX2,PPL ;S PPL="" K APFLAG,APSP,APSP1,APSP2,APSPCTR,APSPD,APSPDR,APSPDZ,APSPM0,APSPPDY,APSPPLOT,APSPPMF,APSPRFD,APSPRXX,APSPZDT,APSPZRN,APSPDY,APSPLOT,APSPMF,APSPZ,APSPZ1,APSPZ2,APSPZ3,APSPZZ,APSHRN K APSPZZN ;IHS/DSD/ENM 07/31/96 Q PCOPY ;ASK CM COPIES D COPIES^APSPCP2 Q CPCK ;CHECK CHRONIC MED PRINT STATUS I $G(APSPCP)=2 D INIT^APSPCP2 G CQ ;IHS/DSD/ENM 09/05/96 I $G(APSPCPP)]"" S ZTIO=APSPCPP D EMPRT^APSPCP2 G CQ I APSPCP=1,$G(APSPCPP)']"" D INIT^APSPCP2 G CQ Q EXCK ;IHS/DSD/ENM 02/23/96 QUESTION USER EXIT ACTION ;If a user exits before label prints release and label print info ;will not be set. W !,*7,?30,"Warning!!",!,?10,"Exiting at this point will result in an incomplete",!,?10,"prescription entry. To avoid future problems with",!,?10,"this Rx just destroy the label after it prints.",! S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you still want to Exit" D ^DIR K DIR I Y=0 S PX="P" Q S PX="^" Q APSPORXA APSPORXA ; IHS/DSD/ENM - enter outside rx ; [ 05/14/1998 4:04 PM ] ;;6.0;IHS PHARMACY MODIFICATIONS;**1**;09/03/97 ; START ;EP - called from option HDR ;write header W:$D(IOF) @IOF F J=1:1:7 S X=$P($T(TEXT+J),";;",2) W !?80-$L(X)\2,X K X,J W !! ; BEGIN ; D INIT G:APSPQUIT EXIT D GETPAT G:DFN="" EXIT F D GETDRUG Q:APSPQUIT!(APSPDIEN="") D PROCESS D EXIT Q PROCESS ; D GETDATE Q:APSPDATE="" D GETOL Q:APSPOL="" D GENVISIT Q:APSPQUIT D GENVMED Q EXIT ;cleanup and exit K DFN,APCDLOOK,APCDANE,APCDALVR,APCDVSIT,APCDPAT K APSPOIEN,APSPDRUG,APSPDIEN,APSPOL,APSPDATE,APSPQUIT ;IHS/DSD/ENM APSPDOL REMOVED D KILL^AUPNPAT K AUPNTALK,AUPNLK("ALL") K DIE,DR,DA,DIRUT,DIR,DTOUT,DUOUT,DIV,DIW,DQ,DD,DQ,DI,DIC,DIR,X,Y,I,DDH,DI,D,D0 Q INIT ;EP S APSPQUIT=0 S APSPOIEN=$O(^PSDRUG("B","OUTSIDE DRUG",0)) I 'APSPOIEN W !!,$C(7),$C(7),"OUTSIDE DRUG not defined in DRUG file, notify supervisor." H 3 S APSPQUIT=1 Q ;I APCDFLG S APSPQUIT=1 Q I '$D(PSOPAR) D ^PSOLSET ;set up pharmacy site parameters ;S APSPDOL=4472 I '$G(APSPDOL) W !!,"DEFAULT OTHER LOCATION NOT DEFINED IN PHARMACY SITE FILE!! NOTIFY YOUR SUPERVISOR" H 3 S APSPQUIT=1 Q Q GETDATE ;EP GET DATE OF ENCOUNTER K DIR S APSPDATE="",DIR(0)="DO^:"_DT_":EPT",DIR("A")="Enter DATE DISPENSED" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 Q:$D(DIRUT) S %DT="ET" D ^%DT G:Y<0 GETDATE I Y>DT W " ",$C(7),$C(7) K X G GETDATE S APSPDATE=Y Q GETOL ; S APSPOL="" S DIR(0)="9000010,2101",DIR("A")="Enter LOCATION WHERE DISPENSED" K DA D ^DIR K DIR S APSPOL=Y Q GETDRUG ; S (APSPDRUG,APSPDIEN)="" W !! K DD,DIR S DIR(0)="FO^1:40",DIR("A")="Enter DRUG NAME" D ^DIR K DIR S:$D(DTOUT) DIRUT=1 Q:Y="" I $D(DIRUT) W !,"No drug entered!!" Q S (X,APSPDRUG)=Y,DIC="^PSDRUG(",DIC(0)="MQE" D ^DIC K DIC I Y=-1 D NODRUG Q S APSPDIEN=+Y,APSPDRUG="" K DIR,DA,DIRUT,DTOUT,DUOUT Q ; NODRUG ; W !,"That drug cannot be found in the Drug file." K DIR S DIR(0)="Y",DIR("A")="Do you want to try to lookup the drug in the Drug file again",DIR("B")="Y" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 I $D(DIRUT) W !,"Exiting..." S APSPQUIT=1 Q I Y G GETDRUG S APSPDIEN=APSPOIEN W ! K DD,DIR S DIR(0)="FO^1:40",DIR("A")="Enter the FULL DRUG NAME...",DIR("A",1)="You must enter the drug name that will appear on the health summary.",DIR("B")=APSPDRUG D ^DIR K DIR S:$D(DTOUT) DIRUT=1 I $D(DIRUT) S APSPQUIT=1 W !!,"Exiting..." Q S APSPDRUG=Y S APSPDRUG=$TR(APSPDRUG,"-") ;IHS/DSD/ENM/POC 05/11/98 Q GENVISIT ; K APCDALVR S APCDALVR("AUPNTALK")="" S APCDALVR("APCDDATE")=APSPDATE S APCDALVR("APCDTYPE")="O" S APCDALVR("APCDPAT")=DFN S APCDALVR("APCDLOC")=$G(APSPDOL) S APCDALVR("APCDCAT")="E" S APCDALVR("APCDAUTO")="",APCDALVR("APCDANE")="" S APCDALVR("APCDOLOC")=APSPOL D ^APCDALV I $D(APCDALVR("APCDAFLG")) W !!,$C(7),"Creating PCC Visit Failed....Notify Supervisor" H 3 S APSPQUIT=1 Q S APCDVSIT=APCDALVR("APCDVSIT"),APCDPAT=APCDALVR("APCDPAT") S Y=DFN D ^AUPNPAT Q GENVMED ; I '$G(APSPDIEN) W !!,"Error.... no drug entry" H 2 Q ;D ^APCDEA3 W !!,"Please enter all available information about this prescription.",! S DA=APCDVSIT,DR="[APCD ORX (ADD)]",DIE="^AUPNVSIT(" D ^DIE I $D(Y) W !!,"Creating V Medication entry failed!! Notify supervisor!" H 3 Q Q GETPAT ;EP W ! S DFN="" S DIC("A")="Enter PATIENT NAME: ",DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC Q:Y<0 S DFN=+Y Q ; TEXT ; ;; ;;IHS PHARMACY MODULE/PCC Interface ;; ;;******************************* ;;* Entry of OUTSIDE RX's * ;;******************************* ;; APSPORXE APSPORXE ;IHS/TUCSON/LAB - enter outside rx [ 09/15/1999 3:55 PM ] ;;6.0;IHS PHARMACY MODIFICATIONS;**1,2**;09/03/97 ; START ;EP - called from option HDR ;write header W:$D(IOF) @IOF F J=1:1:7 S X=$P($T(TEXT+J),";;",2) W !?80-$L(X)\2,X K X,J W !! ;IHS/DSD/ENM/POC 05/11/98 NEXT THREE LINES S X="IOBON;IOBOFF" D ENDR^%ZISS S X="WARNING! NO DRUG INTERACTIONS OR CLASS CHECKING DONE IN THIS MODE" W ?80-$L(X)\2,IOBON,X,IOBOFF ; BEGIN ; I $G(APSPTYPE)="" W !!,$C(7),$C(7),"TYPE OF ACTION MISSING" H 2 G EXIT I "ED"'[$G(APSPTYPE) W !!,$C(7),$C(7),"TYPE OF ACTION MISSING" H 2 G EXIT D INIT^APSPORXA G:APSPQUIT EXIT D GETPAT^APSPORXA G:DFN="" EXIT D GETDATE^APSPORXA G:APSPDATE="" EXIT D @APSPTYPE D EXIT Q EXIT ;cleanup and exit K APSPOIEN,APSPDRUG,APSPDIEN,APSPOL,APSPDATE,APSPQUIT,APSPSEL,APSPX,APSPRX,APSPC,APSPER,APSPHIGH,APSPTYPE,APSPY ;IHS/DSD/ENM 12/26/95 APSPDOL REMOVED K M,P,V,X,Y,A,B,C,D,DIE,DIC,DIR,DTOUT,DUOUT,DIRUT,DA,DR,DIV,DIW,DIY,DIQ,DD,D0,DI,DQ,%DT,APCDVDLT,APCDVLDT D KILL^AUPNPAT K DFN,APCDPAT Q FIND ;find all rx's on that date K APSPRX S Y="APSPRX(",X=DFN_"^ALL MEDS;DURING "_APSPDATE_"-"_APSPDATE S APSPER=$$^APCLDF(X,Y) I APSPER W !!,"ERROR in finding outside rx's - data fetcher error!!" K APSPRX Q S X=0 F S X=$O(APSPRX(X)) Q:X'=+X S V=$P(APSPRX(X),U,5),M=+$P(APSPRX(X),U,4) I $P(^AUPNVSIT(V,0),U,7)'="E" K APSPRX(X) I '$D(APSPRX) W !!,$C(7),$C(7),"No OUTSIDE Rx's recorded for ",$P(^DPT(DFN,0),U)," on " S Y=APSPDATE D DD^%DT W Y,".",! Q Q E ; D FIND Q:'$D(APSPRX) S (X,C)=0 K APSPC F S X=$O(APSPRX(X)) Q:X'=+X S C=C+1,APSPC(C)=X D DISP S DIR(0)="NO^1:"_APSPHIGH,DIR("A")="Edit which of the above" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 Q:$D(DIRUT) Q:Y="" S APSPSEL=+Y,APSPX=APSPC(APSPSEL),DA=+$P(APSPRX(APSPX),U,5),DIE="^AUPNVSIT(",DR=2101 D ^DIE K DIE,DR,DA,DIU,DIY,DIW,DIV S DIE="^AUPNVMED(",DA=+$P(APSPRX(APSPX),U,4),DR=$S($P(^AUPNVMED(DA,0),U,4)]"":".04;",1:"")_".05;.06;.07" D ^DIE K DIE,DA,DR,DIY,DIW,DIU,DIV G E D ;delete D FIND Q:'$D(APSPRX) S (X,C)=0 K APSPC F S X=$O(APSPRX(X)) Q:X'=+X S C=C+1,APSPC(C)=X D DISP S DIR(0)="NO^1:"_APSPHIGH,DIR("A")="Edit which of the above" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 Q:$D(DIRUT) Q:Y="" S APSPSEL=+Y,APSPX=APSPC(APSPSEL) S DIR(0)="Y",DIR("A")="Are you sure you want to delete this MEDICATION",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 Q:$D(DIRUT) I 'Y W !,"Okay, not deleted." Q S DIE="^AUPNVMED(",DA=+$P(APSPRX(APSPX),U,4),DR=".01///@" D ^DIE K DIE,DA,DR,DIY,DIW,DIU,DIV ;9/14/99 Version 6 Patch 2- changed APCDVLDT to APCDVDLT ;the incorrect variable was keeping the delete flag from being set ;in the AUPNVSIT global for the affected visit - next 2 lines changed ;S V=$P(APSPRX(APSPX),U,5) I '$P(^AUPNVSIT(V,0),U,9) S APCDVLDT=V D ^APCDVDLT K APCDVDLT S V=$P(APSPRX(APSPX),U,5) I '$P(^AUPNVSIT(V,0),U,9) S APCDVDLT=V D ^APCDVDLT K APCDVDLT ;IHS/DSD/LWJ/POC 09/14/99 (fixed APCDVDLT being set) ;IHS/DSD/LWJ/POC 09/14/99 - end of fix to APCDVLDT (version 6,patch 2) G D Q DISP ;display outside rx W:$D(IOF) @IOF W !,"Outside Rx's for ",$P(^DPT(DFN,0),U)," on " S Y=APSPDATE D DD^%DT W Y,":",! S (APSPY,APSPHIGH)=0 F S APSPY=$O(APSPC(APSPY)) Q:APSPY'=+APSPY S APSPHIGH=APSPHIGH+1,X=APSPC(APSPY) S P=APSPC(APSPY),M=+$P(APSPRX(P),U,4) D .W !,APSPY,")",?5,"Drug Name: ",?22,$S($P(^AUPNVMED(M,0),U,4)]"":$P(^AUPNVMED(M,0),U,4),1:$P(^PSDRUG($P(^AUPNVMED(M,0),U),0),U)) .W !?5,"Where Dispensed: ",?22,$P($G(^AUPNVSIT($P(APSPRX(P),U,5),21)),U) .W !?5,"Sig:",?22,$P(^AUPNVMED(M,0),U,5),! .Q Q ; TEXT ; ;; ;;IHS PHARMACY MODULE/PCC Interface ;; ;;******************************* ;;* Update of OUTSIDE RX's * ;;******************************* ;; APSPORXF APSPORXF ;IHS/DSD/ENM - FUNNCTION CALLS FROM PCC ; [ 05/14/1998 4:04 PM ] ;;6.0;IHS PHARMACY MODIFICATIONS;**1**;09/03/97 ; ; ;function calls from pcc MEDS(DFN,APSPA,APSPBD,APSPED,APSPSC,APSPVT) ;EP - GET MEDS IN DATE RANGE FOR A PATIENT, SCREEN OPTIONALLY ON SERV CAT OR TYPE NEW APSPX,APSPDFE,APSPDAT,APSPV,APSPVR,APSPI,APSPC,APSPR,APSPER S APSPER=0 I 'DFN S APSPER=1 Q APSPER ;no patient I '$D(^DPT(DFN)) S APSPER=1 Q APSPER ;patient not valid I $G(APSPA)="" S APSPER=2 Q APSPER ;no array defined I $G(APSPSC)="" S APSPSC="" I $G(APSPVT)="" S APSPVT="" ;set up data fetcher call S APSPX=DFN_"^ALL MEDS" D .I APSPED="" S APSPED=DT .I APSPBD]""!(APSPED]"") S APSPX=APSPX_";DURING "_APSPBD_"-"_APSPED .Q S APSPDFE=$$^APCLDF(APSPX,"APSPDAT(") I APSPDFE S APSPER=3 Q APSPER ;date fetcher error I '$D(APSPDAT) Q APSPER S (APSPX,APSPC)=0 F S APSPX=$O(APSPDAT(APSPX)) Q:APSPX'=+APSPX D .S APSPV=$P(APSPDAT(APSPX),U,5),APSPVR=^AUPNVSIT(APSPV,0) .I APSPSC]"",APSPSC'[$P(APSPVR,U,7) Q .I APSPVT]"",APSPVT'[$P(APSPVR,U,3) Q .S APSPI=+$P(APSPDAT(APSPX),U,4),APSPR=^AUPNVMED(APSPI,0) .S A=APSPA_APSPX_")" S @A=APSPI_U_APSPV_U_$P(APSPDAT(APSPX),U)_U_$P(APSPR,U)_U_$P(APSPDAT(APSPX),U,2) .F X=4:1:8 S @A=@A_U_$P(APSPR,U,X) .S @A=@A_U_$P($G(^AUPNVSIT(APSPV,21)),U) .I $G(^AUPNVMED(APSPI,12)) F X=1:1:4 S @A=@A_U_$P(^AUPNVMED(APSPI,12),U,X) .Q Q APSPER ; START ;EP called from option to display all outside Rx/s W:$D(IOF) @IOF W !!?18,"DISPLAY OUTSIDE RX's",!! GETPAT ; D GETPAT^APSPORXA ; get patient I 'DFN D EXIT Q GETDATES ; BD ;get beginning date W ! S DIR(0)="D^:DT:EP",DIR("A")="Enter beginning Date for Rx display" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 I $D(DIRUT) G GETPAT S APSPBD=Y ED ;get ending date W ! S DIR(0)="D^"_APSPBD_":DT:EP",DIR("A")="Enter ending Date for Rx display" S Y=APSPBD D DD^%DT S DIR("B")=Y,Y="" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 I $D(DIRUT) G BD S APSPED=Y ; GETMEDS ; get vmeds to display K APSPQUIT S APSPERR=$$MEDS(DFN,"APSPORX(",APSPBD,APSPED,"E") I APSPERR W !!,$C(7),$C(7),"Error occurred when attempting to find outside Rx's!! Notify supervisor" D PAUSE G EXIT I '$D(APSPORX) W !!,$C(7),"No Outside Rx's on file for ",$P(^DPT(DFN,0),U),!,"in that time period",! D PAUSE G GETPAT S APSPPG=0 D HEAD S APSPY=0 F S APSPY=$O(APSPORX(APSPY)) Q:APSPY'=+APSPY!($D(APSPQUIT)) S X=APSPORX(APSPY) D .I $Y>(IOSL-4) D HEAD Q:$D(APSPQUIT) .;W !!,APSPY,")",?5,"Drug Name: ",?23,$S($P(X,U,5)]"":$P(X,U,5),1:$P(X,U,4)) .W !!,APSPY,")",?5,"Drug Name: ",?23,$S($P(X,U,6)]"":$P(X,U,6),1:$P(X,U,5)) ;IHS/DSD/ENM 01/06/98 OKCAO POC 12/15/97 .W !?5,"Where Dispensed: ",?21,$P(X,U,11) .W !?5,"Sig:",?23,$P(X,U,7) ;IHS/DSD/ENM 09/06/96 CHNG 5 TO A 7 .W !?5,"Quantity:",?23,$P(X,U,8),?40,"Days Prescribed:",?58,$P(X,U,9) ;IHS/DSD/ENM 09/06/96 CHNG 6 TO 8, 7 TO 9 .W !?5,"DATE PRESCRIBED: ",$$FMTE^XLFDT($P(X,U,3)) ;IHS/DSD/ENM/POC 05/11/98 .Q I '$D(APSPQUIT) S DIR("A")="End of Display. Hit return to continue" D PAUSE D EXIT Q ; PAUSE ; W ! S DIR(0)="E" D ^DIR K DIR W ! Q HEAD ;write header I 'APSPPG G HEAD1 I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APSPQUIT="" Q HEAD1 ; W:$D(IOF) @IOF W !,"Outside Rx's for ",$P(^DPT(DFN,0),U)," from ",! S Y=APSPBD D DD^%DT W Y S Y=APSPED D DD^%DT W " to ",Y,":" S APSPPG=APSPPG+1 Q EXIT ; K APSPBD,APSPED,APSPERR,APSPPG,APSPORX,APSPQUIT,APSPER,APSPY K X,Y,%DT,DIR D KILL^AUPNPAT Q APSPRESK APSPRESK ; IHS/DSD/ENM - BHAM ISC/SAB/ENM - RETURN TO STOCK ; [ 09/08/1999 3:14 PM ] ;;6.0;IHS PHARMACY MODIFICATIONS;**1,2**;09/03/97 ;MODIFIED VERSION OF PSORESK BY ENM S:$G(PSOFROM)']"" PSOFROM="RETURN" ;IHS/DSD/ENM 02/07/96 AC S PSIN=+$P(^PS(59.7,1,49.99),"^",2) ;IHS/DSD/ENM 6.14.95 Next 13 lines added for multi-lkup&view Rx data START G:$D(PSOSD)'>1 END ;IHS/DSD/ENM/POC 3/5/98 D INIT,LKUP G:PSORXED("QFLG") END D PARSE,EX G AC END D EX EMQ Q INIT S PSORXED("QFLG")=0 Q LKUP ;S PSONUM="RX",PSONUM("A")="Return to Stock",PSOQFLG=0 D EN1^PSONUM I PSOQFLG!($Q(PSOLIST)']"") S PSORXED("QFLG")=1 ;IHS/DSD/ENM 10/01/96 N PSOOPT S PSOOPT=0 ;IHS/DSD/ENM 10/01/96 S PSONUM("A")="Return to Stock ",PSOQFLG=0 D ^PSONUM I $G(PSOQFLG)']""!($Q(PSOLIST)']"") S PSORXED("QFLG")=1 ;IHS/DSD/ENM 10/30/97 K PSOQFLG Q ; PARSE F PSORXED("LIST")=1:1 Q:'$D(PSOLIST(PSORXED("LIST")))!PSORXED("QFLG") F PSORXED("I")=1:1:$L(PSOLIST(PSORXED("LIST"))) S PSORXED("IRXN")=$P(PSOLIST(PSORXED("LIST")),",",PSORXED("I")) D:+PSORXED("IRXN") BC Q BC ;W !! S DIR("A")="Enter PRESCRIPTION number",DIR("?")="^D HP^PSORESK",DIR(0)="FO" D ^DIR K DIR G:$D(DIRUT) EX S APSPX="" D ^APSPRXV S (X,Y)=APSPX9 ;IHS/DSD/ENM DISPLAY RX INFO ;G:$D(DIRUT) EX ;IHS/DSD/ENM 5.19.95 Q:APSPQ ;IHS/DSD/ENM 5.19.95 I X'["-" D BCI W:'$G(RXP) !,"INVALID Rx" G:'$G(RXP) EMQ G BC1 I X["-",$P(X,"-")'=$P(^DD("SITE",1),"^") W !,*7,*7," INVALID STATION NUMBER !!",*7,*7,! Q I X["-" S RXP=$P(X,"-",2) I '$D(^PSRX(+$G(RXP),0))!($G(RXP)']"") W !,*7,*7,*7," NON-EXISTENT Rx" Q G:$D(^PSRX(RXP,0)) BC1 W !,*7,*7,*7," IMPROPER BARCODE FORMAT" Q BC1 ; I $S('+$P($G(^PSRX(+RXP,0)),"^",15):0,$P(^(0),"^",15)=11:0,$P(^(0),"^",15)=12:0,1:1) D STAT Q S COPAYFLG=1,QDRUG=$P($G(^PSRX(RXP,0)),"^",6),QTY=$P($G(^(0)),"^",7) I $O(^PSRX(RXP,1,0)) G REF I $O(^PSRX(RXP,"P",0)) D Q:$D(DTOUT)!($D(DUOUT)) .S DIR(0)="SA^O:ORIGINAL;P:PARTIAL",DIR("B")="ORIGINAL",DIR("A",1)="",DIR("A",2)="There are Partials for this Rx.",DIR("A")="Which are you Returning To Stock? " .S DIR("?")=" Press return for Original. Enter 'P' for Partial" D ^DIR K DIR ;S XTYPE=$S(Y="O":"O",1:"P") G:Y="P" PAR S XTYPE=$S(Y="P":"P",1:"O") G:Y="P" PAR ;RX REF IN ACT LOG DEF ORIG I $P($G(^PSRX(RXP,2)),"^",15) W !,*7,*7,"Original fill for Rx # "_$P(^PSRX(RXP,0),"^")_" was RETURNED TO STOCK." Q I '$P($G(^PSRX(RXP,2)),"^",13),$P($G(^(2)),"^",2)'1 W !,"You must first enter the IHS site parameters dealing with",!,"prepack label sizes and widths . Thank you" S APSPRT("QUIT")=1 G INITX I $P(%APSITE,U,22)'>2 W !,"You must first enter a Prepack Label Width under the IHS site parameters. Thank you" S APSPRT("QUIT")=1 G INITX F I=16:1:19 S APSP(I)=+$P(%APSITE,U,I) F I=21:1:28 S APSP(I)=+$P(%APSITE,U,I) S APSP(29)=$P(%APSITE,U,29) S APSP(31)=+$P(%APSITE,U,31) S APSP("LINE1")=$P(%APSITE,U,32) S APSP("LINE2")=$P(%APSITE,U,33) S %ZIS="N",%ZIS("A")="Prepack Label Printer : " D ^%ZIS K %ZIS S:POP=0 APSPRT("IO")=ION S:POP=1 APSPRT("QUIT")=1 D EXPDATE ;Sets APSP("EXPDATE")=TODAY + 6 MONTHS S APSP("LASTP")=$S($D(^APSPP(31,"LAST")):$P(^APSPP(31,"LAST"),U,1),1:"") S APSP("LASTU")=$S($D(^APSPP(31,"LAST")):$P(^APSPP(31,"LAST"),U,2),1:"") INITX ; Exit point for INIT subroutine Q EXPDATE ; S X="T+6M" D ^%DT ;S APSP("EXPDATE")=$E(Y,4,5)_"/"_$E(Y,2,3) S APSP("EXPDATE")=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) ;IHS/DSD/ENM 07/14/99 Q EN ;EP ; S APSPGY="" F APSP=1:1:$L(APSP("SIG")," ") S X=$P(APSP("SIG")," ",APSP) S:X]"" APSPGY=APSPGY_X_" " S APSPS=1,APSPY=APSP(22)-2,APSPE=APSP(22)-1,APSPDR1=0 SIG1 F APSPF=APSPS:0:APSPY S APSPF=$F(APSPGY," ",APSPF) Q:'APSPF I APSPF'>APSPY,$L(APSPGY)>(APSP(22)-3) S APSPE=APSPF S X=$E(APSPGY,APSPS,APSPE-2),APSPS=APSPE,APSPY=APSPS+APSP(22)-4,APSPDR1=APSPDR1+1,APSPGY(APSPDR1)=X G SIG1:APSPE<$L(APSPGY) S APSPGC=APSPDR1,APSPGY(APSPDR1)=APSPGY(APSPDR1)_"." I $L(APSP("DRUG"))+$L(APSP("QTY"))+3>APSP(22) D SIG2 K APSP("SIG"),APSPE,APSPF,APSPS,APSPY Q SIG2 ; I $L(APSP("QTY"))+$L(APSPGY(APSPGC))+1 Prints labels D EOJ ; End of job Q ; PRINT S APSP("COPIES")=APSP("COPIES")-1 F I=1:1:APSP(24) W ! W !,?APSP(27),APSP("DRUG") I APSP(29)="Y" W ?APSP(31),APSP("DRUG") ;IHS/DSD/ENM/POC 05/13/98 y replaced w Y W !,?APSP(27),APSP("CNTL#")," ",APSPRT("EXPDATE") I APSP(29)="Y" W ?APSP(31),APSP("CNTL#")," ",APSPRT("EXPDATE") W ! ;IHS/DSD/ENM/POC y replaced w Y I +APSP("QTY")>1 W ?APSP(27),APSP("QTY") W:APSP(29)="Y" ?APSP(31),APSP("QTY") ;IHS/DSD/ENM/POC 05/13/98 y replaced w Y F I=1:1:APSP(25) W ! I APSP("COPIES")>0 G PRINT F I=1:1:(APSP(24)+APSP(25)*APSP(26)) W ! Q EOJ ; D ^%ZISC K APSP("DRUG"),APSPRT("EXPDATE"),APSP("COPIES"),APSP("CNTL#") K I,IOP Q APSPSLBL APSPSLBL ;IHS/DSD/JCM/ENM - IHS SUMMARY LABEL; [ 05/14/1998 4:04 PM ] ;;6.0;IHS PHARMACY MODIFICATIONS;**1**;09/03/97 ; ;THIS ROUTINE DOES THE PRINTING OF THE REFILL OR PARTIAL ;SUMMARY LABEL TO BE PLACED IN THE PATIENTS CHART IF THIS SITE ;PARAMETER HAS BEEN CHOSEN. PLEASE BE SURE THAT THE ESCAPE SEQUENCES ;FOR YOUR PRINTER HAVE BEEN ENTERED IN YOUR TERMINAL TYPE FILE FOR ;CONDENSED PRINT AND A SOFT RESET OR 10,12 PITCH. ; ;INPUT VARIABLES- N,ARRAY(N),PSZW,PSZK,PSZE,PSZL,PSZTAB,PSZB ; ;OUTPUT VARIABLES- C,NUM,PZX,PSZZL,PSZCW,PSZCTAB,E,I,POP ;DRUG,SIG,QTY,LENGTH,L ; ;EXTERNAL CALLS ^%ZIS ; EP ;IHS/DSD/ENM 11/09/94 ENTRY POINT FOR SUM OPT N APSPZZN ;IHS/DSD/ENM 02/24/97 D:'$D(PSOPAR) ^PSOLSET ;IHS/DSD/ENM 11/06/96 S APSPQFLG=0,APSPEDT=0 K ARRAY,APSPFLG ;IHS/DSD/ENM 01/29/97 ;D PARM^APSPLBL D PARM ;IHS/DSD/ENM 02/04/97 D PT^PSORX Q:APSPQFLG!(PSORX("QFLG")) EPP D PROFILE^PSORX S APSPID=1 ;IHS/DSD/ENM 5/3/95 USED IN PSOLIST S PSOOPT=-1,PSONUM="LIST" D EN^PSONUM ;I APSPEDT<1 D EOJ Q ;IHS/DSD/ENM 10/25/96 I $G(Y(1))']"" D EMSG,EOJ Q ;IHS/DSD/ENM 01/29/97 G:Y["^" EP DEV ; S %ZIS="QM" S %ZIS("A")="Enter SUMMARY Device: ",IOP=$G(PSOLAP) D ^%ZIS I POP G EOJ I $D(IO("Q")),IO=IO(0) W !!,"Sorry, you cannot queue to your screen or to a slave printer.",! K IO("Q") D ^%ZISC G DEV I IO=IO(0)!('$D(IO("Q"))) G EP1 S ZTRTN="EP1^APSPSLBL",ZTIO=ION F G="PSOPAR","%APSITE","PRF","PSZW","PSZK","PSZE","PSZL","PSZTAB","PSZB","PSONUM","PSOLIST(1)" S:$D(@G) ZTSAVE(G)="" S ZTDESC="Outpatient Pharm Summary Label" D ^%ZTLOAD G EOJ EP1 ;INITIALIZE Q:'$G(PSOLIST(1)) F APSPZ=1:1 S APSPRX=$P(PSOLIST(1),",",APSPZ) Q:APSPRX="" S N=APSPZ D ESET D EP2,EOJ Q ESET S APSP=^PSRX(APSPRX,0),APSPN=$P(APSP,U,2),APSPD=$P(APSP,U,6),APSPS=$P(APSP,U,10),APSPQ=$P(APSP,U,7),APSPF=$P(^PSRX(APSPRX,2),U,2) S APSXPS=$S($D(^PS(59,PSOSITE,0)):^(0),1:""),APSNBR=$P(APSXPS,"^",6) ;IHS/DSD/ENM 02/05/97 GET SITE NUMBER FROM SITE FILE S PNM=$P(^DPT(APSPN,0),U),PSZDRUG=$P(^PSDRUG(APSPD,0),U),APSHRN=$S($G(^AUPNPAT(APSPN,41,APSNBR,0)):$P(^(0),U,2),1:"") ;IHS/DSD/ENM 02/05/97 S ARRAY(N)=$E(PNM,1,PSZW-8)_"^"_APSPRX_"^"_PSZDRUG_"^"_APSPS_"^"_APSPQ_"^"_APSPF_"^"_APSHRN Q ; EP2 ;EP D PARM ;IHS/DSD/ENM 02/04/97 I $G(APSPZZN)]"" S N=APSPZZN ;IHS/DSD/ENM 07/31/96 S PZX=N,NUM=1,C=0,FDT=$P(ARRAY(N),"^",6) ;IHS/DSD/ENM/POC 05/11/98 NEXT FOUR LINES ;S PSOZSLBL("COPIES")=$S($P(%APSITE,"^",20)]"":$P(%APSITE,"^",20),1:1) S %AAPSITE=^APSPCTRL(PSOSITE,0) S PSOZSLBL("COPIES")=$S($P(%AAPSITE,"^",36)]"":$P(%AAPSITE,"^",36),1:1) K %AAPSITE ;SETS MY COUNTERS AND FDT= DATE FILLED ; S PSZZL=PSZL-1 ; THIS SETS THE NUMBER OF LINES TO PRINT ;AFTER THE PATIENTS NAME AND DATE IS PRINTED ; S PSZCW=$P(^APSPCTRL(PSOSITE,0),"^",14) ;IHS/DSD/ENM 08/01/96 S PSZCTAB=$P(^APSPCTRL(PSOSITE,0),"^",13) ;IHS/DSD/ENM 08/01/96 S:PSZCWPSZCW W !,?(PSZCTAB),DRUG," ",SIG,?(PSZCTAB+PSZCW-$L(QTY)),QTY Q ;THE ABOVE LINE PRINTS DRUG,SIG,QTY ON ONE LINE IF IT WILL FIT ; I C=(PSZZL-1) S N=N-1 W ! Q ;MAKES SURE THERE ARE TWO ;LINES AVAILABLE TO PRINT ON AND RESETS N TO CORRECT VALUE ; AND DOES A LINE FEED IF NOT ; W !,?(PSZCTAB),DRUG," ",$E(SIG,1,E) ;FIRST LINE ; I $E(SIG,E+1)'=" " I $E(SIG,E+1)'="" W "-" ; W !,?(PSZCTAB),$E(SIG,E+1,99) W ?(PSZCTAB+PSZCW-$L(QTY)),QTY ;THE ABOVE TWO LINES PRINT THE SECOND LINE ; S C=C+1 ; Q EMSG ;IHS/DSD/ENM 01/29/97 W !,"No Rx's found for this date....!" H 2 Q PARM ;EP ;IHS/DSD/ENM 02/04/97 MODULE FROM APSPLBL FOR SUMMARY LBLS ;SET LBL WTH/LN/MAR & GET DATA FROM FILE #9009033 S X=$S($D(^APSPCTRL(PSOSITE,0)):^(0),1:""),PSZW=$P(X,U,14),PSZL=$P(X,U,5),PSZB=$P(X,U,6),PSZE=$P(X,U,7),PSZK=$P(X,U,9),PSZTAB=$P(X,U,13) ;IHS/DSD/ENM 08/01/96 Q PSOAMIS PSOAMIS ;BHAM/ISC/SAB - PHARMACY AMIS REPORT [ 05/14/1998 4:04 PM ] ;;6.0;OUTPATIENT PHARMACY;**1**;09/03/97 W ! S %DT(0)=-DT,%DT("A")="PRINT AMIS STATS STARTING: " S %DT="EPXA" D ^%DT G:"^"[X END G PSOAMIS:Y<0 S SDT=Y K %DT(0) EDT W ! S %DT(0)=SDT,%DT("A")="ENDING STATS DATE: " D ^%DT G:"^"[X END S EDT=Y I Y<0 G EDT K %DT ZDIV ;IHS/DSD/ENM 10/16/96 ASK DIV MODULE ADDED S DIR(0)="Y",DIR("A")="Would you like all divisions",DIR("B")="YES",DIR("?")="Enter 'Yes' or 'No'" D ^DIR K DIR Q:$D(DTOUT)!$D(DIRUT) I "Yy"[$E(X) S APSPANS="A" G DEV S DIR(0)="PO^59:EMZ",DIR("A")="Select Division",DIR("?")="Enter the Division Name or Number " D ^DIR G:$D(DTOUT)!$D(DUOUT)!$D(DIRUT) END K DIR S APSPANS=+Y ;IHS/DSD/ENM 10/16/96 END OF ASK DIV MODULE DEV K %ZIS,IOP,ZTSK S %ZIS("B")="",PSOION=ION,%ZIS="QM" D ^%ZIS I POP S IOP=PSOION D ^%ZIS K IOP,PSOION G END ;I $E(IOST)["C"!($G(IOM)<132) W *7,!!,"PRINTOUT MUST BE SENT TO A 132 COLUMNS PRINTER !!",!! G DEV ;IHS/DSD/ENM DISABLED 5.15.95 K PSOION I $D(IO("Q")) S ZTDESC="Option to print the Outpatient AMIS report",ZTRTN="ENQ^PSOAMIS" F G="SDT","EDT","APSPANS" S:$D(@G) ZTSAVE(G)="" ;IHS/DSD/ENM 10/17/96 I K IO("Q") D ^%ZTLOAD W:$D(ZTSK) !,"Report Queued !" K G,ZTSAVE,ZTSK,Y,X,%DT G END ENQ ;START COMPUTATIONS I +APSPANS G DIV1 ;IHS/DSD/ENM 10/17/96 K ^TMP($J) D COM S PSDATE=SDT-1 F G=0:0 S PSDATE=$O(^PS(59.1,PSDATE)) Q:'PSDATE!(PSDATE>EDT)!($D(DUOUT)) F I=0:0 S I=$O(^PS(59.1,PSDATE,1,I)) Q:'I!($D(DUOUT)) D ;IHS/DSD/ENM 5/95 .;S ^TMP($J,I,PSDATE)=$P(^PS(59.1,PSDATE,1,I,0),"^",2,3)_"^"_$P(^PS(59.1,PSDATE,1,I,0),"^",5)_"^"_$P(^PS(59.1,PSDATE,1,I,0),"^",7,12)_"^"_$P(^PS(59.1,PSDATE,1,I,0),"^",14,17) D .S ^TMP($J,I,PSDATE)=$P(^PS(59.1,PSDATE,1,I,0),"^",2)_"^"_$P(^PS(59.1,PSDATE,1,I,0),"^",7,8)_"^"_$P(^PS(59.1,PSDATE,1,I,0),"^",10,12)_"^"_$P(^PS(59.1,PSDATE,1,I,0),"^",14,17) D ;IHS/DSD/ENM 10/95 ..F G=1:1:10 S DAT(I,G)=$P(^TMP($J,I,PSDATE),"^",G)+DAT(I,G),GT(G)=$P(^TMP($J,I,PSDATE),"^",G)+GT(G) ;IHS/DSD/ENM 10/95 S GR=0 F DIV=0:0 S DIV=$O(^PS(59,DIV)) Q:'DIV!($D(DUOUT)) D:GR SUB D RPT F PSDATE=0:0 S PSDATE=$O(^TMP($J,DIV,PSDATE)) Q:'PSDATE!($D(DUOUT)) S DAT=^(PSDATE) D:$Y+4>IOSL RPT D ZPDT D S GR=1,ST=DIV .F K=1:1:10 W $J($P(DAT,"^",K),9) ;IHS/DSD/ENM 10/95 .I $Y+4>IOSL,IOST["C-" D FZZ Q:$D(DUOUT)!($D(DTOUT)) ;IHS/DSD/ENM 5/95 Q:$D(DUOUT)!($D(DTOUT)) ;IHS/DSD/ENM 5/95 D SUB,GR ; END W ! W:$E(IOST)'["C" @IOF D ^%ZISC K GR,ST,%DT,G,SDT,EDT,X,Y,POP,^TMP($J),K,PSDATE,I,DAT,G,GT,DIV S:$D(ZTQUEUED) ZTREQ="@" Q ZPDT ;IHS/DSD/ENM 06/13/96 W !,$E(PSDATE,4,5)_"-"_$E(PSDATE,6,8)_"-"_$E(PSDATE,2,3) Q DIV1 F G=1:1:13 S (DAT(APSPANS,G),GT(G))=0 ;K ^TMP($J) S PSDATE=SDT-1 F G=0:0 S PSDATE=$O(^PS(59.1,PSDATE)) Q:'PSDATE!(PSDATE>EDT)!($D(DUOUT)) F I=0:0 S I=$O(^PS(59.1,PSDATE,1,I)) Q:'I!(I'=APSPANS)!($D(DUOUT)) D ;IHS/DSD/ENM 04/22/98 K ^TMP($J) S PSDATE=SDT-1 F G=0:0 S PSDATE=$O(^PS(59.1,PSDATE)) Q:'PSDATE!(PSDATE>EDT)!($D(DUOUT)) F I=0:0 S I=$O(^PS(59.1,PSDATE,1,I)) Q:'I!($D(DUOUT)) D ;IHS/DSD/ENM 04/22/98 .Q:I'=APSPANS ;IHS/DSD/ENM 04/22/98 .S ^TMP($J,I,PSDATE)=$P(^PS(59.1,PSDATE,1,I,0),"^",2)_"^"_$P(^PS(59.1,PSDATE,1,I,0),"^",7,8)_"^"_$P(^PS(59.1,PSDATE,1,I,0),"^",10,12)_"^"_$P(^PS(59.1,PSDATE,1,I,0),"^",14,17) D ;IHS/DSD/ENM 10/95 ..F G=1:1:10 S DAT(I,G)=$P(^TMP($J,I,PSDATE),"^",G)+DAT(I,G),GT(G)=$P(^TMP($J,I,PSDATE),"^",G)+GT(G) ;IHS/DSD/ENM 10/95 S GR=0 D RPT F PSDATE=0:0 S PSDATE=$O(^TMP($J,APSPANS,PSDATE)) Q:'PSDATE!($D(DUOUT)) S DAT=^(PSDATE) D:$Y+4>IOSL RPT D ZPDT D S GR=1,ST=APSPANS .F K=1:1:10 W $J($P(DAT,"^",K),9) ;IHS/DSD/ENM 10/95 .I $Y+4>IOSL,IOST["C-" D FZZ Q:$D(DUOUT)!($D(DTOUT)) ;IHS/DSD/ENM 5/95 Q:$D(DUOUT)!($D(DTOUT)) ;IHS/DSD/ENM 5/95 D SUB,GR ; END1 W ! W:$E(IOST)'["C" @IOF D ^%ZISC K GR,ST,%DT,G,SDT,EDT,X,Y,POP,^TMP($J),K,PSDATE,I,DAT,G,GT,DIV S:$D(ZTQUEUED) ZTREQ="@" Q ZPDT1 ;IHS/DSD/ENM 06/13/96 W !,$E(PSDATE,4,5)_"-"_$E(PSDATE,6,8)_"-"_$E(PSDATE,2,3) Q RPT ; HEADER Q:$D(DUOUT)!($D(DTOUT)) U IO W @IOF,!?55,"A M I S R E P O R T",!!?40,"FROM "_$E(SDT,4,5)_"-"_$E(SDT,6,7)_"-"_$E(SDT,2,3),?60,"TO "_$E(EDT,4,5)_"-"_$E(EDT,6,7)_"-"_$E(EDT,2,3)_" DIVISION: "_$P(^PS(59,$S(APSPANS="A":DIV,1:+APSPANS),0),"^") W !!,"DATE " F K=1:1:10 W $J($P("INPAT^OTHER^CNTLD^PAT REQ^FEE^STAFF^NEW^REFILL^WINDOW^MAIL","^",K),9) W ! F K=1:1:132 W "-" Q COM ;COMPILE SUB-TOTALS AND GRAND TOTALS F DIV=0:0 S DIV=$O(^PS(59,DIV)) Q:'DIV F G=1:1:13 S (DAT(DIV,G),GT(G))=0 Q SUB ;PRINT SUB TOTALS W !,"SUB-TOTALS",!,?8 F K=1:1:10 W:$D(ST) $J(DAT(ST,K),9) ;IHS/DSD/ENM 5/95 I $Y+4>IOSL,IOST["C-" D FZZ Q:$D(DUOUT)!($D(DTOUT)) ;IHS/DSD/ENM 5/95 W:$Y+4>IOSL @IOF W !?8 F K=1:1:10 W $J("-------",9) ;IHS/DSD/ENM 10/95 Q GR ;PRINT GRAND TOTALS I $Y+4>IOSL,IOST["C-" D FZZ Q:$D(DUOUT)!($D(DTOUT)) ;IHS/DSD/ENM 5/95 W:$Y+4>IOSL @IOF W !?8 F K=1:1:10 W $J("-------",9) ;IHS/DSD/ENM 10/95 W !,"GRAND TOTALS",!,?8 F K=1:1:10 W $J(GT(K),9) W ! Q FZZ ;IHS/DSD/ENM CAUSE A PAUSE 5.95 K DTOUT,DUOUT,DIR S DIR("?")="Enter '^' to halt or Press Return to Continue",DIR(0)="FO",DIR("A")="Press Return to Continue or '^' to Halt" D ^DIR Q PSOCAN1 PSOCAN1 ;BHAM/ISC/JMB - MODULAR RX CANCEL WITH SPEED CANCEL ABILITY ; 2/22/93 [ 06/08/1998 9:10 AM ] ;;6.0;OUTPATIENT PHARMACY;**1**;09/03/97 ;;6.0;OUTPATIENT PHARMACY;**6,84**;09/03/97 ;IHS/DSD/ENM IHSHOOK module added ;10.25.93 PAT K X,PSODFN,ASKED,BC,DELCNT,WARN ;W ! S DIR("A")="Are you entering the patient name or barcode",DIR(0)="SBO^P:Patient Name;B:Barcode" ;IHS/DSD/ENM 6.7.95 BELOW DISABLED, ABOVE COPIED AND MODIFIED ;K X,PSODFN,ASKED,BC,DELCNT,WARN W ! S DIR("A")="Are you entering the patient name or barcode",DIR(0)="SBO^P:Patient Name;B:Barcode" ;S DIR("?")="Enter a P if you are going to enter the patient name. Enter a B if you are going to enter or wand the barcode." ;D ^DIR K DIR G:$D(DIRUT) ^PSOCAN S BC=Y S BC="P" ;IHS/DSD/ENM 9-28-95 BC ;S OUT=0 I BC="B" W ! S DIR("A")="Enter/wand barcode",DIR(0)="FO^5:20",DIR("?")="Enter the barcode number or wand the barcode to change all of the prescription suspense dates for one patient" D ^DIR K DIR G:$G(DIRUT) PAT S BCNUM=Y D ;.D PSOINST^PSOSUPAT Q:OUT S RX=$P(BCNUM,"-",2) I $D(^PSRX(RX,0)) S PSODFN=$P(^PSRX(RX,0),"^",2) W " ",$P($G(^DPT(PSODFN,0)),"^") ;.I '$D(^PSRX(RX,0)) W !,*7,"NO PRESCRIPTION RECORD FOR THIS BARCODE." S OUT=1 ;G:OUT BC NAM W ! S DIC(0)="AEMZQ",DIC="^DPT(" D ^DIC K DIC G:$D(DTOUT)!($D(DUOUT))!(Y<0) ^PSOCAN S PSODFN=+Y ;IHS/DSD/ENM NEXT LINE COPIED AND MODIFIED ABOVE 6.7.95 ;I BC="P" W ! S DIC(0)="AEMZQ",DIC="^DPT(" D ^DIC K DIC G:$D(DTOUT)!($D(DUOUT))!(Y<0) PAT S PSODFN=+Y ENM ;EP FROM APSPCAN LBL PRINT LINE IHS/DSD/ENM 03/27/97 I BC="LL" S PSFROM="N" D CHK^PSOCAN Q:DEAD K PSOSD D ^PSOBUILD S PSOOPT=-1 D ^PSODSPL Q:'$D(PSOSD) D ENM1 Q ;IHS/DSD/ENM 03/27/97 S PSFROM="N" D CHK^PSOCAN G:DEAD NAM K PSOSD D ^PSOBUILD S PSOOPT=-1 D ^PSODSPL G:'$D(PSOSD)&($G(BC)'="LL") NAM ;IHS/DSD/ENM 03/31/97 ;IHS/DSD/ENM 03/27/97 ENM1 LINE TAG ADDED TO NEXT LINE ENM1 W ! S DIR("A")="Cancel/reinstate all or specific Rx#'s?",DIR(0)="SBO^A:ALL Rx's;S:SPECIFIC Rx's",DIR("?")="Enter the letter A for all listed Rx's OR the letter for specific Rx's." D ^DIR K DIR G:$G(DIRUT)&($G(BC)'="LL") PAT I Y=""&($G(BC)="LL") Q ;IHS/DSD/ENM 03/31/97 S ALL=Y G:Y="S" LINE D COM G:'$D(INCOM)&($G(BC)'="LL") NAM S (DRG,DRUG,IN)="",II=0 F S DRUG=$O(PSOSD(DRUG)) Q:DRUG="" S II=II+1,DRG=DRUG D PSPEED ;IHS/DSD/ENM 03/31/97 I BC="LL" D ASK Q ;IHS/DSD/ENM 03/31/97 D ASK G PAT LINE W !! S DIR(0)="LO^1:"_PSOSD,DIR("A")="ENTER THE LINE #",DIR("?",1)="Enter the line number(s) displayed to the left of the Rx#." S DIR("?",2)=" Separate the numbers with commas (Example: 3,8,10,7),",DIR("?",3)=" OR a dash (Example: 12-20), OR a combination of commas and",DIR("?",4)=" dashes (Example: 3-5,1,12)." S DIR("?")="Do not exceed 245 characters including commas and dashes." D ^DIR K DIR G:$G(DIRUT) KILL I Y["." W !?53,*7,"INVALID LINE NUMBER(S)." G LINE S LINE=Y K PSCAN,PSOCAN S (DRG,IN)="" F CNT=1:1 S DRG=$O(PSOSD(DRG)) Q:DRG="" S PSOCAN(CNT)=$P(PSOSD(DRG),"^") F CNT=1:1 S PLINE=$P(LINE,",",CNT) Q:'$P(LINE,",",CNT) S IN=$S(IN="":+PSOCAN(PLINE),1:IN_","_+PSOCAN(PLINE)) D SPEED G:BC="P" PAT G:BC="B" BC ;IHS/DSD/ENM 9/28/95 Q:BC="LL" ;IHS/DSD/ENM 10/23/97 PSPEED S DA=$P(PSOSD(DRG),"^"),RX=$P($G(^PSRX(DA,0)),"^") D SPEED1 Q:PSPOP SHOW S DRG=+$P(^PSRX(DA,0),"^",6),DRG=$S($D(^PSDRUG(DRG,0)):$P(^(0),"^"),1:"") PSHOW S LC=0 W !,$P(^PSRX(DA,0),"^")," ",DRG,?52,$S($D(^DPT(+$P(^PSRX(DA,0),"^",2),0)):$P(^(0),"^"),1:"PATIENT UNKNOWN") I REA="C" W !?25,"RX TO BE CANCELLED",! G SHOW1 W !?21,"*** RX TO BE REINSTATED ***",! SHOW1 S LC=LC+3 I LC>20 R !,"PRESS RETURN TO CONTINUE",X:DTIME G:X'="" SHOW1 S LC=0 Q SPEED1 S PSPOP=0 I $G(PSODIV),+$P($G(^PSRX(DA,2)),"^",9)'=$G(PSOSITE) D DIV^PSOCAN K STAT S STAT=+$P(^PSRX(DA,0),"^",15),REA=$E("C00CCCCCCC00R0",STAT+1) I REA=0!(PSPOP) S PSINV(RX)="" Q S:REA'=0&('PSPOP) PSCAN(RX)=DA_"^"_REA Q AREC S:'$G(DEAD) REA=$P(PSCAN($P(^PSRX(DA,0),"^")),"^",2) S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(DA,"A",SUB)) Q:'SUB S ACNT=SUB S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(DA,1,RF)) Q:'RF S RFCNT=RF D NOW^%DTC S ^PSRX(DA,"A",0)="^52.3DA^"_(ACNT+1)_"^"_(ACNT+1) L +^PSRX(DA) S ^PSRX(DA,"A",ACNT+1,0)=%_"^"_REA_"^"_DUZ_"^"_RFCNT_"^"_$S($G(MSG)]"":MSG,1:$G(ACOM)_$G(INCOM)) L -^PSRX(DA) S ACOM="" D EXP^PSOHELP1 IHSHOOK ;Data link to IHS/PCC (cancel/reinstate) ;IHS/DSD/ENM 10/25/94 I $P(%APSITE,U,15)="Y" S APSRX=DA,APSREA=REA D ^APSPCCC I $P(^PSRX(DA,0),U,15)=12 K ^PS(55,PSODFN,"P","CP",DA) S:$P(^PSRX(DA,0),U,15)'=12 ^PS(55,PSODFN,"P","CP",DA)="" Q SPEED D COM Q:'$D(INCOM) K PSINV,PSCAN F II=1:1 S DA=$P(IN,",",II) Q:'$P(IN,",",II) I $D(^PSRX(DA,0)) S RX=$P(^(0),"^") S:DA<0 PSINV(RX)="" D:DA>0 SPEED1 G:'$D(PSCAN) INVALD S II="",RXCNT=0 F S II=$O(PSCAN(II)) Q:II="" S DA=+PSCAN(II),REA=$P(PSCAN(II),"^",2),RXCNT=RXCNT+1 D SHOW ; ASK G:'$D(PSCAN) INVALD W ! S DIR("A")="OK TO "_$S($G(RXCNT)>1:"CHANGE STATUS",REA="C":"CANCEL",1:"REINSTATE"),DIR(0)="Y",DIR("B")="N" D ^DIR K DIR Q:$G(DIRUT) I 'Y K PSCAN D INVALD Q S RX="" F S RX=$O(PSCAN(RX)) Q:RX="" D ACT D INVALD Q ACT S DA=+PSCAN(RX),REA=$P(PSCAN(RX),"^",2),II=RX,PSODFN=$P(^PSRX(DA,0),"^",2) I REA="R" D REINS^PSOCAN2 Q D CAN^PSOCAN Q INVALD K PSCAN Q:'$D(PSINV) W !! F I=1:1:80 W "=" W *7,!!,"The Following Rx Number(s) Are Invalid Choices, Expired, or Marked As Deleted:" S II="" F S II=$O(PSINV(II)) Q:II="" W !?10,II K PSINV G KILL Q LISTPAT S X="?",DIC(0)="EMQ",DIC="^DPT(" D ^DIC K DIC Q COM W ! S DIR("A")="COMMENTS",DIR(0)="F^1:75",DIR("?")="Comments must be entered. Comments must be 1 to 75 characters with no embedded ^'s" D ^DIR K DIR W ! Q:$G(DIRUT) G:Y=" " COM S INCOM=Y Q KILL K %,ACNT,ACOM,ACT,ALL,BCNUM,CNT,DA,DAYS360,DEAD,DFN,DRG,DIRUT,DR,DRUG,DTOUT,DUOUT,FDT,HOLD,I,II,IN,INCOM,IT,JJ,LC,LFD,LINE,LL,LPRT,LREF,LSI,NAME,NDF,NOEXP,NSF,OUT,RXSP,EN,WARN ;K PCNT,POP,PPL,PS,PSFROM,PSINV,PLINE,PSI,PSINV,PSOCAN,PSODFN,PSODRG,PSODRUG,PSONEW,PSOOPT,PSORX,PSOSD,PSPOP,PSRXDA,PSS,PSVC K PCNT,POP,PS,PSFROM,PSINV,PLINE,PSI,PSINV,PSOCAN,PSODFN,PSODRG,PSODRUG,PSONEW,PSOOPT,PSORX,PSOSD,PSPOP,PSRXDA,PSS,PSVC ;IHS/DSD/ENM/POC 6/8/98 PPL REMOVED K REA,RELDT,RF,RFDATE,RFCNT,RFL,RFL1,RFLL,RP,RX,RX0,RXCNT,RXDA,RXN,RXNUM,RXP,RXREC,RXREF,RXS,SDATE,SPCANC,SS,STAT,SUB,X,XFDT,XLPDT,XRELDT,Y D KVA^VADPT Q PSODGDGI PSODGDGI ;BHAM/ISC/SAB - DRUG/DRUG INTERACTION CHECKER ; 4/14/93 [ 05/14/1998 4:04 PM ] ;;6.0;OUTPATIENT PHARMACY;**1**;09/03/97 ;;6.0;OUTPATIENT PHARMACY;**1,52,118,128,131**;09/03/97 W !,"Checking for Drug/Drug Interactions !",! I '(PSODRUG("NDF")?1.N1"A"1.N),PSODRUG("DEA")'["S" W !,*7,*7,PSODRUG("NAME")," CANNOT BE CHECKED FOR INTERACTIONS. IT HAS NO ENTRY IN THE NATIONAL DRUG FILE!!" ;IHS/DSD/ENM/POC 02/2/98 WARN OF NO NDF ;IHS/DSD/ENM/POC 02/2/98 NEXT LINE Q:$G ADDED WHEN STOP AT CRITICAL AND DELETE DRUG SO WONT LOOP THRU OTHER INTERACTIONS S (CRIT,DRG,LSI,DGI,DGS,SER,SERS)="" F S DRG=$O(PSOSD(DRG)) Q:DRG=""!($G(PSORX("DFLG"))) I $P(PSOSD(DRG),"^",2)<10 D ;IHS/DSD/ENM 01/06/98 .;S NDF=$P(PSOSD(DRG),"^",7),IT=$O(^PS(56,"APD",NDF,PSODRUG("NDF"),0)) I IT D BLD Q:+$G(PSORX("DFLG")) .S NDF=$P(PSOSD(DRG),"^",7) .S PSOZDEA=$P(^PSDRUG($P(^PSRX($P(PSOSD(DRG),U),0),U,6),0),U,3) .I '(NDF?1.N1"A"1.N),PSOZDEA'["S" W !,*7,*7,DRG," CANNOT BE CHECKED FOR INTERACTIONS WITH ",PSODRUG("NAME"),". ",DRG," HAS NO ENTRY IN NATIONAL DRUG FILE!!" ;IHS/DSD/ENM/POC 02/2/98 DONT LOOK AT SUPPLY ITEMS .S IT=$O(^PS(56,"APD",NDF,PSODRUG("NDF"),0)) I IT D BLD Q:+$G(PSORX("DFLG")) ;IHS/DSD/ENM/POC 02/2/98 ADDED FOR EACH DRUG WITH NO NDF ENTRY I '$D(^XUSEC("PSORPH",DUZ)),$G(DGI)]"" S:+CRIT PSONEW("STATUS")=4 W *7,!,"DRUG INTERACTON WITH RX #s: "_LSI,! K LSI,DRG,IT,NDF Q TECH ;add tech entry to RX VERIFY file (#52.4) I +CRIT S PSODI=1,(DIC,DLAYGO)="^PS(52.4,",DIC(0)="L",(DINUM,X)=PSOX("IRXN"),DIC("DR")="1////"_PSODFN_";2////"_DUZ_";4///"_DT_";7///"_1_";7.1///"_SER_";7.2///"_DGI K DD,DO D FILE^DICN S:$G(DGS)'="" $P(^PSRX(PSOX("IRXN"),"DRI"),"^")=SERS,$P(^PSRX(PSOX("IRXN"),"DRI"),"^",2)=DGS K PSODI,CRIT,DIC,DLAYGO,DINUM,DGI,DGS,SER,SERS Q BLD I $D(^XUSEC("PSORPH",DUZ)) S PSORX("PHARM")=DUZ D PHARM Q S LSI=$P(^PSRX(+PSOSD(DRG),0),"^")_"/"_$P(^PSDRUG($P(^(0),"^",6),0),"^")_","_LSI,DGI=$P(PSOSD(DRG),"^")_","_DGI,SER=IT_","_SER I $P(PSOSD(DRG),"^",9),$P(^PS(56,IT,0),"^",4)=1 S $P(^PSRX(+PSOSD(DRG),0),"^",15)=4 I $P(^PS(56,IT,0),"^",4)=2 S SERS=IT_","_SERS,DGS=$P(PSOSD(DRG),"^")_","_DGS S:$P(^PS(56,IT,0),"^",4)=1 CRIT=1 Q PHARM ;pharmacist verification of drug interaction S SER=^PS(56,IT,0),DIR("?",1)="Answer 'YES' if you DO want to "_$S($P(SER,"^",4)=1:"continue processing",1:"enter an intervention for")_" this medication," S DIR("?")=" 'NO' if you DON'T want to "_$S($P(SER,"^",4)=1:"continue processing",1:"enter an intervention for")_" this medication," W *7,*7 S DIR("A",1)="***"_$S($P(SER,"^",4)=1:"CRITICAL",1:"SIGNIFICANT")_"*** "_"Drug Interaction with RX #"_$P(^PSRX($P(PSOSD(DRG),"^"),0),"^"),DIR("A",2)="DRUG: "_DRG S DIR(0)="SA^1:YES;0:NO",DIR("A")="Do you want to "_$S($P(SER,"^",4)=1:"Continue? ",1:"Intervene? "),DIR("B")="Y" D ^DIR I 'Y,$P(SER,"^",4)=1 S PSORX("DFLG")=1,DGI="" K DIR,DTOUT,DIRUT,DIROUT,DUOUT I Y,$P(SER,"^",4)=1 S PSORX("INTERVENE")=1,DGI="" K DIR,DTOUT,DIRUT,DIROUT,DUOUT G CRI Q I 'Y,$P(SER,"^",4)=2 K DIR,DTOUT,DIRUT,DIROUT,DUOUT Q I Y,$P(SER,"^",4)=2 S PSORX("INTERVENE")=2,DGI="" K DIR,DTOUT,DIRUT,DIROUT,DUOUT D ^PSORXI K PSORX("INTERVENE") ;IHS/DSD/ENM 01/06/98 OKCAO/POC 12/3/97 Q CRI ;process new drug interactions entered by pharmacist ;K DIR G:$P(PSOSD(DRG),"^",9) CRITN S DIR("A",1)="",DIR("A",2)="Do you want to Process medication",DIR("A")=PSODRUG("NAME")_": ",DIR(0)="SA^1:PROCESS;0:ABORT ORDER ENTRY",DIR("B")="P" K DIR S DIR("A",1)="",DIR("A",2)="Do you want to Process medication",DIR("A")=PSODRUG("NAME")_": ",DIR(0)="SA^1:PROCESS;0:ABORT ORDER ENTRY",DIR("B")="P" ;IHS/DSD/ENM 01/06/98 OKCAO/POC 11/19/97 S DIR("?",1)="Enter '1' or 'P' to Activate medication",DIR("?")=" '0' or 'A' to Abort Order Entry process" D ^DIR K X1,DIR I 'Y S PSORX("DFLG")=1,DGI="" K DTOUT,DIRUT,DIROUT,DUOUT,PSORX("INTERVENE") Q I $P(SER,"^",4)=1 D .D SIG^XUSESIG I X1="" K PSORX("INTERVENE") S PSORX("DFLG")=1 Q .S PSORX("INTERVENE")=$P(SER,"^",4) .D ^PSORXI K PSORX("INTERVENE") ;IHS/DSD/ENM 01/06/98 OKCAO/POC 12/3/97 K DUOUT,DTOUT,DIRUT,DIROUT Q CRITN ;process multiple new drug interactions K X1,DIR S DIR("A",1)="",DIR("A",2)="Do you want to Delete: ",DIR("A",3)=" 1. NEW medication "_PSODRUG("NAME"),DIR("A",4)=" 2. ACTIVE New Rx #"_$P(^PSRX($P(PSOSD(DRG),"^"),0),"^")_" DRUG: "_DRG S DIR("A",5)=" 3. Both 1 and 2",DIR("A")=" 4. Continue ?: ",DIR(0)="SA^1:NEW MEDICATION;2:ACTIVE New RX #"_DGI_" "_DRG_";3:BOTH;4:CONTINUE" S DIR("?",1)="Enter '1' or 'N' to Delete New Medication and Activate RX #"_$P(^PSRX(+PSOSD(DRG),0),"^"),DIR("?",2)=" '2' or 'A' to Delete Active RX #"_$P(^PSRX(+PSOSD(DRG),0),"^")_" and Abort New Order Entry" S DIR("?",3)=" '3' or 'B' to Delete Both",DIR("?")=" '4' or 'C' to do nothing to either RX" D ^DIR K DIR I Y=1 S PSORX("DFLG")=1,DGI="",PSHLDDRG=PSODRUG("IEN") S PSODRUG("IEN")=$P(^PSRX($P(PSOSD(DRG),"^"),0),"^",6) D ^PSORXI S PSODRUG("IEN")=PSHLDDRG K DTOUT,DIRUT,DIROUT,DUOUT,PSHLDDRG Q I Y=2 S (DA,PSOHOLDA)=+PSOSD(DRG) D MESS,ENQ^PSORXDL S DA=PSOHOLDA D EN1^PSORXI(.DA),PPL K PSOSD(DRG),DTOUT,DIROUT,DIRUT,DUOUT,PSOHOLDA S PSOSD=PSOSD-1 Q I Y=3 S (DA,PSOHOLDA)=+PSOSD(DRG) S PSOSD=PSOSD-1,PSORX("DFLG")=1 D MESS,ENQ^PSORXDL S DA=PSOHOLDA D EN1^PSORXI(.DA),PPL K PSOSD(DRG),PSOHOLDA K DTOUT,DIROUT,DIRUT,DUOUT Q MESS W !!,"Deleting Rx: ",$P($G(^PSRX(DA,0)),"^")," ","Drug: ",$P($G(^PSDRUG($P(^PSRX(DA,0),"^",6),0)),"^"),! Q PPL F PSOSL=0:0 S PSOSL=$O(PSORX("PSOL",PSOSL)) Q:'PSOSL S PSOX2=PSOSL I $G(PSOX2) D .F PSOSL=0:1:PSOX2 S PSOSL=$O(PSORX("PSOL",PSOSL)) Q:'PSOSL F ENT=1:1:$L(PSORX("PSOL",PSOSL),",") I $P(PSORX("PSOL",PSOSL),",",ENT)=$P(PSOSD(DRG),"^") S PSOL(PSOSL,ENT)="" .F PSOL=0:0 S PSOL=$O(PSOL(PSOL)) Q:'PSOL F ENT=0:0 S ENT=$O(PSOL(PSOL,ENT)) Q:'ENT D ..I ENT=1,'$P(PSORX("PSOL",PSOL),",",2) K PSORX("PSOL",PSOL) Q ..I ENT=1,$P(PSORX("PSOL",PSOL),",",2) S PSORX("PSOL",PSOL)=$P(PSORX("PSOL",PSOL),",",2,99) Q ..S PSORX("PSOL",PSOL)=$P(PSORX("PSOL",PSOL),",",1,ENT-1)_","_$P(PSORX("PSOL",PSOL),",",ENT+1,99) K PSOX2,PSOSL,PSOL,ENT Q PSODIR1 PSODIR1 ;IHS/DSD/JCM - ASKS DATA FOR RX ORDER ENTRY CONT. [ 05/22/1998 2:24 PM ] ;;6.0;OUTPATIENT PHARMACY;**1**;09/03/97 ;;6.0;OUTPATIENT PHARMACY;**34,61,86,73,113**;09/03/97 ;---------------------------------------------------------------- PTSTAT(PSODIR) ; PTSTATEN K DIC,DR,DIE S PSODIR("FIELD")=0 ;S:$G(PSORX("PATIENT STATUS"))]"" DIC("B")=PSORX("PATIENT STATUS") ;S:$G(PSODIR("PATIENT STATUS"))]"" DIC("B")=PSODIR("PATIENT STATUS") ;S DIC("A")="PATIENT STATUS: " ;S DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC ;I X[U,$L(X)>1 D JUMP G PTSTATX ;I $D(DUOUT)!$D(DTOUT) S PSODIR("DFLG")=1 G PTSTATX ;I Y=-1 W *7," Required" G PTSTATEN ;S (PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"))=+Y S (PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"))=$G(APST) ;IHS/DSD/ENM 01/26/98 ;S PSODIR("PTST NODE")=Y(0) S PSODIR("PTST NODE")=$G(^PS(53,APST,0)) L +^PS(55,PSODFN):0 I '$T G PTSTATX ;S DIE="55",DR="3////"_+Y,DA=PSODFN D ^DIE K DIE,DA,D0 S DIE="55",DR="3////"_APST,DA=PSODFN D ^DIE K DIE,DA,D0 L -^PS(55,PSODFN) PTSTATX K DTOUT,DUOUT,X,Y,DA ;IHS/DSD/ENM 05/22/98 ;K DTOUT,DUOUT,X,Y,DA,APST Q SIG(PSODIR) ; K DIR,DIC S DIR(0)="52,10" S:$G(PSODRUG("SIG"))]"" DIR("B")=PSODRUG("SIG") S:$G(PSODIR("SIG"))]"" DIR("B")=PSODIR("SIG") D DIR G:PSODIR("DFLG")!PSODIR("FIELD") SIGX S PSODIR("SIG")=Y SIGX K X,Y Q QTY(PSODIR) ; K DIR,DIC S DIR(0)="52,7" S DIR("A")="QTY ( "_$G(PSODRUG("UNIT"))_" ) " S:$G(PSODIR("QTY"))]"" DIR("B")=PSODIR("QTY") D DIR G:PSODIR("DFLG")!PSODIR("FIELD") QTYX S PSODIR("QTY")=Y QTYX K X,Y Q COPIES(PSODIR) ; K DIR,DIC S DIR(0)="52,10.6" S DIR("B")=$S($G(PSODIR("COPIES"))]"":PSODIR("COPIES"),1:1) D DIR G:PSODIR("DFLG")!PSODIR("FIELD") COPIESX S PSODIR("COPIES")=Y COPIESX K X,Y Q ; DAYS(PSODIR) ; DAYSEN K DIR,DIC S X="PSORDAY" X ^%ZOSF("TEST") I $T D ^PSORDAY ;IHS/DSD/ENM/POC 05/11/98 DAYS SUPPLY CAL BY POC S DIR(0)="N^1:180" ;IHS/DSD/ENM 6/8/95 ;S DIR(0)="N^1:90" I $D(PSOZDAY) S DIR("B")=PSOZDAY K PSOZDAY ;IHS/DSD/ENM/POC 05/11/98 E S DIR("B")=$S($G(PSODIR("DAYS SUPPLY"))]"":PSODIR("DAYS SUPPLY"),$P($G(PSODIR("PTST NODE")),"^",3):$P(PSODIR("PTST NODE"),"^",3),1:30) ;IHS/DSD/ENM/POC 05/11/98 S DIR("A")="DAYS SUPPLY",DIR("?")="Enter a whole number between 1 and 180" ;IHS/DSD/ENM 02/06/96 90 REPLACED WITH 180 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") DAYSX I $G(PSODRUG("MAXDOSE"))]"",$G(PSODIR("QTY"))]"",(+PSODIR("QTY")/Y>PSODRUG("MAXDOSE")) W !,*7," Greater than Maximum dose of ",PSODRUG("MAXDOSE")," per day" G DAYSEN S PSODIR("DAYS SUPPLY")=Y DAYSX K X,Y Q ; REFILL(PSODIR) ; K DIR,DIC,PSOX ;S PSOX=$S(PSODRUG("DEA")["S":$P(PSOPAR,"^",9),1:5) S PSOX=$S(PSODRUG("DEA")["S":$P(PSOPAR,"^",9),1:12) ;IHS/DSD/ENM 02/06/96 REFILL NBR INCREASED TO 12 S PSOX1=$P($G(PSODIR("PTST NODE")),"^",4) ;S PSOX=$S((PSOX=+$P(PSOPAR,"^",9))&(PSOX1=5)&(PSODRUG("DEA")["S"):PSOX,1:PSOX1) S PSOX=$S((PSOX=+$P(PSOPAR,"^",9))&(PSOX1=12)&(PSODRUG("DEA")["S"):PSOX,1:PSOX1) ;IHS/DSD/ENM 02/06/96 ;S PSOX=$S('PSOX:0,PSODIR("DAYS SUPPLY")=90:1,1:PSOX) S PSOX=$S('PSOX:0,PSODIR("DAYS SUPPLY")>120:1,1:PSOX) ;IHS/DSD/ENM 02/06/96 ;S PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1) S:PSODRUG("DEA")["S" PSOX=$S($P(PSOPAR,"^",9)'="":$P(PSOPAR,"^",9),1:PSOX) ;IHS/DSD/ENM 02/06/96 ABOVE AND BELOW LINE COPIED/MODIFIED S PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<31:11,PSDY'<31&(PSDY'>60):5,PSDY'<61&(PSDY'>90):3,PSDY'<91&(PSDY'>120):2,PSDY>120:1,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1) S:PSODRUG("DEA")["S" PSOX=$S($P(PSOPAR,"^",9)'="":$P(PSOPAR,"^",9),1:PSOX) I PSODRUG("DEA")["A",PSODRUG("DEA")'["B" W !,"No refills allowed on Narcotics ..",! S:$D(PSODIR("FIELD")) PSODIR("FIELD")=0 G REFILLX S DIR(0)="N^0:"_PSOX,DIR("A")="# OF REFILLS" ;IHS/DSD/ENM 09/27/94 NEXT LINE DEFAULT SET TO 0 ;S DIR("B")=$S($G(PSODIR("# OF REFILLS"))]"":PSODIR("# OF REFILLS"),$G(PSOX1)]""&(PSOX>PSOX1)&(PSODRUG("DEA")["S"):PSOX1,1:PSOX) S DIR("B")=$S($G(PSODIR("# OF REFILLS"))]"":PSODIR("# OF REFILLS"),$G(PSOX1)]""&(PSOX>PSOX1)&(PSODRUG("DEA")["S"):PSOX1,1:0) ;IHS/DSD/ENM 9-27-94 S DIR("?")="Enter a whole number. The maximum is set by the DAYS SUPPLY field." D DIR G:PSODIR("DFLG")!PSODIR("FIELD") REFILLX S PSODIR("# OF REFILLS")=Y REFILLX S:'$D(PSODIR("# OF REFILLS")) PSODIR("# OF REFILLS")=0 K X,Y,PSOX,PSOX1,PSDY,PSDY1 Q CM(PSODIR) ;IHS/DSD/ENM CHRONIC MED ENTER/ED 10-05-94 K DIR,DIC S DIR(0)="52,9999999.02" S DIR("B")=$S($G(PSODIR("CM"))]"":PSODIR("CM"),1:"N") D DIR G:PSODIR("DFLG")!PSODIR("FIELD") CMX S PSODIR("CM")=Y,APSP("CM")=Y ;IHS/DSD/ENM 09/19/96 CMX K X,Y Q ; DIR ; S PSODIR("FIELD")=0 G:$G(DIR(0))']"" DIRX D ^DIR K DIR,DIE,DIC,DA I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1 S PSODIR("DFLG")=1 G DIRX I X[U,$L(X)>1 D JUMP DIRX K DIRUT,DTOUT,DUOUT,DIROUT,PSOX Q ; JUMP ; S X=$P(X,"^",2),DIC="^DD(52,",DIC(0)="QM" D ^DIC K DIC I Y=-1 S PSODIR("FIELD")=PSODIR("FLD") G JUMPX I $G(PSONEW1)=0 D JUMP^PSONEW1 G JUMPX I $G(PSOREF1)=0 D JUMP^PSOREF1 G JUMPX I $G(PSONEW3)=0 D JUMP^PSONEW3 G JUMPX I $G(PSORENW3)=0 D JUMP^PSORENW3 G JUMPX JUMPX S X="^"_X Q PSODIR2 PSODIR2(PSODIR) ;IHS/DSD/JCM - RX ORDER ENTRY CONTD [ 05/14/1998 4:04 PM ] ;;6.0;OUTPATIENT PHARMACY;**1**;09/03/97 ;;6.0;OUTPATIENT PHARMACY;**21,79,94,115,136**;09/03/97 ;--------------------------------------------------------------------- ; EXP(PSODIR) ; ;IHS/DSD/ENM 09-28-94 DISABLE EXP DATE (PSG REQ) NOW SET IN APSPMAN ;K DIR,DIC ;I $G(PSODRUG("EXPIRATION DATE"))]"" S Y=PSODRUG("EXPIRATION DATE") X ^DD("DD") S PSORX("EXPIRATION DATE")=Y ;S DIR("A")="EXPIRES",DIR("B")=$S($G(PSORX("EXPIRATION DATE"))]"":PSORX("EXPIRATION DATE"),1:"T+6M") ;S DIR(0)="D^NOW::EX" ;S DIR("?")="Both the month and date are required." ;D DIR G:PSODIR("DFLG")!PSODIR("FIELD") EXPX ;D NOW^%DTC S X1=X,X2=182 D C^%DTC S PSODIR("EXPIRATION DATE")=X ;S PSODIR("EXPIRATION DATE")=Y EXPX ;K X,Y Q ; CLINIC(PSODIR) ; K DIR,DIC S PSODIR("FIELD")=0 S DIC=44,DIC(0)="AEQM",DIC("A")="CLINIC: ",DIC("S")="I '$P($G(^(""SL"")),""^"",5)" S:$G(PSORX("CLINIC"))]"" DIC("B")=PSORX("CLINIC") D ^DIC G:PSODIR("DFLG")!PSODIR("FIELD") CLINICX I +Y>0 S PSODIR("CLINIC")=+Y,PSORX("CLINIC")=$P(Y,"^",2) E S PSORX("CLINIC")="" CLINICX K X,Y,PSOX,DIC ;P136 Q ; MW(PSODIR) ;IHS/DSD/ENM 09/28/94 next three lines added to set 'window pickup' variable S PSODIR("MAIL/WINDOW")="W",PSORX("MAIL/WINDOW")="WINDOW" S (PSODIR("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))="" Q K DIR,DIC S DIR(0)="52,11" S DIR("B")=$S($G(PSORX("MAIL/WINDOW"))]"":PSORX("MAIL/WINDOW"),1:"WINDOW") D DIR G:PSODIR("DFLG")!PSODIR("FIELD") MWX I $G(Y(0))']"" S PSODIR("DFLG")=1 G MWX S PSODIR("MAIL/WINDOW")=Y,PSORX("MAIL/WINDOW")=Y(0) I $G(PSORX("EDIT"))]"",PSODIR("MAIL/WINDOW")'="W" K PSODIR("METHOD OF PICK-UP") MW1 G:PSODIR("MAIL/WINDOW")'="W"!('$P($G(PSOPAR),"^",12)) MWX S DIR(0)="52,35O" S:$G(PSORX("METHOD OF PICK-UP"))]"" DIR("B")=PSORX("METHOD OF PICK-UP") D DIR G:PSODIR("DFLG") MWX I X[U W !,"Cannot jump to another field ..",! G MW1 S (PSODIR("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))=Y MWX K X,Y Q ; RMK(PSODIR) ; RMKEN K DIR,DIC S DIR(0)="52,12" S:$G(PSODIR("REMARKS"))]"" DIR("B")=PSODIR("REMARKS") D DIR G:PSODIR("DFLG") RMKX I X[U W !,"Cannot jump to another field ..",! G RMKEN S:$L(X)>0 PSODIR("REMARKS")=X ;P136 RMKX K X,Y Q ; ISSDT(PSODIR) ; K DIR,DIC ;S DIR("A")="ISSUE DATE",DIR("B")=$S($G(PSORX("ISSUE DATE"))]"":PSORX("ISSUE DATE"),1:"TODAY") ;S DIR(0)="52,1" ;D DIR G:PSODIR("DFLG")!PSODIR("FIELD") ISSDTX ;S PSODIR("ISSUE DATE")=Y ;X ^DD("DD") S PSORX("ISSUE DATE")=Y ;IHS/DSD/ENM/POC 01/16/98 NEXT 8 LINES ADDED TO BRING BACK ENCOUNTER DT ISS ;S DIR(0)=$S('$P(%APSITE,U,36):"D^:DT:EX",1:"D^:DT:ET"),DIR("A")=$S('$P(%APSITE,U,36):"ISSUE DATE",1:"ENCOUNTER FORM DATE & TIME") S DIR(0)=$S('$P(%APSITE,U,36):"D^:DT:EX",1:"D^:-NOW:ET"),DIR("A")=$S('$P(%APSITE,U,36):"ISSUE DATE",1:"ISSUE/ENCOUNTER FORM DATE & TIME") I '$D(APSEFDT) S DIR("B")=$S('$P(%APSITE,U,36):"TODAY",1:"") I $D(APSEFDT) S Y=APSEFDT X ^DD("DD") S APSEFDT=Y,DIR("B")=APSEFDT S (PSONEW("FIELD"),PSORENW("FIELD"))=0 ;IHS/DSD/ENM/POC TO STOP LOOPING D ^DIR G:PSODIR("DFLG")!PSODIR("FIELD") ISSDTX S APSEDT=Y,PSODIR("ISSUE DATE")=Y\1 X ^DD("DD") S PSORX("ISSUE DATE")=Y S APSE=PSODIR("ISSUE DATE"),X1=DT,X2=-180 D C^%DTC I APSE1!(Y="") S PSODIR("DFLG")=1 G DIRX I X[U,$L(X)>1 D JUMP DIRX K DIRUT,DTOUT,DUOUT,DIROUT,PSOX Q ; JUMP ; S X=$P(X,"^",2),DIC="^DD(52,",DIC(0)="QM" D ^DIC K DIC I Y=-1 S PSODIR("FIELD")=PSODIR("FLD") G JUMPX I $G(PSONEW1)=0 D JUMP^PSONEW1 G JUMPX I $G(PSONEW3)=0 D JUMP^PSONEW3 G JUMPX I $G(PSORENW3)=0 D JUMP^PSORENW3 G JUMPX JUMPX S X="^"_X Q PSODRG PSODRG ;IHS/DSD/JCM - ORDER ENTRY DRUG SELECTION [ 05/22/1998 2:22 PM ] ;;6.0;OUTPATIENT PHARMACY;**1**;09/03/97 ;;6.0;OUTPATIENT PHARMACY;**40,131**;09/03/97 ;---------------------------------------------------------- START ; S (PSONEW("DFLG"),PSONEW("FIELD"),PSODRG("QFLG"))=0 D SELECT ; Select Drug I $G(PSORX("EDIT"))]"",'PSONEW("FIELD") D TRADE G:PSONEW("DFLG")!(PSODRG("QFLG")) END D SET ; Set various drug information D POST I PSORX("DFLG") S PSONEW("DFLG")=1 K:'$G(PSORX("EDIT")) PSORX("DFLG") ; Do any post selection action END D EOJ Q ;------------------------------------------------------------ ; SELECT ; K DIC,X,Y,PSODRUG("TRADE NAME") I $G(PSODRUG("IEN"))]"" S DIC("B")=PSODRUG("NAME"),PSONEW("OLD VAL")=PSODRUG("IEN") S DIC="^PSDRUG(",DIC(0)="MQEAZO",DIC("A")="DRUG: ",DIC("S")="I $S('$D(^PSDRUG(+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0),$S($P($G(^PSDRUG(+Y,2)),""^"",3)'[""O"":0,1:1)" D ^DIC K DIC ;IHS/DSD/ENM 01/31/97 NEXT LI COPIED MODIFIED/DISABLED ;S DIC="^PSDRUG(",DIC(0)="MQEAZ",DIC("A")="DRUG: ",DIC("S")="I $S('$D(^PSDRUG(+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0),$S($P($G(^PSDRUG(+Y,2)),""^"",3)'[""O"":0,1:1)" D ^DIC K DIC I X[U,$L(X)>1 S PSODIR("FLD")=PSONEW("FLD") D JUMP^PSODIR1 S:$G(PSODIR("FIELD")) PSONEW("FIELD")=PSODIR("FIELD") K PSODIR S PSODRG("QFLG")=1 G SELECTX I $D(DTOUT)!($D(DUOUT)) S PSONEW("DFLG")=1 G SELECTX I Y<0 G SELECT S:$G(PSONEW("OLD VAL"))=+Y PSODRG("QFLG")=1 K PSOY S PSOY=Y,PSOY(0)=Y(0) D ^APSPMAN ;IHS/DSD/ENM MANUFACTURER CALL 1-6-95 I $P(PSOY(0),"^")="OTHER DRUG"!($P(PSOY(0),"^")="OUTSIDE DRUG") D TRADE SELECTX K X,Y,DTOUT,DUOUT Q ; TRADE ; K DIR,DIC,DA,X,Y S DIR(0)="52,6.5" D ^DIR K DIR,DIC I $D(DIRUT) S:$D(DUOUT)!$D(DTOUT)&('$D(PSORX("EDIT"))) PSONEW("DFLG")=1 G TRADEX S PSODRUG("TRADE NAME")=Y TRADEX K DIRUT,DTOUT,DUOUT,X,Y Q ; SET ; S PSODRUG("IEN")=+PSOY,PSODRUG("VA CLASS")=$P(PSOY(0),"^",2) S PSODRUG("NAME")=$P(PSOY(0),"^") S PSODRUG("NDF")=$S($G(^PSDRUG(+PSOY,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0) S PSODRUG("MAXDOSE")=$P(PSOY(0),"^",4),PSODRUG("DEA")=$P(PSOY(0),"^",3) S PSODRUG("CLN")=$S($D(^PSDRUG(+PSOY,"ND")):+$P(^("ND"),"^",6),1:0) S PSODRUG("SIG")=$P(PSOY(0),"^",5) S PSODRUG("NDC")=$P($G(^PSDRUG(+PSOY,2)),"^",4) S PSODRUG("STKLVL")=$G(^PSDRUG(+PSOY,660.1)) G:$G(^PSDRUG(+PSOY,660))']"" SETX S PSOX1=$G(^PSDRUG(+PSOY,660)) S PSODRUG("COST")=$P($G(PSOX1),"^",6) S PSODRUG("UNIT")=$P($G(PSOX1),"^",8) ;S PSODRUG("EXPIRATION DATE")=$P($G(PSOX1),"^",9) SETX K PSOX1,PSOY Q ; POST ; S PSORX("DFLG")=0 ;I $G(DUZ("AG"))="I" D ^PSODRG99 ; IHS specific call D ^PSODRDUP ; Set PSORX("DFLG")=1 if process to stop S X="APSQDRDU" X ^%ZOSF("TEST") I $T D ^APSQDRDU ;IHS/DSD/ENM/POC 05/11/98 DUP OUTSIDE RX CK Q:$G(PSORX("DFLG")) ;D ^PSODGDGI D:$G(PSORX("INTERVENE"))]"" ^PSORXI G:PSORX("DFLG") POSTX D ^PSODGDGI G:PSORX("DFLG") POSTX ;IHS/DSD/ENM/POC 05/11/98 MULTI-INTERVENS S X="APSQDGDG" X ^%ZOSF("TEST") I $T D ^APSQDGDG G:PSORX("DFLG") POSTX ;IHS/DSD/ENM/POC 05/11/98 OUTSIDE RX CK S X="APSQALLE" X ^%ZOSF("TEST") I $T K PSORX("INTERVENE") ;IHS/DSD/ENM/POC 05/11/98 OUTSIDE RX CK S X="APSQALLE" X ^%ZOSF("TEST") I $T D EN^APSQALLE D:$G(PSORX("INTERVENE"))]"" ^PSORXI G:PSORX("DFLG") POSTX ;IHS/DSD/ENM/POC 05/11/98 OUTSIDE RX CK ; ;IHS/DSD/ENM NEXT LINE ROUTINE IS UNDER DEVELOPMENT ;D EN^APSPALG D:$G(PSORX("INTERVENE"))]"" ^PSORXI G:PSORX("DFLG") POSTX ;IHS/DSD/POC/ENM ADDED FOR ALLERGY CHECK D:$P($G(^PSDRUG(PSODRUG("IEN"),"CLOZ1")),"^")]"" CLOZ G:PSORX("DFLG") POSTX ; Do ^allergy check ;D ^PSODRDUP ; Set PSORX("DFLG")=1 if process to stop ; ^Do any other action revolving around the drug selection POSTX ; K PSORX("INTERVENE") Q ; EOJ ; K PSODRG Q ; CLOZ ; S ANQRTN=$P(^PSDRUG(PSODRUG("IEN"),"CLOZ1"),"^"),ANQX=0 S P(5)=PSODRUG("IEN"),DFN=PSODFN,X=ANQRTN X ^%ZOSF("TEST") I D @("^"_ANQRTN) S:$G(ANQX) PSORX("DFLG")=1 K P(5),ANQRTN,ANQX,X Q PSODSPL PSODSPL ;IHS/DSD/JCM - DISPLAY RX PROFILE TO SCREEN [ 05/14/1998 4:04 PM ] ;;6.0;OUTPATIENT PHARMACY;**1**;09/03/97 ;;6.0;OUTPATIENT PHARMACY;**128**;09/03/97 ; Input Variables: PSOSD(, ; Optional Inupt Variables: PSOOPT ; ; display profiles needs PSOOPT=3 from new PSOOPT=4 from refill, ; or PSOOPT=0 from anywhere ; PSOOPT=-1 to get numbered list but no refill/renew message ;--------------------------------------------------------------- START ; I $D(PSOSD)'>1 W !,"This patient has no prescriptions",! G END D EOJ D HD D SHOW END D EOJ Q ;----------------------------------------------------------------- SHOW ; S PSODRUG="",PSOQFLG=0 F PSOCNT=1:1 S PSODRUG=$O(PSOSD(PSODRUG)) Q:PSODRUG="" Q:PSOCNT>1000!PSOQFLG S PSODATA=PSOSD(PSODRUG) S:'$D(^PSRX(+PSODATA,0)) PSOCNT=PSOCNT-1 D:$D(^(0)) DISPL I PSOQFLG G SHOWX S X="APSQSHOW" X ^%ZOSF("TEST") I $T S EN="SHOW" D ^APSQSHOW ;IHS/DSD/ENM/POC 05/11/98 DISPLAY OUTSIDE RX I $D(PSOOPT),(PSOOPT>2) W !,?10,"* indicates prescription is not ",$P("^^renewable^refillable","^",PSOOPT) W !,?10,"(R) indicates last fill returned to stock" W !,?10,"(%) indicates this is a free text drug name not in drug file" ;IHS/DSD/ENM/POC 05/11/98 K DIR S DIR(0)="EA",DIR("A")="Press RETURN to continue: " D ^DIR S:'$D(DFN) DFN=PSODFN D GMRA^PSODEM SHOWX W ! K DIRUT,DTOUT,DUOUT,DIROUT S PSOCNT=PSOCNT-1 K PSODRUG Q ; HD ; I $Y+5>IOSL S (DX,DY)=0 X ^%ZOSF("XY") K DX,DY W !!!," # RX # DRUG",?44,"STAT QTY ISS-DT LST-FL REF-RM DAYS",! Q ; DISPL W ! I $D(PSOOPT),PSOOPT W $J(PSOCNT,2) W ?6,$P(^PSRX(+PSODATA,0),"^") I $G(^PSRX(+PSODATA,"IB")) W ?11,"$" W ?13," ",$E($P(PSODRUG,"^",1),1,30) W ?45,$E("ANRHPSR DECD",$P(PSODATA,"^",2)+1) I $D(PSOOPT),PSOOPT>2 W $S($L($P(PSODATA,"^",PSOOPT)):"*",1:"") W ?49,$J($P(^PSRX(+PSODATA,0),"^",7),3) S PSOID=$P(^(0),"^",13),PSOLF=+^(3) S APSPZDT(PSOLF,PSOCNT)=+PSODATA ;IHS/DSD/ENM 4.28.95 USED BY SUM L F PSOX=0:0 S PSOX=$O(^PSRX(+PSODATA,1,PSOX)) Q:'PSOX I +^PSRX(+PSODATA,1,PSOX,0)=PSOLF,$P(^PSRX(+PSODATA,1,PSOX,0),"^",16) S PSOLF=PSOLF_"^(R)" K PSOX I '$O(^PSRX(+PSODATA,1,0)),$P(^PSRX(+PSODATA,2),"^",15) S PSOLF=PSOLF_"^(R)" W ?53,$E(PSOID,4,5),"-",$E(PSOID,6,7),?60,$E(PSOLF,4,5),"-",$E(PSOLF,6,7),$P(PSOLF,"^",2),?68,$J($P(PSODATA,"^",6),2),?74,$J($P(PSODATA,"^",8),3) K PSODATA,PSOID,PSOLF ; I $Y+5>IOSL K DIR S DIR(0)="E" D ^DIR K DIR S:$D(DUOUT) PSOQFLG=1 K DIRUT,DTOUT,DUOUT,DIROUT D:'PSOQFLG HD ; Q ; EOJ ; K PSODRUG,PSODATA,PSOID,PSOLF,PSOCNT Q PSOHELP1 PSOHELP1 ;BHAM/ISC/SAB - OUTPATIENT HELP TEXT/UTILITY ROUTINE 2 [ 05/14/1998 5:27 PM ] ;;6.1;OUTPATIENT PHARMACY;**1**;03/13/98 ;;6.0;OUTPATIENT PHARMACY;**6,84**;09/03/97 2001 W !!,"Enter the lowest prescription number for this site.",!,"If this is the first time you are entering this field," W !,"you should pick a number LARGER than the last prescription number used.",!! Q ; 2002 W !!,"Enter the largest acceptable prescription number for this site.",!,"The difference between this number and the lowest prescription" W !,"number should be substantial. The system will not allow numbers",!,"larger than the one you choose. It will give a warning message",!,"and not allow entry of any more prescriptions.",!! Q ; 2003 W !!,"Enter the last prescription number used.",!,"If you are entering this for the first time, this number",!,"should be the same as the number you entered for LOW RX#" W !,"The system will take this number, increment it by one",!,"until it finds a number that has not been used, and then",!,"use that number for the next prescription",!! Q ;IHS/DSD/ENM 01/08/97 CLOZAPINE QUEUE REMOVED ;IHS/DSD/ENM 06/26/97 REF TO FILE 19 NOW LOOK AT 19.2 AUTOQ ;ENTRY POINT ;IHS/DSD/ENM 12/04/97 S APSPDA=$O(^DIC(19,"B","PSO AMIS COMPILE",0)) G:'APSPDA EXIT ;SETUP OPTION IN OPTION SCHEDULING FILE 19.2 IF IT DOESN'T EXIST S DA=$O(^DIC(19.2,"B",APSPDA,0)) G:'DA OPTX D AUTOQ1 Q ;CREATE OPTION OPTX S DIC="^DIC(19.2,",DIC(0)="MZ",X=APSPDA,DIC("DR")="6///24H" K DD,DO D FILE^DICN K DIC S APSPDA1=$O(^DIC(19.2,"B",APSPDA,0)) G:'APSPDA1 EXIT D AUTOQ1 Q EXIT K APSPDA,APSPDA1 Q AUTOQ1 ;IHS/DSD/ENM 12/04/97 S DR="W $P($G(^DIC(19,$P($G(Y(0)),""^""),0)),""^"",2);"_2,DIC(0)="ZM",(DIE,DIC)="^DIC(19.2," F X="PSO AMIS COMPILE","APSA AWP AUTO QUEUE" D ^DIC W ! S DA=+Y L +^DIC(19.2,DA) D ^DIE L -^DIC(19.2,DA) K Y W !! CLO K C,D,D0,DI,DQ,DA,DIE,DR,DIC,Y,X,APSPDA,APSPDA1 Q EXP ;reset "P","A" xref in 55 from cancel option I REA="C" K:$P(^PSRX(DA,2),"^",6) ^PS(55,PSODFN,"P","A",$P(^(2),"^",6),DA) S ^PS(55,PSODFN,"P","A",DT,DA)="",$P(^PSRX(DA,3),"^",5)=DT Q S PCD=+$P($G(^PSRX(DA,3)),"^",5) I 'PCD D K EXP,PCD,IFN Q .S (IFN,EXP)=0 .F S EXP=$O(^PS(55,PSODFN,"P","A",EXP)) Q:'EXP F S IFN=$O(^PS(55,PSODFN,"P","A",EXP,IFN)) Q:'IFN I IFN=DA K ^PS(55,PSODFN,"P","A",EXP,DA) S ^PS(55,PSODFN,"P","A",$P(^PSRX(DA,2),"^",6),DA)="" K ^PS(55,PSODFN,"P","A",PCD,DA) S ^PS(55,PSODFN,"P","A",$P(^PSRX(DA,2),"^",6),DA)="",$P(^PSRX(DA,3),"^",5)="" K PCD Q SREF ;set "P","A" xref in 55 from fileman I $P($G(^PSRX(X,0)),"^",15)=12,'$P($G(^PSRX(X,3)),"^",5) D Q .F PX=0:0 S PA=$O(^PSRX(X,"A",PX)) Q:'PX S:$P(^PSRX(X,"A",PX,0),"^",2)="C" PCD=$P($P(^PSRX(X,"A",PX,0),"^"),".") .I $G(PCD) S ^PS(55,DA(1),"P","A",PCD,X)="",$P(^PSRX(X,3),"^",5)=PCD .E S:$P($G(^PSRX(X,2)),"^",6) ^PS(55,DA(1),"P","A",$P(^PSRX(X,2),"^",6),X)="" .K PCD,PX I $P($G(^PSRX(X,0)),"^",15)=12,$P($G(^PSRX(X,3)),"^",5) S ^PS(55,DA(1),"P","A",$P(^PSRX(X,3),"^",5),X)="" Q S:$P($G(^PSRX(X,2)),"^",6) ^PS(55,DA(1),"P","A",$P(^PSRX(X,2),"^",6),X)="" Q KREF ;kill "P","A" xref in 55 from fileman K:+$P($G(^PSRX(X,2)),"^",6) ^PS(55,DA(1),"P","A",+$P(^PSRX(X,2),"^",6),X) I $P($G(^PSRX(X,0)),"^",15)=12,'$P($G(^PSRX(X,3)),"^",5) D K PCD,PX Q .F PX=0:0 S A=$O(^PSRX(X,"A",PX)) Q:'PX S:$P(^PSRX(X,"A",PX,0),"^",2)="C" PCD=$P($P(^PSRX(X,"A",PX,0),"^"),".") .I $G(PCD) K ^PS(55,DA(1),"P","A",PCD,X) I $P($G(^PSRX(X,0)),"^",15)=12,$P($G(^PSRX(X,3)),"^",5) K ^PS(55,DA(1),"P","A",$P(^PSRX(X,3),"^",5),X) Q DAYS1 ;EP W !,"This is the days supply of a refill!",! Q PSOKI001 PSOKI001 ;IHS/DSD/ENM - ; 12-MAY-1998 [ 05/13/1998 5:24 PM ] ;;6.0;OUTPATIENT PATCH (PSO*6.0*1);**1**;MAY 12, 1998 Q:'DIFQ(52) F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^DIC(52,0,"GL") ;;=^PSRX( ;;^DIC("B","PRESCRIPTION",52) ;;= ;;^DIC(52,"%",0) ;;=^1.005^2^2 ;;^DIC(52,"%",1,0) ;;=PS ;;^DIC(52,"%",2,0) ;;=PSO ;;^DIC(52,"%","B","PS",1) ;;= ;;^DIC(52,"%","B","PSO",2) ;;= ;;^DIC(52,"%D",0) ;;=^^8^8^2930716^^^^ ;;^DIC(52,"%D",1,0) ;;=Contains all outpatient RX data used by the outpatient pharmacy package. ;;^DIC(52,"%D",2,0) ;;=As the above indicates, this is the hub of the outpatient system. It will ;;^DIC(52,"%D",3,0) ;;=easily be the largest pharmacy file in time and is pointed to very heavily. ;;^DIC(52,"%D",4,0) ;;=Deletion of an entry in this file must be handled VERY carefully and is not ;;^DIC(52,"%D",5,0) ;;=allowed if refills have been issued. ;;^DIC(52,"%D",6,0) ;;= ;;^DIC(52,"%D",7,0) ;;=Of particular interest is that essentially all the history pertaining to a ;;^DIC(52,"%D",8,0) ;;=particular Rx is contained in each Rx entry. ;;^DD(52,0) ;;=FIELD^NL^9999999.11^63 ;;^DD(52,0,"DDA") ;;=Y ;;^DD(52,0,"DIK") ;;=PSOXZA ;;^DD(52,0,"DIKOLD") ;;=PSOXZA ;;^DD(52,0,"DT") ;;=2980512 ;;^DD(52,0,"ID",1) ;;=W "" ;;^DD(52,0,"ID",2) ;;=W "" ;;^DD(52,0,"ID",6) ;;=W:$D(^("0")) " ",$S($D(^PSDRUG(+$P(^("0"),U,6),0))#2:$P(^(0),U,1),1:""),$E(^PSRX(Y,0),0)_$S($P(^(0),U,15)=13:" ***MARKED FOR DELETION***",1:"") ;;^DD(52,0,"ID",108) ;;=W:$D(^("D")) " ",$P(^("D"),U,3) ;;^DD(52,0,"IX","AC",52,1) ;;= ;;^DD(52,0,"IX","ACP2",52,31) ;;= ;;^DD(52,0,"IX","ACP4",52.1,2) ;;= ;;^DD(52,0,"IX","AD",52,22) ;;= ;;^DD(52,0,"IX","AD",52.1,.01) ;;= ;;^DD(52,0,"IX","AD2",52,20) ;;= ;;^DD(52,0,"IX","AD3",52.1,8) ;;= ;;^DD(52,0,"IX","AD4",52.2,.09) ;;= ;;^DD(52,0,"IX","AE",52,22) ;;= ;;^DD(52,0,"IX","AF",52,6) ;;= ;;^DD(52,0,"IX","AG",52,26) ;;= ;;^DD(52,0,"IX","AH",52,99) ;;= ;;^DD(52,0,"IX","AI",52,26) ;;= ;;^DD(52,0,"IX","AJ",52,32.1) ;;= ;;^DD(52,0,"IX","AJ1",52.1,14) ;;= ;;^DD(52,0,"IX","AK",52,26.1) ;;= ;;^DD(52,0,"IX","AL",52,31) ;;= ;;^DD(52,0,"IX","AL1",52.1,17) ;;= ;;^DD(52,0,"IX","ANCO",52,109) ;;= ;;^DD(52,0,"IX","AP",52,100) ;;= ;;^DD(52,0,"IX","APCC",52,9999999.11) ;;= ;;^DD(52,0,"IX","APCC2",52.1,9999999.11) ;;= ;;^DD(52,0,"IX","B",52,.01) ;;= ;;^DD(52,0,"IX","C",52,2) ;;= ;;^DD(52,0,"IX","CP",52,9999999.02) ;;= ;;^DD(52,0,"IX","ZAL",52,31) ;;= ;;^DD(52,0,"IX","ZAL2",52.2,8) ;;= ;;^DD(52,0,"IX","ZAL3",52.1,17) ;;= ;;^DD(52,0,"NM","PRESCRIPTION") ;;= ;;^DD(52,0,"PT",2.5,.01) ;;= ;;^DD(52,0,"PT",50.0731,3) ;;= ;;^DD(52,0,"PT",52.4,.01) ;;= ;;^DD(52,0,"PT",52.4,3) ;;= ;;^DD(52,0,"PT",52.41,.01) ;;= ;;^DD(52,0,"PT",52.5,.01) ;;= ;;^DD(52,0,"PT",52.52,1) ;;= ;;^DD(52,0,"PT",52.8,.01) ;;= ;;^DD(52,0,"PT",52.9002,.01) ;;= ;;^DD(52,0,"PT",55.03,.01) ;;= ;;^DD(52,0,"PT",356,.08) ;;= ;;^DD(52,.01,0) ;;=RX #^RF^^0;1^K:$L(X)>11!($L(X)<1) X ;;^DD(52,.01,1,0) ;;=^.1^^-1 ;;^DD(52,.01,1,1,0) ;;=52^B ;;^DD(52,.01,1,1,1) ;;=S ^PSRX("B",$E(X,1,30),DA)="" ;;^DD(52,.01,1,1,2) ;;=K ^PSRX("B",$E(X,1,30),DA) ;;^DD(52,.01,3) ;;=TYPE A WHOLE NUMBER BETWEEN 1 AND 999999999 ;;^DD(52,.01,4) ;;=W *7,!?5,"ENTER A VALID PRESCRIPTION NUMBER",!?5,"OR A BARCODE PRESCRIPTION NUMBER",!?5,"OR 'P' TO GET A PATIENT PROFILE (works only if in OUTPATIENT package)" ;;^DD(52,.01,7.5) ;;= ;;^DD(52,.01,20,0) ;;=^.3LA^1^1 ;;^DD(52,.01,20,1,0) ;;=PSO ;;^DD(52,.01,21,0) ;;=^^1^1^2910724^ ;;^DD(52,.01,21,1,0) ;;=This is the prescription number ;;^DD(52,.01,"DEL",1,0) ;;=I 1 W *7,!?5,"DELETE THROUGH PACKAGE ONLY!" ;;^DD(52,.01,"DEL",52,0) ;;=S X1=$S($D(^PSRX(D0,2)):$P(^(2),"^",6),1:0) S:'X1 RX0=^(0),J=D0 D ^PSOEXDT:'X1 I DT'>$P(^(2),U,6),$O(^PSRX(DA,1,0)) W !?5,*7,"CANNOT DELETE PRESCRIPTIONS WITH REFILLS." ;;^DD(52,.01,"DT") ;;=2901126 ;;^DD(52,40,0) ;;=ACTIVITY LOG^52.3DA^^A;0 ;;^DD(52,40,9) ;;=^ ;;^DD(52,40,21,0) ;;=^^1^1^2980512^^^^ ;;^DD(52,40,21,1,0) ;;=Activity Log. ;;^DD(52,40,23,0) ;;=^^1^1^2980512^^^^ ;;^DD(52,40,23,1,0) ;;=Date. Multiple #52.3 (Add new entry without asking). ;;^DD(52,40,"DT") ;;=2930324 ;;^DD(52.3,0) ;;=ACTIVITY LOG SUB-FIELD^NL^3^8 ;;^DD(52.3,0,"DT") ;;=2980512 ;;^DD(52.3,0,"NM","ACTIVITY LOG") ;;= ;;^DD(52.3,0,"UP") ;;=52 ;;^DD(52.3,.01,0) ;;=ACTIVITY LOG^MD^^0;1^S %DT="ETX" D ^%DT S X=Y K:Y<1 X ;;^DD(52.3,.01,1,0) ;;=^.1^^0 ;;^DD(52.3,.01,21,0) ;;=^^1^1^2920427^^ ;;^DD(52.3,.01,21,1,0) ;;=Date when activity occured. ;;^DD(52.3,.01,23,0) ;;=^^1^1^2920427^^ ;;^DD(52.3,.01,23,1,0) ;;=Date (Multiply asked). ;;^DD(52.3,.01,"DT") ;;=2920428 ;;^DD(52.3,.02,0) ;;=REASON^S^H:HOLD;U:UNHOLD;C:CANCELLED;E:EDIT;L:LOST;P:PARTIAL;R:REINSTATE;W:REPRINT;S:SUSPENSED;I:RETURNED TO STOCK;V:INTERVENTION;D:DELETED;A:PENDING/DRUG INTERACTION;B:PROCESSED;^0;2^Q PSOKI002 PSOKI002 ;IHS/DSD/ENM - ; 12-MAY-1998 [ 05/13/1998 5:24 PM ] ;;6.0;OUTPATIENT PATCH (PSO*6.0*1);**1**;MAY 12, 1998 Q:'DIFQ(52) F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^DD(52.3,.02,3) ;;=Enter code to indicate the activity taking place for this prescription. ;;^DD(52.3,.02,21,0) ;;=^^1^1^2921001^^^^ ;;^DD(52.3,.02,21,1,0) ;;=What was done that caused activity to happen. ;;^DD(52.3,.02,23,0) ;;=^^4^4^2921001^^^^ ;;^DD(52.3,.02,23,1,0) ;;=Set 'H' for Hold, 'U' for Unhold, 'C' for Cancelled, 'E' for Edit, ;;^DD(52.3,.02,23,2,0) ;;='L' for Lost, 'P' for Partial, 'R' for Reinstate, 'W' for Reprint, ;;^DD(52.3,.02,23,3,0) ;;='S' for Suspensed, 'I' for Returned to Stock, 'V' for Intervention ;;^DD(52.3,.02,23,4,0) ;;='D' for Deleted, 'A' for Pending due to drug interactions, 'B' for Unpending. ;;^DD(52.3,.02,"DT") ;;=2921001 ;;^DD(52.3,.03,0) ;;=INITIATOR OF ACTIVITY^RP200'^VA(200,^0;3^Q ;;^DD(52.3,.03,3) ;;= ;;^DD(52.3,.03,21,0) ;;=^^1^1^2920428^^^ ;;^DD(52.3,.03,21,1,0) ;;=The name of the person entering an activity is entered. ;;^DD(52.3,.03,23,0) ;;=^^1^1^2920428^^^ ;;^DD(52.3,.03,23,1,0) ;;=(Required) Pointer. ;;^DD(52.3,.03,"DT") ;;=2920428 ;;^DD(52.3,.04,0) ;;=RX REFERENCE^S^0:ORIGINAL;1:FIRST REFILL;2:SECOND REFILL;3:THIRD REFILL;4:FOURTH REFILL;5:FIFTH REFILL;6:SIXTH REFILL;7:SEVENTH REFILL;8:EIGHTH REFILL;9:NINTH REFILL;10:TENTH REFILL;11:ELEVENTH REFILL;12:PARTIAL;^0;4^Q ;;^DD(52.3,.04,3) ;;=Contains the number of the fill. ;;^DD(52.3,.04,21,0) ;;=^^1^1^2980512^^^^ ;;^DD(52.3,.04,21,1,0) ;;=This field is used to indicate which fill the activity took place. ;;^DD(52.3,.04,23,0) ;;=^^5^5^2980512^^^^ ;;^DD(52.3,.04,23,1,0) ;;=Set '0' for Original, '1' for First Refill, '2' for Second Refill, ;;^DD(52.3,.04,23,2,0) ;;='3' for Third Refill, '4' for Fourth Refill, '5' for Fifth Refill, ;;^DD(52.3,.04,23,3,0) ;;='6' for Sixth Refill, '7' for Seventh Refill, '8' for Eighth Refill, ;;^DD(52.3,.04,23,4,0) ;;='9' for Ninth Refill, '10' for Tenth Refill, '11' for Eleventh Refill, ;;^DD(52.3,.04,23,5,0) ;;='12' for Partial. ;;^DD(52.3,.04,"DT") ;;=2980512 ;;^DD(52.3,.05,0) ;;=COMMENT^RF^^0;5^K:$L(X)>75!($L(X)<1) X ;;^DD(52.3,.05,3) ;;=ANSWER MUST BE 1-75 CHARACTERS IN LENGTH ;;^DD(52.3,.05,21,0) ;;=^^1^1^2920115^ ;;^DD(52.3,.05,21,1,0) ;;=Any additional comments. ;;^DD(52.3,.05,23,0) ;;=^^1^1^2920115^ ;;^DD(52.3,.05,23,1,0) ;;=(Required) Free Text. ;;^DD(52.3,.05,"DT") ;;=2820901 ;;^DD(52.3,1,0) ;;=FIELD EDITED^F^^1;1^K:$L(X)>25!($L(X)<5) X ;;^DD(52.3,1,3) ;;=Enter the name of the field that was edited. Answer must be 5-25 characters in length. ;;^DD(52.3,1,21,0) ;;=^^2^2^2920305^ ;;^DD(52.3,1,21,1,0) ;;=This field is used to indicate any editing to a data field of a presciption. ;;^DD(52.3,1,21,2,0) ;;=This field will contain the name of the field edited. ;;^DD(52.3,1,"DT") ;;=2920305 ;;^DD(52.3,2,0) ;;=OLD VALUE^F^^1;2^K:$L(X)>25!($L(X)<1) X ;;^DD(52.3,2,3) ;;=Enter the old value of the edited field of the RX. Answer must be 1-25 characters in length. ;;^DD(52.3,2,21,0) ;;=^^1^1^2930316^^ ;;^DD(52.3,2,21,1,0) ;;=This field is used to show the old value of an edited field. ;;^DD(52.3,2,"DT") ;;=2920305 ;;^DD(52.3,3,0) ;;=NEW VALUE^F^^1;3^K:$L(X)>25!($L(X)<1) X ;;^DD(52.3,3,3) ;;=Enter the new value of the edited field of the RX. Answer must be 1-25 characters in length. ;;^DD(52.3,3,21,0) ;;=^^1^1^2920305^ ;;^DD(52.3,3,21,1,0) ;;=This field is ued to show the new value of an edited field of a RX. PSOKI003 PSOKI003 ;IHS/DSD/ENM - ; 12-MAY-1998 [ 05/13/1998 5:24 PM ] ;;6.0;OUTPATIENT PATCH (PSO*6.0*1);**1**;MAY 12, 1998 F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^UTILITY(U,$J,"PKG",2328,0) ;;=OUTPATIENT PATCH (PSO*6*1)^PSOK^This is for IHS patch pso*6*1 ;;^UTILITY(U,$J,"PKG",2328,1,0) ;;=^^1^1^2980512^^^ ;;^UTILITY(U,$J,"PKG",2328,1,1,0) ;;=This is for IHS patch pso*6*1 ;;^UTILITY(U,$J,"PKG",2328,4,0) ;;=^9.44PA^1^1 ;;^UTILITY(U,$J,"PKG",2328,4,1,0) ;;=52 ;;^UTILITY(U,$J,"PKG",2328,4,1,1,0) ;;=^9.45A^1^1 ;;^UTILITY(U,$J,"PKG",2328,4,1,1,1,0) ;;=ACTIVITY LOG ;;^UTILITY(U,$J,"PKG",2328,4,1,1,"B","ACTIVITY LOG",1) ;;= ;;^UTILITY(U,$J,"PKG",2328,4,1,222) ;;=y^n^^n^^^n ;;^UTILITY(U,$J,"PKG",2328,4,"B",52,1) ;;= ;;^UTILITY(U,$J,"PKG",2328,5) ;;=IHS/DSD/ENM ;;^UTILITY(U,$J,"PKG",2328,7) ;;=IHS/DSD ;;^UTILITY(U,$J,"PKG",2328,22,0) ;;=^9.49I^1^1 ;;^UTILITY(U,$J,"PKG",2328,22,1,0) ;;=6^2980512 ;;^UTILITY(U,$J,"PKG",2328,22,1,1,0) ;;=^^2^2^2980512^ ;;^UTILITY(U,$J,"PKG",2328,22,1,1,1,0) ;;=The Rx Reference field contained a set of codes from 0 to 6. Additional ;;^UTILITY(U,$J,"PKG",2328,22,1,1,2,0) ;;=sets had to be created to allow 11 refills and/or partials. ;;^UTILITY(U,$J,"PKG",2328,22,"B",6,1) ;;= ;;^UTILITY(U,$J,"PKG",2328,"DEV") ;;=ENM/DSD ;;^UTILITY(U,$J,"SBF",52,52) ;;= ;;^UTILITY(U,$J,"SBF",52,52.3) ;;= PSOKINI1 PSOKINI1 ;IHS/DSD/ENM - ; 12-MAY-1998 [ 05/13/1998 5:25 PM ] ;;6.0;OUTPATIENT PATCH (PSO*6.0*1);**1**;MAY 12, 1998 ; LOADS AND INDEXES DD'S ; K DIF,DIK,D,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DFR,DTN,DIX,DZ D DT^DICRW S %=1,U="^",DSEC=1 S NO=$P("I 0^I $D(@X)#2,X[U",U,%) I %<1 K DIFQ Q ASK I %=1,$D(DIFQ(0)) W !,"SHALL I WRITE OVER FILE SECURITY CODES" S %=2 D YN^DICN S DSEC=%=1 I %<1 K DIFQ Q Q:'$D(DIFQ) S %=2 W !!,"ARE YOU SURE EVERYTHING'S OK" D YN^DICN I %-1 K DIFQ Q I $D(DIFKEP) F DIDIU=0:0 S DIDIU=$O(DIFKEP(DIDIU)) Q:DIDIU'>0 S DIU=DIDIU,DIU(0)=DIFKEP(DIDIU) D EN^DIU2 D DT^DICRW K ^UTILITY(U,$J),^UTILITY("DIK",$J) D WAIT^DICD S DN="^PSOKI" F R=1:1:3 D @(DN_$$B36(R)) W "." F S D=$O(^UTILITY(U,$J,"SBF","")) Q:D'>0 K:'DIFQ(D) ^(D) S D=$O(^(D,"")) I D>0 K ^(D) D IX DATA W "." S (D,DDF(1),DDT(0))=$O(^UTILITY(U,$J,0)) Q:D'>0 I DIFQR(D) S DTO=0,DMRG=1,DTO(0)=^(D),Z=^(D)_"0)",D0=^(D,0),@Z=D0,DFR(1)="^UTILITY(U,$J,DDF(1),D0,",DKP=DIFQR(D)'=2 F D0=0:0 S D0=$O(^UTILITY(U,$J,DDF(1),D0)) S:D0="" D0=-1 Q:'$D(^(D0,0)) S Z=^(0) D I^DITR K ^UTILITY(U,$J,DDF(1)),DDF,DDT,DTO,DFR,DFN,DTN G DATA ; W S Y=$P($T(@X),";",2) W !,"NOTE: This package also contains "_Y_"S",! Q:'$D(DIFQ(0)) S %=1 W ?6,"SHALL I WRITE OVER EXISTING "_Y_"S OF THE SAME NAME" D YN^DICN I '% W !?6,"Answer YES to replace the current "_Y_"S with the incoming ones." G W S:%=2 DIFQ(X)=0 K:%<0 DIFQ Q ; OPT ;OPTION RTN ;ROUTINE DOCUMENTATION NOTE FUN ;FUNCTION BUL ;BULLETIN KEY ;SECURITY KEY HEL ;HELP FRAME DIP ;PRINT TEMPLATE DIE ;INPUT TEMPLATE DIB ;SORT TEMPLATE DIS ;FORM ; SBF ;FILE AND SUB FILE NUMBERS IX W "." S DIK="A" F %=0:0 S DIK=$O(^DD(D,DIK)) Q:DIK="" K ^(DIK) S DA(1)=D,DIK="^DD("_D_"," D IXALL^DIK I $D(^DIC(D,"%",0)) S DIK="^DIC(D,""%""," G IXALL^DIK Q B36(X) Q $$N(X\(36*36)#36+1)_$$N(X\36#36+1)_$$N(X#36+1) N(%) Q $E("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",%) PSOKINI2 PSOKINI2 ;IHS/DSD/ENM - ; 12-MAY-1998 [ 05/13/1998 5:25 PM ] ;;6.0;OUTPATIENT PATCH (PSO*6.0*1);**1**;MAY 12, 1998 ; ; K ^UTILITY("DIFROM",$J),DIC S DIDUZ=0 S:$D(DUZ)#2 DIDUZ=DUZ S DUZ=.5 I $D(^DIC(9.2,0))#2,^(0)?1"HEL".E S (DIC,DLAYGO)=9.2,N="HEL",DIC(0)="LX" G ADD Q ; ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R'>0 S X=$P(^(R,0),U,1) W "." K DA D ^DIC I Y>0,'$D(DIFQ(N))!$P(Y,U,3) S ^UTILITY("DIFROM",$J,N,X)=+Y K ^DIC(9.2,+Y,1),^(2),^(3),^(10) S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y D %XY^%RCR S DIK=DIC HELP S R=$O(^UTILITY("DIFROM",$J,N,R)) Q:R="" W !,"'"_R_"' Help Frame filed." S DA=^(R) F X=0:0 S X=$O(^DIC(9.2,DA,2,X)) Q:'X S I=$S($D(^(X,0)):^(0),1:0),Y=$P(I,U,2) S:Y]"" Y=$O(^DIC(9.2,"B",Y,0)) S ^(0)=$P(^DIC(9.2,DA,2,X,0),U,1)_U_$S(Y>0:Y,1:"")_U_$P(^(0),U,3,99) S I=0 F X=0:0 S X=$O(^DIC(9.2,DA,10,X)) Q:'X I $D(^(X,0)) S Y=$P(^(0),U),Y=$S(Y]"":$O(^MAG("B",Y,0)),1:0) S:Y $P(^DIC(9.2,DA,10,X,0),U)=Y,I=I+1,%=X I 'Y K ^DIC(9.2,DA,10,X,0) I I S $P(^DIC(9.2,DA,10,0),U,3,4)=%_U_I IX D IX1^DIK G HELP ; U I $D(DIRUT) S DIFQ=1 W ! Q REP S DIR(0)="Y",DIR("A")="Shall I change the NAME of the file to "_DIF S DIR("??")="^D REP^DIFROMH1",DIR("B")="NO" D ^DIR G U:$D(DIRUT) I Y S DIE=1,DIFQ=0,DA=N,DR=".01////"_DIF D ^DIE Q S DIR("A")="Shall I replace your file with mine" S DIR("??")="^D AG^DIFROMH1" D ^DIR G U:$D(DIRUT)!'Y S DIU(0)="E",DIR("A")="Do you want to keep the Data" S DIR("??")="^D CHG^DIFROMH1" D ^DIR G U:$D(DIRUT) S:'Y DIU(0)=DIU(0)_"D" S DIR("A")="Do you want to keep the Templates" S DIR("??")="^D TEMP^DIFROMH1" D ^DIR G U:$D(DIRUT) S:'Y DIU(0)=DIU(0)_"T" S DIFQ(N)=1,DIFKEP(N)=DIU(0) W !?15," (",DIF,") " Q PSOKINI3 PSOKINI3 ;IHS/DSD/ENM - ; 12-MAY-1998 [ 05/13/1998 5:26 PM ] ;;6.0;OUTPATIENT PATCH (PSO*6.0*1);**1**;MAY 12, 1998 ; ; K ^UTILITY("DIFROM",$J) S DIC(0)="LX",(DIC,DLAYGO)=3.6,N="BUL" D ADD:$D(^XMB(3.6,0)) S X=0 F R=0:0 S X=$O(^UTILITY("DIFROM",$J,N,X)) Q:X="" W !,"'",X,"' BULLETIN FILED -- Remember to add mail groups for new bulletins." I $D(^DIC(9.4,0))#2,^(0)?1"PACK".E S N="PKG",(DIC,DLAYGO)=9.4 D ADD G NP:'$D(DA) S %=+$O(^DIC(9.4,DA,22,"B",DIFROM,0)) I $D(^DIC(9.4,DA,22,%,0)) S $P(^(0),U,3)=DT I $D(^DIC(9.4,DA,0))#2 S %=$P(^(0),U,4) I %]"" S %=$O(^DIC(9.2,"B",%,0)) S:%]"" $P(^DIC(9.4,DA,0),U,4)=% OR I $D(^ORD(100.99))&$O(^UTILITY(U,$J,"OR","")) D EN^PSOKINI4 NP K DIC,^UTILITY("DIFROM",$J) S DIC(0)="LX" I $D(^DIC(19,0))#2,^(0)?1"OPTION".E S (DIC,DLAYGO)=19,N="OPT" D ADD,OP I $D(^DIC(19.1,0))#2,($P(^(0),U)?1"SECUR".E)!($P(^(0),U)="KEY") S (DIC,DLAYGO)=19.1,N="KEY" D ADD K ^UTILITY("DIFROM",$J) I $D(^DIC(9.8,0))#2,^(0)?1"ROUTINE^".E S (DIC,DLAYGO)=9.8,N="RTN" D ADD S DIC=.5,DLAYGO=0,N="FUN" D ADD S DIC("S")="I $P(^(0),U,4)=DIFL" F N="DIPT","DIBT","DIE" S DIC=U_N_"(" D ADD K DIC("S") S N="DIST(.404,",DIC=U_N,DLAYGO=.404 D ADD S DIC("S")="I $P(^(0),U,8)=DIFL",N="DIST(.403,",DIC=U_N,DLAYGO=.403 D ADD K ^UTILITY(U,$J),DIC,DLAYGO F DIFR="DIE","DIPT" D DIEZ K ^UTILITY("DIFROM",$J) Q DIEZ I ^DD("VERSION")>17.4,'$D(DISYS) D OS^DII E S DISYS=^DD("OS") Q:'$D(^DD("OS",DISYS,"ZS")) S DIFR1="" DZ1 S DIFR1=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1)) Q:DIFR1="" F DIFR2=0:0 S DIFR2=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1,DIFR2)) Q:'DIFR2 S Y=DIFR2 I $D(@(U_DIFR_"(Y,""ROU"")")) K ^("ROU") I $D(^("ROUOLD")) S X=^("ROUOLD"),DMAX=^DD("ROU") D:X]"" @("EN^DI"_$E(DIFR,3)_"Z") G DZ1 ; OP S R=$O(^UTILITY("DIFROM",$J,N,R)) I R="" K ^UTILITY("DIFROM",$J) G Q W !,"'"_R_"' Option Filed" S DA=+^UTILITY("DIFROM",$J,N,R) G:$P(^(R),U,2,3)="XUCORE^"!($P(^(R),U,2,3)="XUCOMMAND^") OP I $D(^DIC(19,DA,220)) S %=$P(^(220),U) S:%]"" %=$O(^XMB(3.6,"B",%,0)) S $P(^DIC(19,DA,220),U)=%,%=$P(^(220),U,3) S:%]"" %=$O(^XMB(3.8,"B",%,0)) S $P(^DIC(19,DA,220),U,3)=% S %=$P(^DIC(19,DA,0),U,12) S:%]"" %=$O(^DIC(9.4,"B",%,0)) S $P(^DIC(19,DA,0),U,12)=%,%=$P(^(0),U,7),(DZ,DIX)=0 D:$D(^DIC(19,DA,10,"B")) KAD(DA) S:%]"" %=$O(^DIC(9.2,"B",%,0)) S $P(^DIC(19,DA,0),U,7)=%,%=$P(^(0),U,4),%="MOQXL"[% K ^(10,"B"),^("C") F X=0:0 S X=$O(^DIC(19,DA,10,X)) Q:'X S I=$S($D(^(X,0)):^(0),1:0),Y=$S($D(^(U)):^(U),1:"") K ^DIC(19,DA,10,X) I Y]"",% S D=$O(^DIC(19,"B",Y,0)) I D S ^DIC(19,DA,10,X,0)=D_U_$P(I,U,2,9),DZ=DZ+1,DIX=X S:% ^DIC(19,DA,10,0)="^19.01PI^"_DIX_U_DZ D IX1^DIK G OP ; ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R="" S X=$P(^(R,0),U),DIFL=$S(N="DIST(.403,":$P(^(0),U,8),N="DIST(.404,":$P(^(0),U,2),1:$P(^(0),U,4)) W "." K DA D ^DIC I Y>0,'$D(DIFQ($E(N,1,3)))!$P(Y,U,3) S Y=Y_U D A Q Q A I N="BUL" K % S %(0)=$G(@(DIC_"+Y,2,0)")) F %=0:0 S %=$O(@(DIC_"+Y,2,%)")) Q:'% S %(%)=$G(^(%,0)) K:N'="KEY"&(N'="OPT") @(DIC_"+Y)") S ^UTILITY("DIFROM",$J,N,X)=Y S:$E(N,1,2)="DI" ^(X,+Y)="" S:N="PKG" DIFROM(0)=+Y Q:$P(Y,U,2,3)="XUCORE^"!($P(Y,U,2,3)="XUCOMMAND^") I N="BUL",%(0)]"" S @(DIC_"+Y,2,0)")=%(0) F %=0:0 S %=$O(%(%)) Q:'% S @(DIC_"+Y,2,%,0)")=%(%) I $E(N,1,2)="DI",('DIFL)!('$D(^DD(+DIFL))) D .W !,"**WARNING--"_$S(N="DIE":"INPUT",N="DIPT":"PRINT",N="DIBT":"SORT",1:"FORM or BLOCK")_$S(N'["DIST":" template ",1:" ")_$P(Y,U,2)_" has been installed,",!,"but associated file "_DIFL_" is not on your system!" .Q I N="OPT" S:$P(^DIC(19,+Y,0),U,6)]"" DIOPT=$P(^(0),U,6) I $O(^UTILITY(U,$J,N,R,1,0)) K ^DIC(19,+Y,1) I N="DIST(.403," D BLK S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y,DIK=DIC D %XY^%RCR D IX1^DIK:N'="OPT" I N="OPT",$D(DIOPT) S:$P(^DIC(19,DA,0),U,6)="" $P(^(0),U,6)=DIOPT K DIOPT I N="DIST(.403," D .N DIFRVAL S DIFRVAL=$$VAL^DIFROMSS(.403,DA) .I DIFRVAL W !,"Compiling form: ",$P(^DIST(.403,DA,0),U) D EN^DDSZ(DA) Q .W !,"ERROR: Form: ",$P(^DIST(.403,DA,0),U)," cannot be compiled" .Q Q BLK F J=0:0 S J=$O(^UTILITY(U,$J,N,R,40,J)) Q:'J I $D(^(J,0)) S %=$P(^(0),U,2) S:%]"" %=$O(^DIST(.404,"B",%,0)) S:% $P(^UTILITY(U,$J,N,R,40,J,0),U,2)=% D B1 K A0,A1,A2,J,L Q B1 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,40,L)) Q:'L S A0=$G(^(L,0)),%=$P(A0,U) I %]"" S %=$O(^DIST(.404,"B",%,0)) I % S $P(A0,U)=%,^UTILITY(U,$J,N,R,40,J,"BLK",%,0)=A0 D .N X S X=0 .F S X=$O(^UTILITY(U,$J,N,R,40,J,40,L,X)) Q:X="" S ^UTILITY(U,$J,N,R,40,J,"BLK",%,X)=^(X) .Q S A0=$G(^UTILITY(U,$J,N,R,40,J,40,0)) Q:A0="" K ^UTILITY(U,$J,N,R,40,J,40) S (A1,A2)=0 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L)) Q:'L S ^UTILITY(U,$J,N,R,40,J,40,L,0)=^(L,0),A1=L,A2=A2+1 D .N X S X=0 .F S X=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L,X)) Q:X="" S ^UTILITY(U,$J,N,R,40,J,40,L,X)=^(X) .Q S $P(A0,U,3,4)=A1_U_A2,^UTILITY(U,$J,N,R,40,J,40,0)=A0 K ^UTILITY(U,$J,N,R,40,J,"BLK") Q KAD(D0) N D1,X S X=0 F S X=$O(^DIC(19,D0,10,"B",X)) Q:X'>0 S D1=0 F S D1=$O(^DIC(19,D0,10,"B",X,D1)) Q:D1'>0 K ^DIC(19,"AD",X,D0,D1) Q PSOKINI4 PSOKINI4 ;IHS/DSD/ENM - ; 12-MAY-1998 [ 05/13/1998 5:27 PM ] ;;6.0;OUTPATIENT PATCH (PSO*6.0*1);**1**;MAY 12, 1998 ; ; EN S DA(1)=1,DIK="^ORD(100.99,1,5," I $D(^ORD(100.99,1,5,DA)) D ^DIK S %X="^UTILITY(U,$J,""OR"","_$O(^UTILITY(U,$J,"OR",""))_",",%Y=DIK_DA_"," S:'$D(^ORD(100.99,1,5,0)) ^(0)="^100.995P^^" S $P(^(0),U,3,4)=DA_U_($P(^(0),U,4)+1) D %XY^%RCR S $P(^ORD(100.99,1,5,DA,0),U)=DA,%=$P(^(0),U,4) I %]"" S %=$O(^ORD(100.98,"B",%,0)) I %>0 S $P(^ORD(100.99,1,5,DA,0),U,4)=% D OR S DA(1)=1 D IX1^DIK Q OR S (N,I)=0,X="" F S N=$O(^ORD(100.99,1,5,DA,1,N)) Q:'N S X=$P(^(N,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,0)=% S X=N,I=I+1,(R,J)=0,Y="" D OR1 S:I $P(^ORD(100.99,1,5,DA,1,0),U,3,4)=X_U_I S (N,I)=0,X="" F S N=$O(^ORD(100.99,1,5,DA,5,N)) Q:'N S X=$P(^(N,0),U,3) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% $P(^ORD(100.99,1,5,DA,5,N,0),U,3)=% S X=N,I=I+1 S:I $P(^ORD(100.99,1,5,DA,5,0),U,3,4)=X_U_I K N,R,X,Y,I,J Q OR1 N X F S R=$O(^ORD(100.99,1,5,DA,1,N,1,R)) Q:'R S X=$P(^(R,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,1,R,0)=% S Y=R,J=J+1 S:J $P(^ORD(100.99,1,5,DA,1,N,1,0),U,3,4)=Y_U_J Q ADDP N I,J,N,R,DA,DLAYGO S %="" S DIC="^ORD(101,",DIC(0)="LX",DLAYGO=101 D FILE^DICN K DIC Q:Y=-1 S %=+Y Q PSOKINI5 PSOKINI5 ;IHS/DSD/ENM - ; 12-MAY-1998 [ 05/13/1998 5:27 PM ] ;;6.0;OUTPATIENT PATCH (PSO*6.0*1);**1**;MAY 12, 1998 K ^UTILITY("DIF",$J) S DIFRDIFI=1 F I=1:1:2 S ^UTILITY("DIF",$J,DIFRDIFI)=$T(IXF+I),DIFRDIFI=DIFRDIFI+1 Q IXF ;;OUTPATIENT PATCH (PSO*6*1)^PSOK ;;52Is;PRESCRIPTION;^PSRX(;1;y;n;;n;;;n ;; PSOKINIS PSOKINIS ;IHS/DSD/ENM - ; 12-MAY-1998 [ 05/13/1998 5:27 PM ] ;;6.0;OUTPATIENT PATCH (PSO*6.0*1);**1**;MAY 12, 1998 PAC(PKG,VER) ; called from package init (DIFROM7 created this routine) ; PKG = $T(IXF) of the INIT routine. ; VER is an array that is contained in DIFROM from the INIT routine ; N %,%I,%H,DATE,DIFROM,NOW,PACKAGE,RUN,SERVER,SITE,START,X,XMDUZ,XMSUB,XMTEXT,XMY,Y K ^TMP("PSOKINIS",$J) ; ; Site tracking updates only occur if run in a VA production primary domain ; account. I $G(^XMB("NETNAME"))'[".VA.GOV" Q Q:'$D(^%ZOSF("UCI")) Q:'$D(^%ZOSF("PROD")) X ^%ZOSF("UCI") I Y'=^%ZOSF("PROD") Q ; S SERVER="S.A5CSTS@FORUM.VA.GOV" S PACKAGE=$P($P(PKG,";",3),U) S SITE=$G(^XMB("NETNAME")) S START=$P($G(^DIC(9.4,VER(0),"PRE")),U,2) I '$L(START) S START="Unknown" D ; check if ok to use kernel functions .S X="XLFDT" X ^%ZOSF("TEST") I $T D Q ..S NOW=$$HTFM^XLFDT($H) ..S RUN="Unknown" I START S RUN=$$FMDIFF^XLFDT(NOW,START,3) ..S START=$$FMTE^XLFDT(START) ..S DATE=NOW\1 ..S NOW=$$FMTE^XLFDT(NOW) .D NOW^%DTC S NOW=%,DATE=X .S RUN="" ; don't bother to compute .S Y=START D DD^%DT S START=Y .S Y=NOW D DD^%DT S NOW=Y ; ; Message for server S ^TMP("PSOKINIS",$J,1,0)="PACKAGE INSTALL" S ^TMP("PSOKINIS",$J,2,0)="SITE: "_SITE S ^TMP("PSOKINIS",$J,3,0)="PACKAGE: "_PACKAGE S ^TMP("PSOKINIS",$J,4,0)="VERSION: "_VER S ^TMP("PSOKINIS",$J,5,0)="Start time: "_START S ^TMP("PSOKINIS",$J,6,0)="Completion time: "_NOW S ^TMP("PSOKINIS",$J,7,0)="Run time: "_RUN S ^TMP("PSOKINIS",$J,8,0)="DATE: "_DATE ; ; Data is sent to server on FORUM - S.A5CSTS S XMY(SERVER)="",XMDUZ=.5,XMTEXT="^TMP(""PSOKINIS"",$J,",XMSUB=PACKAGE_" VERSION "_VER_" INSTALLATION" D ^XMD K ^TMP("PSOKINIS",$J) Q PSOKINIT PSOKINIT ;IHS/DSD/ENM - ; 12-MAY-1998 [ 05/13/1998 5:28 PM ] ;;6.0;OUTPATIENT PATCH (PSO*6.0*1);**1**;MAY 12, 1998 ; K DIF,DIFQ,DIFQR,DIFQN,DIK,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DIFROM,DFR,DTN,DIX,DZ,DIRUT,DTOUT,DUOUT S DIOVRD=1,U="^",DIFQ=0,DIFROM="6" W !,"This version (#6) of 'PSOKINIT' was created on 12-MAY-1998" W !?9,"(at DEV/DSD, by VA FileMan V.21.0)",! I $D(^DD("VERSION")),^("VERSION")'<21 G GO ;W !,"FIRST, I'LL FRESHEN UP YOUR VA FILEMAN...." D N^DINIT I ^DD("VERSION")<21 W !,"but I need version 21 of the VA FileMan!" G Q GO ; EN ; ENTER HERE TO BYPASS THE PRE-INIT PROGRAM S DIFQ=0 K DIRUT,DTOUT,DUOUT F DIFRIR=1:1:1 S DIFRRTN="^PSOKINI"_$E("5",DIFRIR) D @DIFRRTN W:1 !,"I AM GOING TO SET UP THE FOLLOWING FILES:" F I=1:2:2 S DIF(I)=^UTILITY("DIF",$J,I) D 1 G Q:DIFQ!$D(DIRUT) K DIF(I) S DIFROM="6" D PKG:'$D(DIFROM(0)),^PSOKINI1 G Q:'$D(DIFQ) S DIK(0)="AB" F DIF=1:2:2 S %=^UTILITY("DIF",$J,DIF),DIK=$P(%,";",5),N=$P(%,";",3),D=$P(%,";",4)_U_N D D K DIFQ(N) K DIFQR D ^PSOKINI2,^PSOKINI3 L S DUZ=DIDUZ W:1 !,$C(7),"OK, I'M DONE.",!,"NO"_$P("TE THAT FILE",U,DSEC)_" SECURITY-CODE PROTECTION HAS BEEN MADE" I DIFROM F DIF=1:2:2 S %=^UTILITY("DIF",$J,DIF),N=+$P(%,";",3) I N,$P(%,";",8)="y" S ^DD(N,0,"VR")=DIFROM I DIFROM(0)>0 F %="PRE","INI","INIT" S:$D(DIFROM(%)) $P(^DIC(9.4,DIFROM(0),%),U,2)=DIFROM(%) I $G(DIFQN) S $P(^(0),U,3,4)=$P(DIFQN,U,2)_U_($P(^DIC(0),U,4)+DIFQN) K DIFQN I DIFROM,$D(^%ZTSK) S X="PSOKINIS" X ^%ZOSF("TEST") D:$T PAC^PSOKINIS($T(IXF),.DIFROM) S:DIFROM(0)>0 ^DIC(9.4,DIFROM(0),"VERSION")=DIFROM G Q^DIFROM0 D S:$D(^DIC(+N,0))[0 ^(0)=D S X=$D(@(DIK_"0)")),^(0)=D_U_$S(X#2:$P(^(0),U,3,9),1:U) S DIFQR=DIFQR(+N) I ^DD("VERSION")>17.5,$D(^DD(+N,0,"DIK"))#2 S X=^("DIK"),Y=+N,DMAX=^DD("ROU") D EN^DIKZ I DIFQR D IXALL^DIK:$O(@(DIK_"0)")) W "." Q R G REP^PSOKINI2 ; 1 S N=+$P(DIF(I),";",3),DIF=$P(DIF(I),";",4),S=$P(DIF(I),";",5) W !!?3,N,?13,DIF,$P(" (Partial Definition)",U,$P(DIF(I),";",6)),$P(" (including data)",U,$P(DIF(I),";",13)="y") S Z=$S($D(^DIC(N,0))#2:^(0),1:"") I Z="" S DIFQ(N)=1,DIFQN=$G(DIFQN)+1_U_N G S I $L($P(Z,DIF)) W $C(7),!,"*BUT YOU ALREADY HAVE '",$P(Z,U),"' AS FILE #",N,"!" D R Q:DIFQ G S:$D(DIFKEP(N)),1 S DIFQ(N)=$P(DIF(I),";",7)'="n" I $L(Z) W $C(7),!,"Note: You already have the '",$P(Z,U),"' File." S DIFQ(0)=1 S %=$E(^UTILITY("DIF",$J,I+1),4,245) I %]"" X % S DIFQ(N)=$T W:'$T !,"Screen on this Data Dictionary did not pass--DD will not be installed!" G S I $L(Z),$P(DIF(I),";",10)="y" S DIR("A")="Shall I write over the existing Data Definition",DIR("??")="^D DD^DIFROMH1",DIR("B")="YES",DIR(0)="Y" D ^DIR S DIFQ(N)=Y S S DIFQR(N)=0 Q:$P(DIF(I),";",13)'="y"!$D(DIRUT) I $P(DIF(I),";",15)="y",$O(@(S_"0)"))>0 S DIF=$P(DIF(I),";",14)="o",DIR("A")="Want my data "_$P("merged with^to overwrite",U,DIF+1)_" yours",DIR("??")="^D DTA^DIFROMH1",DIR(0)="Y" D ^DIR S DIFQR(N)=$S('Y:Y,1:Y+DIF) Q S %=$P(DIF(I),";",14)="o" W !,$C(7),"I will ",$P("MERGE^OVERWRITE",U,%+1)," your data with mine." S DIFQR(N)=%+1 Q Q W $C(7),!!,"NO UPDATING HAS OCCURRED!" G Q^DIFROM0 ; PKG S X=$P($T(IXF),";",3),DIC="^DIC(9.4,",DIC(0)="",DIC("S")="I $P(^(0),U,2)="""_$P(X,U,2)_"""",X=$P(X,U) D ^DIC S DIFROM(0)=+Y K DIC Q ; IXF ;;OUTPATIENT PATCH (PSO*6*1)^PSOK;238 PSOLSET PSOLSET ;BHAM/ISC/SAB - SITE PARAMETER SET UP [ 09/08/1999 12:11 PM ] VERS ;;6.0;OUTPATIENT PHARMACY;**1,2**;09/03/97 I '$D(DUZ) W !,*7,"DUZ Number must be defined !!",! G LEAVE W !,"Outpatient Pharmacy software - Version ",$P($T(VERS),";",3) OREO ;OREO entry bypasses into message S PSOBAR1="",PSOBARS=0 ;make sure we have one S PSOCNT=0 F I=0:0 S I=$O(^PS(59,I)) Q:'I S PSOCNT=PSOCNT+1,Y=I G DIV1:PSOCNT W !,*7 S DIR("A",1)="SITE PARAMETERS MUST BE SPECIFIED FOR AT LEAST ONE SITE." S DIR("A",2)="THIS IS USUALLY DONE BY THE PACKAGE CO-ORDINATOR.",DIR("A")="DO YOU WISH TO CONTINUE: ",DIR("B")="YES",DIR(0)="SA^Y:YES;N:NO",DIR("?")="Enter Y to edit site parameters or N to exit." D ^DIR G LEAVE:"Y"'[$E(X) W ! D ^PSOSITED G PSOLSET DIV1 G:PSOCNT=1 DIV3 S DIR(0)="SB^Y:YES;N:NO",DIR("?")="Enter 'Y' to select Division or 'N' to EXIT" I $D(^PS(59,"C",DUZ(2))) S Y=$O(^PS(59,"C",DUZ(2),0)) G DIV3 ;IHS/DSD/JCM 5/28/93 DIV2 I PSOCNT>1 W ! S DIC("A")="Division: ",DIC=59,DIC(0)="AEMQ" D ^DIC K DIC G:"^"[X FINAL I +Y<0 W *7 S DIR("A",1)="A 'DIVISION' must be selected!",DIR("A")="Do you want to try again?",DIR("B")="YES" D ^DIR G:"Y"'[$E(X) LEAVE G DIV2 DIV3 K DIR S PSOSITE=+Y W:PSOCNT>1 !!?10,"You are logged on under the ",$P(^PS(59,PSOSITE,0),"^")," division.",! S PSOPAR=$G(^PS(59,PSOSITE,1)),PSOPAR7=$G(^PS(59,PSOSITE,"IB")),PSOSYS=$G(^PS(59.7,1,40.1)) D CUTDATE^PSOFUNC ;IHS/DSD/ENM 10/7/94 PCC/PARAMETERS/HOOKS IHSH ;----------------------------------------------------------------- I $D(^APSPCTRL(PSOSITE,0)) S %APSITE=^(0) ;IHS/OHPRD/JCM 7/23/89 I $D(^APSPCTRL(PSOSITE,3)) S %APSQTYP=^(3),APSQTYPE=$P(^(3),"^",1) ;IHS/DSD/ENM/POC 06/10/98 GET PATIENT INFO LANGUAGE I $P($G(%APSITE),U,36)]"" S $P(%APSITE,U,20)=$P(%APSITE,U,36) ;IHS/DSD/ENM 11/21/97 SUMMARY LABEL COPIES PAR S $P(%APSITE,U,15)="",$P(%APSITE,U,36)="" ;IHS/DSD/ENM 10/12/95 MANUFACTURER PARAM SET S APSPMAN=$P($G(^APSPCTRL(PSOSITE,1)),U) ;IHS/DSD/ENM 10/12/95 DEFAULT OTHER LOCATION SET S APSPDOL=$P($G(^APSPCTRL(PSOSITE,1)),U,2) I $D(^AUTTSITE(1,0)),$P(^(0),U,8)="Y",'$D(^APCCCTRL(DUZ(2),0))#2 W !,*7,"ENTRY MUST BE MADE IN THE PCC MASTER CONTROL FILE FOR THIS LOCATION",!,"PLEASE NOTIFY YOUR SITE MANAGER ... NO LINKAGE TO PCC IS OCCURRING !" S PHARMACY("PKGE DFN")=$O(^DIC(9.4,"B","OUTPATIENT PHARMACY","")) I $P(%APSITE,U,36)]"",'$D(^APCCCTRL(DUZ(2),11,PHARMACY("PKGE DFN"),0))#2 W !,*7,"ENTRY MUST BE MADE IN THE PCC MASTER CONTROL FILE FOR THIS PACKAGE !",!,"PLEASE NOTIFY YOUR SITE MANAGER ... NO LINKAGE TO PCC IS OCCURRING !" I $D(^AUTTSITE(1,0)),$P(^(0),U,8)="Y",$D(^APCCCTRL(DUZ(2),0))#2,$D(^APCCCTRL(DUZ(2),11,PHARMACY("PKGE DFN"),0))#2,$P(^(0),U,2) S $P(%APSITE,U,15)="Y",$P(%APSITE,U,36)=$P(^APCCCTRL(DUZ(2),0),U,2) K PHARMACY("PKGE DFN") ;----------------------------------------------------------------- CPARM ;IHS/DSD/ENM 02/08/99 ADDED CHRONIC MED PARAM DEFAULT DAYS S PSOZZCP("DAYS")="" K PSOZP("FLG"),DIRUT,DTOUT S DIR(0)="NO^1:999:0" S DIR("B")=90,DIR("A")="Number of Days For Chronic Med Profile" D ^DIR I $D(DIRUT)!($D(DTOUT)) S PSOZCP("FLG")="" G CPARMX S PSOZZCP("DAYS")=$S(+Y>0:+Y,1:90) CPARMX ;----------------------------------------------------------------- S PSODIV=$S(($P(PSOSYS,"^",2))&('$P(PSOSYS,"^",3)):0,1:1) S PSOINST=000 I $D(^DD("SITE",1)) S PSOINST=^DD("SITE",1) I $D(DUZ),$D(^VA(200,+DUZ,0)) S PSOCLC=DUZ I $D(PSOREO) G EXIT ;No printer questions for OREO ;----------------------------------------------------------------- ZCM ;IHS/DSD/ENM 10/24/94 ASK CHRONIC MED QUEUE W !,"Pre-Select Chronic Med Profile Device? (Y/N) " S %=2 D YN^DICN W:%Y["?" !,"Answer 'Yes' if you want the Chronic Med Profiles to automatically print with new Rx's" G:%Y["?" ZCM S APSPCP=% CPLBL ;IHS/DSD/ENM 10/21/94 ADD CHRONIC MED DEVICE CALL I APSPCP=1 S %ZIS="MNQ",%ZIS("A")="Select Chronic Med Profile PRINTER: " D ^%ZIS K %ZIS,IO("Q"),IOP G:POP PLBL S APSPCPP=ION D ^%ZISC PLBL I $P(PSOPAR,"^",8) S %ZIS="MNQ",%ZIS("A")="Select PROFILE PRINTER: " D ^%ZIS K %ZIS,IO("Q"),IOP G:POP LBL S PSOPROP=ION D ^%ZISC LBL S %ZIS="MNQ",%ZIS("B")="",%ZIS("A")="Select LABEL PRINTER: " D ^%ZIS K %ZIS,IO("Q"),IOP G:POP EXIT S PSOLAP=ION ;IHS/DSD/ENM 04/17/97 F J=0,1 S @("PSOBAR"_J)="" I $D(^%ZIS(2,^%ZIS(1,IOS,"SUBTYPE"),"BAR"_J)) S @("PSOBAR"_J)=^("BAR"_J) S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",19),PSOIOS=IOS D ^%ZISC LASK K DIR S DIR("A")="OK TO ASSUME LABEL ALIGNMENT IS CORRECT ?",DIR("B")="YES",DIR(0)="SB^Y:YES;N:NO",DIR("?")="Enter Y if labels are aligned, N if they need to be aligned." D ^DIR G:$D(DUOUT)!($D(DTOUT))!($D(DIRUT))!($D(DIROUT))!(Y="Y") EXIT ;S IOP=$G(PSOLAP) D ^%ZIS K IOP I POP W !?5,"PRINTER IS BUSY. " G LASK U IO(0) W !,"ALIGN LABELS SO THAT A PERFORATION IS AT THE TOP OF THE",!,"PRINT HEAD AND THE LEFT SIDE IS AT COLUMN ZERO." ;R !,"PRESS RETURN WHEN READY:",X:DTIME Q:"^"=X!'$T D ^PSOLBLT D ^%ZISC R !,"PRESS RETURN WHEN READY:",X:DTIME Q:"^"=X!'$T ;D ^APSPLBLT D ^%ZISC ;IHS/DSD/ENM 10.13.93 P2 S IOP=$G(PSOLAP) D ^%ZIS K IOP I POP W !?5,"PRINTER IS BUSY. " G LASK D ^APSPLBLT D ^%ZISC ;IHS/DSD/ENM 10.13.93 K DIR S DIR("A")="IS THIS CORRECT ?",DIR("B")="YES",DIR(0)="SB^Y:YES;N:NO",DIR("?")="Enter Y if labels are aligned correctly, N if they need to be aligned." D ^DIR G:$D(DUOUT)!($D(DTOUT))!($D(DIRUT))!($D(DIROUT))!(Y="Y") EXIT G P2 LEAVE S XQUIT="" G FINAL Q W !?10,*7,"DEFAULT PRINTER FOR LABELS MUST BE ENTERED." G LBL ; EXIT D ^%ZISC K I,IOP,X,Y,%ZIS,DIC,J,DIR,X,Y,DTOUT,DIROUT,DIRUT,DUOUT Q ; FINAL ;EXIT ACTION FROM MAIN MENU - KILL AND QUIT K PSOCAP,PSOINST,PSOION,PSONULBL,PSOSITE7,PFIO,PSOIOS,X,Y,PSOSYS,PSODIV,PSOPAR,PSOPAR7,PSOLAP,PSOPROP,PSOCLC,PSOCNT,PSODTCUT,PSOSITE,PSOPRPAS,PSOBAR1,PSOBAR0,PSOBARS,SIG,DIR,DIRUT,DTOUT,DIROUT,DUOUT,I,%ZIS,DIC,J,XQUIT,PSOREL K APSPCP,APSPCPP,APSPMAN,APSPDOL,%APSITE,ZTSK,APCDALVR ;IHS/DSD/ENM 02/24/97 K PSOZZCP("DAYS") ;IHS/DSD/ENM 02/08/99 D ^APSPXUT Q PSOPTPST PSOPTPST ;IHS/DSD/JCM - POST PATIENT SELECTION ACTION [ 08/25/1999 2:56 PM ] ;;6.0;OUTPATIENT PHARMACY;**1,2**;09/03/97 ;;6.0;OUTPATIENT PHARMACY;**27,35,74,73,121**;09/03/97 ;--------------------------------------------------------- START ; S PSOQFLG=0 D GET ; Gets data from Patient file D DEAD G:PSOQFLG END ; Checks to see if patient still alive G:$G(PSOFROM("PTLKUP"))']"" END ; skips questions if not called by RX data entry D INP G:PSOQFLG END ;Checks to see if inpatient and whether to continue D CNH G:PSOQFLG END ; Checks to see if nursing home patient D ELIG ; Checks elegibility D:$G(DUZ("AG"))="V" COPAY G:PSOQFLG END ; Deals with copay D ADDRESS ; Display address information D:$G(^PS(55,PSODFN,1))]"" REMARKS ; Displays narrative about patient END D EOJ Q ;---------------------------------------------------------- GET ; K DIC,DR,DIQ S DIC=2,DA=PSODFN,DR=".1;.172;.351;.361;148",DIQ="PSOPTPST" D EN^DIQ1 K DIC,DA,DR,DIQ Q ; DEAD ; I $G(PSOPTPST(2,PSODFN,.351))]"" S PSOQFLG=1 W !,*7,?10,"PATIENT DIED "_PSOPTPST(2,PSODFN,.351),! Q ; INP ; I $G(PSOPTPST(2,PSODFN,.1))]"" S APSTAT=2 W !,*7,?10,"PATIENT IS AN INPATIENT ON WARD ",PSOPTPST(2,PSODFN,.1)," !!" D DIR ;IHS/DSD/ENM 01/26/98 ;IHS/DSD/ENM 02/12/99 NEXT LINE SETS STAT TO OUTPAT I $G(PSOPTPST(2,PSODFN,.1))="" S APSTAT=1 W !,*7,?10,"PATIENT IS AN OUTPATIENT",! Q ; CNH ; K PSORX("CNH") I $G(PSOPTPST(2,PSODFN,148))="YES" W !,*7,?10,"PATIENT IS IN A CONTRACT NURSING HOME !!" D DIR S:'PSOQFLG PSORX("CNH")=1 Q ; ELIG ; I $G(PSOPTPST(2,PSODFN,.361))]"",$G(PSOPTPST(2,PSODFN,.172))'="I" W !,"MAS ELIGIBILITY: ",PSOPTPST(2,PSODFN,.361) S DFN=PSODFN D RE^PSODEM Q ; COPAY ; K PSOBILL,PSOCPAY S DFN=PSODFN S (X,PSOPTIB)=$P($G(^PS(59,+PSOSITE,"IB")),"^")_"^"_PSODFN ;D XTYPE^IBARX ;IHS/DSD/ENM 05/28/96 IB CALL DISABLED, NOT USED BY IHS I '$D(^IBE(350.1,"ANEW",+PSOPTIB,1,1)) S PSOQFLG=1 D K PSOPTIB Q .W *7,!!,"There is a problem with the IB SERVICE/SECTION entry in your Pharmacy Site File." .W !,"You will not be able to enter any new prescriptions until this is corrected!",! S (ACTYP,BL)="",(PSOBILL,PSOCPAY)=0 I +Y=-1 W !,"ERROR IN COPAY ELIGIBILITY ENCOUNTERED." G COPAYX COPAY1 S ACTYP=$O(Y(ACTYP)) G:'ACTYP COPAYX F III=0:0 S BL=$O(Y(ACTYP,BL)) Q:BL="" I BL>0 S PSOBILL=BL,PSOCPAY=BL_"^"_Y(ACTYP,BL) G COPAY1 COPAYX K X,Y,ACTYP,BL,III Q ; ADDRESS ; N DFN S (DA,DFN)=PSODFN D ADD^VADPT L +^DPT(DA):0 I '$T W !,"File currently being updated, please try again later!",! Q I +VAPA(10)'
> TEMPORARY ADDRESS ",$P(VAPA(9),"^",2)," - ",$P(VAPA(10),"^",2)," <<" I VAPA(1)="" W !,*7,"NO ADDRESS INFORMATION ..",! S DIE=2,DR="[PSO OUTPTA]" D ^DIE:$P($G(PSOPAR),"^",22) G ADDRESSX F PSOI=1:1:4 W:VAPA(PSOI)]"" !,?5,VAPA(PSOI) ;IHS/DSD/ENM 10/07/95 $G added to next L var VAPA(11) W " ",$P(VAPA(5),"^",2)_" "_$S($G(VAPA(11))]"":$P($G(VAPA(11)),"^",2),1:$G(VAPA(6))) I $P($G(PSOPAR),"^",22) K DIE,DR S DIE=2,DR="[PSO OUTPTA]" D ^DIE L -^DPT(DA) ADDRESSX K DFN,PSOI,DA,DR Q ; REMARKS ; S PSOX=$G(^PS(55,PSODFN,1)) W !!,?5 F PSOI=1:1 Q:$P(PSOX," ",PSOI,900)="" W:$X>76 !,?5 W $P(PSOX," ",PSOI)," " K PSOX,PSOI Q ; DIR ; K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="DO YOU WISH TO CONTINUE" D ^DIR K DIR S:'Y PSOQFLG=1 K X,Y,DIRUT,DTOUT,DUOUT Q ; EOJ ; K:PSOQFLG PSORX("CNH") K PSOPTPST,PSOPTIB,VAPA Q PSOREF PSOREF ;IHS/DSD/JCM - REFILL DATA ENTRY [ 05/14/1998 4:04 PM ] ;;6.0;OUTPATIENT PHARMACY;**1**;09/03/97 START ; D INIT S PSONUM("A")="REFILL " D ^PSONUM I $G(PSOQFLG)=1 K PSOQFLG S PSORX("QFLG")=1 G END G:'$D(PSOLIST(1)) END IHSV ;---- ---- ---- ---- ---- ---- ---- ---- ;IHS/DSD/ENM 10/27/93 PCC LINKS ;HOOK TO STORE DATA FOR PATIENT IN PCC PARAM ARRAY FOR LATER USE I $P(%APSITE,U,15)="Y" D ^APSPCCV ;---- ---- ---- ---- ---- ---- ---- ---- D ^PSOREF1 G:PSOREF("DFLG") END IHSV1 ;---- ---- ---- ---- ---- ---- ---- ---- I $P(%APSITE,U,35)=1 D ^APSPCVRX ;---- ---- ---- ---- ---- ---- ---- ---- D PARSE END D EOJ Q ;------------------------------------------------------------------ INIT ; S PSOREF("QFLG")=0 S PSOOPT=4 Q ; PARSE ; ; F PSOREF("LIST")=1:1 Q:'$D(PSOLIST(PSOREF("LIST"))) F PSOREF("I")=1:1:$L(PSOLIST(PSOREF("LIST"))) S PSOREF("IRXN")=$P(PSOLIST(PSOREF("LIST")),",",PSOREF("I")) I +PSOREF("IRXN"),$G(^PSRX(PSOREF("IRXN"),0))]"" D ^PSOREF0 Q ; EOJ ; K PSOREF,PSORX("BAR CODE"),PSOLIST,LFD,MAX,MIN,NODE,PS,PSOERR,REF,RF,RXO,RXN,RXP,RXS,SD,VAERR,APSEFDT ;IHS/DSD/ENM 08/14/97 APSEFDT ADDED K APSPLTYP ;IHS/DSD/ENM 12/23/97 Q PSORENW0 PSORENW0 ;IHS/DSD/JCM - RENEW MAIN DRIVER CONTINUATION [ 05/14/1998 4:04 PM ] ;;6.0;OUTPATIENT PHARMACY;**1**;09/03/97 ;;6.0;OUTPATIENT PHARMACY;**22,83,93**;09/03/97 ; PROCESS ; D ^PSORENW1 I $D(PSORX("BAR CODE")),PSODFN'=PSORENW("PSODFN") D NEWPT S PSORENW("DFLG")=0,PSORENW("FILL DATE")=PSORNW("FILL DATE") W !!,"Now Renewing Rx # "_PSORENW("ORX #")_" Drug: "_$P($G(^PSDRUG(+$G(PSORENW("DRUG IEN")),0)),"^"),! D CHECK G:PSORENW("DFLG") PROCESSX D FILDATE D DRUG G:PSORENW("DFLG") PROCESSX D RXN G:PSORENW("DFLG") PROCESSX D DSPLY^PSORENW3 G:PSORENW("DFLG") PROCESSX D DTO^APSPMAN2 ;IHS/DSD/ENM 10/29/97 D EDIT I PSORENW("DFLG") G PROCESSX D EN^PSORN52(.PSORENW) ENM ;--- --- --- --- ;IHS/DSD/ENM 09/13/96 HOOK FOR PCC PARAM ARRAY I $P(%APSITE,U,15)="Y" D ^APSPCCV ;--- --- --- --- ;IHS/DSD/ENM 11/28/95 PCC LINK S APSPDOC1=$P($G(^VA(200,PSORENW("PROVIDER"),0)),U,16),APCDALVR("APCDTPRV")=$S($P($G(^AUTTSITE(1,0)),U,22):PSORENW("PROVIDER"),1:APSPDOC1) ;IHS/DSD/ENM 11/28/95 S APCDALVR("APCDPAT")=PSODFN,APCDALVR("APCDLOC")=DUZ(2) ;IHS/DSD/ENM 03/18/96 I $P(%APSITE,U,15)="Y" S APSRX=PSORENW("IRXN"),APCDALVR("APCDDATE")=APSEFDT D ^APSPCCN ;IHS/DSD/ENM 12/08/97 PSORENW("IRXN") ADDED ;I $P(%APSITE,U,15)="Y" S APSRX=PSORENW("OIRXN"),APCDALVR("APCDDATE")=PSORENW("FILL DATE") D ^APSPCCN ;--- --- --- --- D:$D(^PS(52.5,"B",PSORENW("OIRXN"))) DELETE D RNPSOSD^PSOUTIL D CAN PROCESSX W:PSORENW("DFLG") !,*7,"RENEWED RX DELETED",! D:$G(PSORENW("OLD FILL DATE"))]"" SUSDATEK^PSOUTIL(.PSORENW) K PSORENW,PSODRUG,PSORX("PROVIDER NAME"),PSORX("CLINIC") S:$G(PSORENW("FROM"))="" (PSORENW("DFLG"),PSORENW("QFLG"))=0 Q ; CHECK ; I '$D(PSORX("BAR CODE")),PSORENW("PSODFN")'=PSODFN W !!,?5,*7,"Can't renew Rx # ",$P(PSORENW("RX0"),"^"),", it is not for this patient." S PSORENW("DFLG")=1 G CHECKX ; S (PSOX,PSOY)="" I $D(PSOSD)>1 F S PSOX=$O(PSOSD(PSOX)) Q:PSOX']""!(PSORENW("DFLG")) I PSORENW("OIRXN")=+PSOSD(PSOX) S PSOY=PSOSD(PSOX) I $P(PSOY,"^",3)]"" D . S PSORENW("DFLG")=1 . W !,*7,"Cannot renew Rx # ",$P(PSORENW("RX0"),"^") . S PSOREA=$P(PSOY,"^",3),PSOSTAT=$P(PSORENW("RX0"),"^",15) . D STATUS^PSOUTIL(PSOREA,PSOSTAT) K PSOREA,PSOSTAT . Q I PSOY="" W !,*7,"Cannot renew Rx # ",$P(PSORENW("RX0"),"^")," later Rx exists." S PSORENW("DFLG")=1 K PSOX,PSOY G:PSORENW("DFLG") CHECKX ; D CHKDIV G:PSORENW("DFLG") CHECKX ; I $A($E(PSORENW("ORX #"),$L(PSORENW("ORX #"))))=90 D . W !,*7,"Cannot renew Rx # ",PSORENW("ORX #"),", Max number of renewals reached." . S PSORENW("DFLG")=1 . Q ; D CHKPRV^PSOUTIL CHECKX Q ; CHKDIV ; G:$P(PSORENW("RX2"),"^",9)=+PSOSITE CHKDIVX W !?5,*7,"RX # ",$P(PSORENW("RX0"),"^")," is for (",$P(^PS(59,$P(PSORENW("RX2"),"^",9),0),"^"),") division." I '$P($G(PSOSYS),"^",2) S PSORENW("DFLG")=1 G CHKDIVX D:$P($G(PSOSYS),"^",3) DIR CHKDIVX Q ; DRUG ; K PSOY S PSOY=PSORENW("DRUG IEN"),PSOY(0)=^PSDRUG(PSOY,0) D SET^PSODRG D POST^PSODRG S:PSORX("DFLG") PSORENW("DFLG")=1 S:$D(PSONEW("STATUS")) PSORENW("STATUS")=PSONEW("STATUS") K PSOY,PSORX("DFLG"),PSONEW("STATUS") Q ; RXN ; K PSOX S PSOX=$E(PSORENW("ORX #"),$L(PSORENW("ORX #"))) S PSORENW("NRX #")=$S(PSOX?1N:PSORENW("ORX #")_"A",1:$E(PSORENW("ORX #"),1,$L(PSORENW("ORX #")-1))_$C($A(PSOX)+1)) RXNX K PSOX Q ; FILDATE ; S PSORENW("IRXN")=PSORENW("OIRXN") ;D NEXT^PSOUTIL(.PSORENW) ;IHS/DSD/ENM 08/12/96 ;I PSORENW("FILL DATE")<$P(PSORENW("RX3"),"^",2) D SUSDATE^PSOUTIL(.PSORENW) ;IHS/DSD/ENM 08/12/96 D EM^PSOUTIL(.PSORENW) ;IHS/DSD/ENM 08/12/96 IHS RENEW FILL DT K PSORENW("IRXN") Q ; EDIT ; K DIR,X,Y S DIR(0)="Y",DIR("B")=$S($G(DUZ("AG"))'="I":"Y",1:"N") S DIR("A")="Edit renewed Rx " S DIR("?")="Answer YES to edit the renewed Rx, NO not to." D ^DIR K DIR S:$D(DIRUT) PSORENW("DFLG")=1 G:PSORENW("DFLG") EDITX I Y D EN^PSORENW2 EDITX K X,Y,DIRUT,DTOUT,DUOUT Q ; DELETE ; K DA,DIK S DA=$O(^PS(52.5,"B",PSORENW("OIRXN"),0)),DIK="^PS(52.5," D ^DIK K DIK,DIC Q ; CAN ; K REA,DA,MSG S REA="C",DA=PSORENW("OIRXN") S MSG="RENEWED" S PSCAN(PSORENW("ORX #"))=DA_"^C" D CAN^PSOCAN K REA,DA,MSG,PSCAN Q ; DIR ; S DIR(0)="Y",DIR("A")="CONTINUE ",DIR("B")="N" S DIR("?")="Answer YES to Continue, NO to bypass" D ^DIR K DIR S:$D(DIRUT)!('Y) PSORENW("DFLG")=1 DIRX K DIRUT,DTOUT,DUOUT,X,Y Q NEWPT ; S PSOQFLG=0 S PSODFN=PSORENW("PSODFN") D ^PSOPTPST I PSOQFLG S PSORENW("DFLG")=1,PSOQFLG=0 G NEWPTX D PROFILE^PSORX NEWPTX Q ; EN(PSORENW) ; Entry Point for Batch Barcode Option D PROCESS Q XIT K APSPDOC1 Q PSORENW2 PSORENW2 ;IHS/DSD/JCM - DISPLAYS RENEW RX INFORMATION FOR EDIT [ 05/14/1998 4:04 PM ] ;;6.0;OUTPATIENT PHARMACY;**1**;09/03/97 ;;6.0;OUTPATIENT PHARMACY;**57,69**;09/03/97 ; This routine displays the entered new rx information and ; asks if correct, if not allows editing of the data. ;------------------------------------------------------------ START ; S (PSORENW("DFLG"),PSORENW2("QFLG"))=0 D DISPLAY ; Displays information D ASK G:PSORENW2("QFLG")!PSORENW("DFLG") END EN D EDIT G START END D EOJ Q ;------------------------------------------------------------ DISPLAY ; W !!,"Rx # ",PSORENW("NRX #") W ?23,$E(PSORENW("FILL DATE"),4,5),"/",$E(PSORENW("FILL DATE"),6,7),"/",$E(PSORENW("FILL DATE"),2,3) W !,$G(PSORX("NAME")),?30,"#",PSORENW("QTY"),?35,"DAYS SUPPLY ",PSORENW("DAYS SUPPLY") ;IHS/DSD/ENM/POC 1/21/98 S X=PSORENW("SIG") D SIGONE^PSOHELP W !,$G(SIG),!!,$S($G(PSODRUG("TRADE NAME"))]"":PSODRUG("TRADE NAME"),1:PSODRUG("NAME")) W !,PSORENW("PROVIDER NAME"),?25,PSORX("CLERK CODE") W !,"# of Refills: ",PSORENW("# OF REFILLS"),! Q ; ASK ; K DIR,X,Y S DIR("A")="Is this correct" S DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR I $D(DIRUT) S PSORENW("DFLG")=1 G ASKX I Y S PSORENW2("QFLG")=1 ASKX K X,Y,DIRUT,DTOUT,DUOUT,SIG Q ; EDIT ; S PSORX("EDIT")=1 D ^PSORENW3 S PSORENW("DFLG")=0 Q ; EOJ ; K PSORENW2,PSORX("EDIT"),PSORENW("EDIT") Q PSORENW3 PSORENW3 ;IHS/DSD/JCM - EDIT TEMPLATE FOR RENEW RX ORDER ENTRY [ 05/14/1998 4:04 PM ] ;;6.0;OUTPATIENT PHARMACY;**1**;09/03/97 ;;6.0;OUTPATIENT PHARMACY;**48**;09/03/97 ; START ; D INIT ; 1 S PSORENW("FLD")=1 D ISSDT^PSODIR2(.PSORENW) ; Get Issue Date G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD") ; ;IHS/DSD/ENM 08/14/97 APSRNEW ADDED TO NEXT LINE 2 S PSORENW("FLD")=2,APSRNEW=1 D FILLDT^PSODIR2(.PSORENW) ; Get Fill date G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD") ; 3 S PSORENW("FLD")=3 D PROV^PSODIR(.PSORENW) ; Get Provider G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD") ; 10 S PSORENW("FLD")=10 D QTY^PSODIR1(.PSORENW) ;IHS/DSD/ENM 08/05/96 GET QTY G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD") ;IHS/DSD/ENM 08/05/96 ; 4 ;S PSORENW("FLD")=4,PSORENW("DAYS SUPPLY")=$P(PSORENW("RX0"),"^",8) S PSORENW("FLD")=4 D DAYS^PSODIR1(.PSORENW) ;IHS/DSD/ENM/POC 01/21/98 GET DAYS SUPPLY G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD") ;IHS/DSD/ENM 11/21/97 ; 11 S PSORENW("FLD")=11 ;IHS/DSD/ENM 11/21/97 NO DEFAULT NBR REFILLS D REFILL^PSODIR1(.PSORENW) ; Get # of refills G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD") ; 5 S PSORENW("FLD")=5 D RMK^PSODIR2(.PSORENW) ; Get Remarks G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD") ; 6 S PSORENW("FLD")=6 D MW^PSODIR2(.PSORENW) ; Get Mail/Window Info G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD") ; ; 7 I $G(DUZ("AG"))="I" S PSORENW("FLD")=7 D EXP^PSODIR2(.PSORENW) ; Get Expiration Date - Indian Health Service ONLY G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD") ; 8 I $G(DUZ("AG"))="I" S PSORENW("FLD")=8 D CLERK^PSODIR2(.PSORENW) ; Get Clerk Code G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD") ; 9 S PSORENW("FLD")=9 D CLINIC^PSODIR2(.PSORENW) G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD") ;IHS/DSD/ENM 10/06/95 NEXT LINE CALLS MFG RTN D:APSPMAN=1 ^APSPMAN2 D:APSPMAN'=1 DTO^APSPMAN2 ;IHS/DSD/ENM 10/29/97 S APFLAG="RE" D ^APSPQ ;IHS/DSD/ENM 10/06/95 CHECK IF DRUG IS A DUE ; END ; K PSORENW3 S PSORENW("EDIT")=1 Q ; INIT ; S PSORENW("DAYS SUPPLY")=$P(PSORENW("RX0"),"^",8) ;IHS/DSD/ENM/POC 01/21/98 S PSORENW("QTY")=$P(PSORENW("RX0"),"^",7) S PSORENW("SIG")=$P(PSORENW("RX0"),"^",10) S (PSORENW("DFLG"),PSORENW("FIELD"),PSORENW3)=0 G:$G(PSORENW("EDIT")) INITX S PSORENW("ISSUE DATE")=DT S PSORENW("CLINIC")=$P(PSORENW("RX0"),"^",5) S:PSORENW("CLINIC") PSORX("CLINIC")=$P(^SC(PSORENW("CLINIC"),0),"^") S Y=PSORENW("FILL DATE") X ^DD("DD") S PSORX("FILL DATE")=Y K Y S PSORENW("PROVIDER")=$P(PSORENW("RX0"),"^",4) S PSORENW("PROVIDER NAME")=$P($G(^VA(200,PSORENW("PROVIDER"),0)),"^") S PSORENW("PTST NODE")=^PS(53,$P(PSORENW("RX0"),"^",3),0) S PSORENW("# OF REFILLS")=$P(PSORENW("RX0"),"^",9) S PSORENW("REMARKS")="RENEWED FROM RX # "_$P(PSORENW("RX0"),"^") S PSORX("MAIL/WINDOW")=$S($P(PSORENW("RX0"),"^",11)="W":"WINDOW",1:"MAIL") S:$G(PSORX("CLERK CODE"))']"" PSORX("CLERK CODE")=$P($G(^VA(200,DUZ,0)),"^") INITX Q JUMP ; ;S PSORENW("FIELD")=$S(+Y=1:1,+Y=22:2,+Y=4:3,+Y=5:9,+Y=9:4,+Y=12:5,+Y=11:6,+Y=29:7,+Y=16:8,+Y=7:10,1:PSORENW("FLD")) ;IHS/DSD/ENM 08/05/96 Y=7:10 ADDED S PSORENW("FIELD")=$S(+Y=1:1,+Y=22:2,+Y=4:3,+Y=5:9,+Y=9:11,+Y=12:5,+Y=11:6,+Y=29:7,+Y=16:8,+Y=7:10,+Y=8:4,1:PSORENW("FLD")) ;IHS/DSD/ENM 11/21/97 Q DSPLY ;called from PSORENW0 W !!,PSORENW("NRX #"),?12," ",$P(^PSDRUG(PSORENW("DRUG IEN"),0),"^"),?46," QTY: ",$P(PSORENW("RX0"),"^",7),?56," DAYS SUPPLY: ",$P(PSORENW("RX0"),"^",8) ;IHS/DSD/ENM/POC 01/21/98 W !,"PHYS: ",PSORX("PROVIDER NAME") ;IHS/DSD/ENM 01/21/98 W !,"# OF REFILLS: ",$P(PSORENW("RX0"),"^",9)," ISSUED: ",$E(DT,4,5),"-",$E(DT,6,7),"-",$E(DT,2,3)," SIG: ",PSORENW("SIG")," FILLED: ",$E(PSORENW("FILL DATE"),4,5),"-",$E(PSORENW("FILL DATE"),6,7),"-",$E(PSORENW("FILL DATE"),2,3) DSPLYX Q PSORN52 PSORN52 ;IHS/DSD/JCM - FILES RENEWAL ENTRIES IN PRESCRIPTION FILE [ 05/14/1998 4:04 PM ] ;;6.0;OUTPATIENT PHARMACY;**1**;09/03/97 ;;6.0;OUTPATIENT PHARMACY;**22,34**;09/03/97 ;IHS/DSD/ENM 10/29/97 XXXX("STOP DATE") IS CALCULATED IN PSON52 EN(PSOX) ;Entry Point START ; D:$D(XRTL) T0^%ZOSV ; Start RT Monitor D INIT G:PSORN52("QFLG") END D DATA,FILE,PS55,DIK S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV ; Stop RT Monitor D FINISH I '$P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7),$G(DUZ("AG"))="V" S PSOFLAG=0 D COPAY^PSOCPB ;D ACP^PSOUTIL ;IHS/DSD/ENM 12/07/93 ;The above line was disabled because line tag doesn't ;exist in PSOUTIL. Line below was added to replace the above. D RNPSOSD^PSOUTIL END D EOJ Q ; INIT ; S PSORN52("QFLG")=0 S:'$D(PSOX("DAYS SUPPLY")) PSOX("DAYS SUPPLY")=$P(PSOX("RX0"),"^",8) S:'$D(PSOX("# OF REFILLS")) PSOX("# OF REFILLS")=$P(PSOX("RX0"),"^",9) S:'$D(PSOX("ISSUE DATE")) PSOX("ISSUE DATE")=DT D INIT^PSON52 K PSON52 Q ; DATA ; S PSOX("NRX0")=PSORENW("RX0"),PSOX("NRX2")=PSORENW("RX2"),PSOX("NRX3")=PSORENW("RX3") S $P(PSOX("NRX0"),"^")=PSOX("NRX #") S:$G(PSOX("PROVIDER"))]"" $P(PSOX("NRX0"),"^",4)=PSOX("PROVIDER") S $P(PSOX("NRX0"),"^",7)=PSOX("QTY") ;IHS/DSD/ENM 08/05/96 S:$G(PSOX("DAYS SUPPLY"))]"" $P(PSOX("NRX0"),"^",8)=PSOX("DAYS SUPPLY") ;IHS/DSD/ENM/POC 11/21/97 S $P(PSOX("NRX0"),"^",5)=PSOX("CLINIC"),$P(PSOX("NRX0"),"^",9)=PSOX("# OF REFILLS") S $P(PSOX("NRX0"),"^",11)=$S(PSOX("FILL DATE")>DT:"M",$D(PSOX("MAIL/WINDOW")):PSOX("MAIL/WINDOW"),1:$P(PSOX("NRX0"),"^",11)) S $P(PSOX("NRX0"),"^",13)=PSOX("ISSUE DATE"),$P(PSOX("NRX0"),"^",15)=PSOX("STATUS"),$P(PSOX("NRX0"),"^",16)=$S($G(PSOX("CLERK CODE"))]"":PSOX("CLERK CODE"),1:DUZ) S $P(PSOX("NRX0"),"^",17)=$G(PSODRUG("COST")) ; S $P(PSOX("NRX2"),"^")=PSOX("LOGIN DATE"),$P(PSOX("NRX2"),"^",2)=PSOX("FILL DATE"),$P(PSOX("NRX2"),"^",3)="",$P(PSOX("NRX2"),"^",5)=PSOX("DISPENSED DATE") S $P(PSOX("NRX2"),"^",6)=PSOX("STOP DATE"),$P(PSOX("NRX2"),"^",7)=$S($G(PSOX("NDC"))]"":PSOX("NDC"),1:$G(PSODRUG("NDC"))) S $P(PSOX("NRX2"),"^",8)=$S($G(PSOX("MANUFACTURER"))]"":PSOX("MANUFACTURER"),1:$G(PSODRUG("MANUFACTURER"))) ;IHS/DSD/ENM 10/06/95 LOT # ADD, NEXT LINE S $P(PSOX("NRX2"),"^",4)=$S($G(PSOX("LOT #"))]"":PSOX("LOT #"),1:"") S $P(PSOX("NRX2"),"^",9)=+PSOSITE,$P(PSOX("NRX2"),"^",10)="" S $P(PSOX("NRX2"),"^",11)=$S($G(PSOX("EXPIRATION DATE"))]"":PSOX("EXPIRATION DATE"),1:$G(PSODRUG("EXPIRATION DATE"))) S:$G(PSOX("GENERIC PROVIDER"))]"" $P(PSOX("NRX2"),"^",12)=PSOX("GENERIC PROVIDER") S $P(PSOX("NRX2"),"^",13)="",$P(PSOX("NRX2"),"^",15)="" ; S PSOX("LAST DISPENSED DATE")=PSOX("DISPENSED DATE"),$P(PSOX("NRX3"),"^",4)=$P(PSOX("NRX3"),"^") S $P(PSOX("NRX3"),"^")=PSOX("LAST DISPENSED DATE") S:$G(PSOX("NEXT POSSIBLE REFILL"))]"" $P(PSOX("NRX3"),"^",2)=PSOX("NEXT POSSIBLE REFILL") S:$G(PSOX("COSIGNING PROVIDER"))]"" $P(PSOX("NRX3"),"^",3)=PSOX("COSIGNING PROVIDER") S:$G(PSOX("REMARKS"))']"" PSOX("REMARKS")="RENEWED FROM RX # "_$P(PSOX("RX0"),"^") S $P(PSOX("NRX3"),"^",7)=PSOX("REMARKS") Q ; FILE ; S DIC="^PSRX(",DLAYGO=52,DIC(0)="L",X=PSOX("NRX #") K DD,DO D FILE^DICN S PSOX("IRXN")=+Y K DLAYGO,X,Y,DIC D:+$G(DGI) TECH^PSODGDGI L +^PSRX(PSOX("IRXN")) S PSORN52(PSOX("IRXN"),0)=PSOX("NRX0") S PSORN52(PSOX("IRXN"),2)=PSOX("NRX2") S PSORN52(PSOX("IRXN"),3)=PSOX("NRX3") S:$G(PSOX("TN"))]"" PSORN52(PSOX("IRXN"),"TN")=PSOX("TN") I $G(PSOX("METHOD OF PICK-UP"))]"",PSOX("FILL DATE")'>DT S PSORN52(PSOX("IRXN"),"MP")=PSOX("METHOD OF PICK-UP") S PSORN52(PSOX("IRXN"),"TYPE")=0 S PSOX1="" F S PSOX1=$O(PSORN52(PSOX("IRXN"),PSOX1)) Q:PSOX1="" S ^PSRX(PSOX("IRXN"),PSOX1)=$G(PSORN52(PSOX("IRXN"),PSOX1)) ;CK/SET CHRONIC MED DATA ;IHS/DSD/ENM 09/19/96 I $G(PSOX("ZCM"))="Y" S DIE=52,DA=PSOX("IRXN"),DR="9999999.02///Y" D ^DIE ;IHS/DSD/ENM 09/19/96 K ^PS(55,PSODFN,"P","CP",PSOX("OIRXN")) ;IHS/DSD/ENM 09/19/96 K PSOX1 Q ; PS55 ; L +^PS(55,PSODFN,"P") S:'$D(^PS(55,PSODFN,"P",0)) ^(0)="^55.03PA^^" F PSOX1=$P(^PS(55,PSODFN,"P",0),"^",3):1 Q:'$D(^PS(55,PSODFN,"P",PSOX1)) S PSOX("55 IEN")=PSOX1 S ^PS(55,PSODFN,"P",PSOX1,0)=PSOX("IRXN"),$P(^PS(55,PSODFN,"P",0),"^",3,4)=PSOX1_"^"_($P(^PS(55,PSODFN,"P",0),"^",4)+1) S ^PS(55,PSODFN,"P","A",PSOX("STOP DATE"),PSOX("IRXN"))="" PS55X L -^PS(55,PSODFN,"P") K PSOX1 Q ; DIK ; K DIK,DA S DIK="^PSRX(",DA=PSOX("IRXN") D IX1^DIK K DIK,DA Q ; FINISH ; G:PSOX("STATUS")=4 FINISHP I $D(PSORX("VERIFY")) D G FINISHX . K DIC,DLAYGO,DINUM,DIADD,X,DD,DO . S DIC="^PS(52.4,",DLAYGO=52.4,DINUM=PSOX("IRXN"),DIC(0)="ML" . S X=PSOX("IRXN") . D FILE^DICN K DIC,DLAYGO,DINUM,X . S ^PS(52.4,PSOX("IRXN"),0)=PSOX("IRXN")_"^"_$P(PSOX("NRX0"),"^",2)_"^"_DUZ_"^"_$G(PSOX("OIRXN"))_"^"_$E(PSOX("LOGIN DATE"),1,7)_"^"_PSOX("IRXN")_"^"_PSOX("STOP DATE") . K DIK,DA . S DIK="^PS(52.4,",DA=PSOX("IRXN") . D IX^DIK K DIK,DA . Q ; I $G(PSOX("QS"))="S" D G FINISHX . S DA=PSOX("IRXN") . D SUS^PSORXL K DA . Q ; I PSOX("FILL DATE")>DT,$P(PSOPAR,"^",6) D G FINISHX . S DA=PSOX("IRXN") . D SUS^PSORXL K DA . Q ; I $G(PSOX("QS"))="Q" D G FINISHX . N PSOFROM S PSOFROM="BATCH" . I $G(PPL),$L(PPL_PSOX("IRXN")_",")>240 D Q^PSORXL K PPL . I $G(PPL) S PPL=PPL_PSOX("IRXN")_"," . E S PPL=PSOX("IRXN")_"," . Q ; FINISHP I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=PSOX("IRXN")_",",APSPZRP=PSORX("PSOL",1) G FINISHX ;IHS/DSD/ENM 12/22/95 APSPZRP ADDED FOR RELEASE RTN F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1 I $L(PSORX("PSOL",PSOX2))+$L(PSOX("IRXN"))<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSOX("IRXN")_"," E S PSORX("PSOL",PSOX2+1)=PSOX("IRXN")_"," S APSPZRP=PSORX("PSOL",1) ;IHS/DSD/ENM 12/22/95 VAR ADDED FOR RELEASE FINISHX ; K PSOX1,PSOX2 Q EOJ ; L -^PSRX(PSOX("IRXN")) K PSORN52 Q PSORX PSORX ;IHS/DSD/JCM - MAIN RX DATA ENTRY DRIVER [ 09/07/1999 8:44 AM ] ;;6.0;OUTPATIENT PHARMACY;**1,2**;09/03/97 ;;6.0;OUTPATIENT PHARMACY;**73,120,133**;09/03/97 ; Input variables: PSOFROM ; Values of PSOFROM: NEW for NEW Rxs ; REFILL for Refill Rxs ; EDIT for Editing Rxs ; DELETE for deleting Rxs ; CANCEL for cancelling Rxs ; RETURN for returning Rxs to Stock ; PARTIAL for doing partial prescriptions ; BATCH for batch Rx processing ; ; PSOFROM("PTLKUP")=1 If you want patient asked first and profile built ; ; ;--------------------------------------------------------- START ; D INIT G:PSORX("QFLG") END D:$G(PSOFROM("PTLKUP"))]"" PT G:PSORX("QFLG") END D:$G(PSOFROM("PTLKUP"))]"" PROFILE EN D @PSOFROM ;D:$G(PSORX("PSOL",1))]"" ^PSORXL K PSORX("PSOL") D:$G(PSORX("PSOL",1))]"" ^APSPNE4 K PSORX("PSOL") ;IHS/DSD/ENM 9/14/94 ;--- --- --- --- --- ;IHS/DSD/ENM 12/01/95 RX RELEASE FEATURE I PSOFROM="NEW"!(PSOFROM="REFILL")!(PSOFROM="PARTIAL")&($D(^XUSEC("PSORPH",DUZ))) D ;IHS/DSD/ENM 11/30/95 RELEASE DT SET .Q:$G(APSPZRP)']"" .F APSP1=1:1 Q:$P(APSPZRP,",",APSP1)="" S RXP=$P(APSPZRP,",",APSP1) D ;GET RELEASE INFO ..;S RXP=APSPZRP,PSRH=DUZ,PSIN=$P($G(^PS(59.7,1,49.99)),"^",2) ..S PSRH=DUZ,PSIN=$P($G(^PS(59.7,1,49.99)),"^",2) ..D ^APSPDISP ;--- --- --- --- --- I $G(PSOFROM("PTLKUP"))]"" D EOJ G START END D EOJ K APSPX1("PROV"),APSEFDT ;IHS/DSD/ENM 08/14/97 Q ;--------------------------------------------------------- INIT ; S PSORX("QFLG")=0 I $G(PSOFROM)']"" W !,"No option defined",! S PSORX("QFLG")=1 G INITX D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) S PSORX("QFLG")=1 I $P($G(PSOPAR),"^",2),'$D(^XUSEC("PSORPH",DUZ)) S PSORX("VERIFY")=1 INITX Q ; PT ; K DIC S PSORX("QFLG")=0 S DIC=2,DIC(0)="QEAM" D ^DIC K DIC,DA I +Y'>0 S PSORX("QFLG")=1 G PTX S PSODFN=+Y,PSORX("NAME")=$P(Y,"^",2) S PSOQFLG=0 D ^PSOPTPST G:PSOQFLG PT ; Post patient slection routine S DIC="^PS(55,",DLAYGO=55 I '$D(^PS(55,PSODFN,0)) K DD,DO S DIC(0)="L",(DINUM,X)=PSODFN D FILE^DICN K DIC,DA,DR I $G(PSODFN),$P($G(^PS(55,PSODFN,0)),"^")="" S $P(^PS(55,PSODFN,0),"^")=PSODFN K DIK S DA=PSODFN,DIK="^PS(55,",DIK(1)=".01^B" D EN^DIK K DIK,DA ;P133 I $G(^PS(55,PSODFN,"PS"))']"" D .L +^PS(55,PSODFN):0 I '$T W *7,!!,"Patient Data is Being Edited by Another User!",! Q .S DIE=55,DR=".02;1;3//OUTPATIENT;50",DA=PSODFN W !!,?5,">>PHARMACY PATIENT DATA<<",! D ^DIE L -^PS(55,PSODFN) ;IHS/DSD/ENM 01/08/96 ;S DIE=55,DR=".02:3;50",DA=PSODFN W !!,?5,">>PHARMACY PATIENT DATA<<",! D ^DIE L -^PS(55,PSODFN) ;IHS/DSD/ENM 01/26/98 CHECK FOR CORRECT PT STATUS - APSTAT SET IN ;PSOPTPST IF PT IS INPATIENT S PSOX=$S($G(APSTAT)]"":APSTAT,1:1) I PSOX]"" S PSORX("PATIENT STATUS")=$P($G(^PS(53,PSOX,0)),"^"),APST=PSOX ;IHS/DSD/ENM 07/20/98 ;S PSOX=$S($G(APSTAT)]"":APSTAT,$G(^PS(55,PSODFN,"PS"))]"":^PS(55,PSODFN,"PS"),1:1) I PSOX]"" S PSORX("PATIENT STATUS")=$P($G(^PS(53,PSOX,0)),"^"),APST=PSOX ;S PSOX=$G(^PS(55,PSODFN,"PS")) I PSOX]"" S PSORX("PATIENT STATUS")=$P($G(^PS(53,PSOX,0)),"^") K DIE,DIC,DLAYGO,DR,DA,PSOX,APSTAT ;IHS/DSD/ENM 01/26/98 PTX ; K X,Y Q ; PROFILE ; S (PSORX("REFILL"),PSORX("RENEW"))=0,PSOX="" D ^PSOBUILD ;I $D(PSOSD)'>1 W !,"This patient has no prescriptions" S:'$D(DFN) DFN=PSODFN D GMRA^PSODEM G PROFILEX I $D(PSOSD)'>1 W !,"This patient has no INHOUSE prescriptions.." S X="APSQSHOW" X ^%ZOSF("TEST") S:$T EN="SHOW" D:$T ^APSQSHOW S:'$D(DFN) DFN=PSODFN D GMRA^PSODEM G PROFILEX ;IHS/DSD/ENM/POC 05/11/97 OUTSIDE RX CK S PSOX="" F S PSOX=$O(PSOSD(PSOX)) Q:PSOX="" S:$P(PSOSD(PSOX),"^",3)="" PSORX("RENEW")=1 S:$P(PSOSD(PSOX),"^",4)="" PSORX("REFILL")=1 K PSOX PROFILEX Q ; NEW ; N PSOOPT S PSOOPT=3 I $D(PSOSD)>1,$P($G(PSOPAR),"^",4) D ^PSORENW G:PSORX("QFLG") NEWX D ^PSONEW G:PSORX("QFLG") NEWX I $G(PSORX("DO REFILL")),'PSORX("REFILL") W !,*7,"No prescriptions with refills allowed ",! G NEWX ;IHS/DSD/ENM 02/14/97 ;IHS/DSD/ENM 10/13/94 Next line chng to return to new rx module ;I $G(PSORX("DO REFILL")),$D(PSOSD)>1,PSORX("REFILL") W !,"Now entering Refill Option",! S PSOOPT=4 D ^PSOREF I $G(PSORX("DO REFILL")),$D(PSOSD)>1,PSORX("REFILL") W !,"Now entering Refill Option",! S PSOOPT=4 D ^PSOREF G APSX K APSPFLG ;IHS/DSD/ENM 01/29/97 NEWX Q APSX ;IHS/DSD/ENM 10/13/94 Return to new Rx Module from Refill K PSORX("DO REFILL") S PSONEW("QFLG")=0,PSOOPT=3 W !,*7,"<-<- Returning to ""New Rx"" Option <-<-",! G NEW Q ; REFILL ; I 'PSORX("REFILL") D G REFILLX . W !,*7,"No prescriptions with refills allowed ",! . N PSOOPT S PSOOPT=4 . D ^PSODSPL . K PSOQFLG Q ; N PSOOPT S PSOOPT=4 I $D(PSOSD)>1 D ^PSOREF REFILLX Q ; BATCH ; D ^PSOBBC Q EDIT ; G:$G(PSOSD)']"" EOJ ;IHS/DSD/ENM 08/08/96 D ^PSORXED Q DELETE ; D ^PSORXDL Q RETURN ; ;D ^PSORESK ;IHS/DSD/ENM 6/16/95 D ^APSPRESK K PSIN ;IHS/DSD/LWJ 9/3/99 Q PARTIAL ; D ^PSORXPAR Q CANCEL ; D ^PSOCAN Q EOJ ; K PSORX,PSOQFLG,PSOSD,PSODRUG,PSODFN,PSOOPT,PSOBILL,PSOCPAY,APSPZRP,RXP,APSPZDT ;IHS/DSD/ENM 08/08/96 RXP + APSP ADDED Q PSORXDL PSORXDL ;BHAM/ISC/SAB - DELETES ONE PRESCRIPTION [ 05/28/1998 9:34 AM ] ;;6.0;OUTPATIENT PHARMACY;**1**;09/03/97 ;;6.0;OUTPATIENT PHARMACY;**22,56,71,92**;09/03/97 I '$D(^XUSEC("PSORPH",DUZ)) W !,*7,"Requires Pharmacy Key (PSORPH) !" Q S PSDEL=1,PS="DELETE",DIC("S")="I $P(^PSRX(+Y,0),""^"",15)'=13,$G(^(2))" D A1^PSORXVW K DIC("S") G KILL:"^"[X S APSDRTDA=DA ;IHS/DSD/ENM/POC 5/21/98 SAVE FOR LATER I $O(^PSRX(DA,1,0)) W !,"WAIT A MINUTE! CAN ONLY DELETE THE REFILLS" D ^PSORXDLR S X="^" ;IHS/DSD/ENM/POC 5/21/98 TO REFILL DELETE G KILL:"^"[X ;--- --- --- --- ;IHS/DSD/ENM 11/29/95 PCC VAR SETUP I $P(%APSITE,U,15)="Y" S APSRX=DA,APSRM=0 I $D(^PSRX(DA,999999911)) S APSRM=+^(999999911) ;IHS/DSD/ENM 11/29/95 I $P(%APSITE,U,15)="Y" S DR="9999999.11///@",DIE="^PSRX(",DA=APSRX D ^DIE K DIE ;IHS/DSD/ENM/POC 05/07/98 TO GET RID OF PCC LINK WHEN MARK DELETE ;I $P($G(^PSRX(DA,2)),"^",13) W *7,!,"RX has been Released to patient or mailed." D KILL G PSORXDL ;IHS/DSD/ENM 02/13/96 ENQ ;S PSOIB=$S($D(^PSRX(DA,"IB")):^PSRX(DA,"IB"),1:0) ;Check if copay ;IHS/DSD/ENM 02/13/96 NOT USED IN IHS S RX=^PSRX(DA,0),RXN=DA,DIE=52,DR="100///^S X=13;108" L +^PSRX(DA) D ^DIE L -^PSRX(DA) K ^PSRX("ACP",$P(^PSRX(DA,0),"^",2),+$P(^(2),"^",2),0,DA) D ACT I $G(^PSRX(DA,"H"))]"" K ^PSRX("AH",+$P(^PSRX(DA,"H"),"^"),DA) S ^PSRX(DA,"H")="" S DA=$O(^PS(52.5,"B",RXN,0)) I DA S DIK="^PS(52.5," D ^DIK I $D(^PS(52.4,RXN)) S DA=RXN,DIK="^PS(52.4," D ^DIK ;I +PSOIB>0,+$P(PSOIB,"^",2)>0 D RXDEL^PSOCPA ;If charged, delete copay ;IHS/DSD/ENM 02/13/96 NOT USED IN IHS ;Q:+$G(PSORX("INTERVENE")) G PSORXDL:$D(DA)&('$G(PSOZVER)) Q:+$G(PSORX("INTERVENE")) G PSORXDL:$G(DA)&('$G(PSOZVER)) ;IHS/DSD/ENM 02/13/96 ;IHS/DSD/ENM/POC 5/21/98 CHECK FOR RTN TO STOCK IF RTS DONT SUBTRACT AS ALREADY SUBTRACTED (NEXT 3 LINES) S APSDRTN=$P(^PSRX(APSDRTDA,2),U,15)]"" ;IS ORIGINAL RX RTN TO STOCK W:APSDRTN !,"THIS RX WAS RETURNED TO STOCK-THEREFORE INVENTORY WILL NOT BE UPDATED AS IT WAS UPDATED WHEN RETURNED TO STOCK",!,"AND THE #OF REFILLS WILL BE DECREASED BY ONE SINCE RETURNED TO STOCK MEDS ADD ONE TO THE REFILLS" I APSDRTN S $P(^PSRX(APSDRTDA,0),"^",9)=$P(^PSRX(APSDRTDA,0),"^",9)-1 ;DEC #OF REF I 'APSDRTN S ^PSDRUG(+$P(RX,"^",6),660.1)=$S($D(^PSDRUG(+$P(RX,"^",6),660.1)):^(660.1),1:0)+$P(RX,"^",7) S DFN=+$P(RX,"^",2) F I=0:0 S I=$O(^PS(55,DFN,"P",I)) Q:'I I +^(I,0)=RXN K ^(0) S ^(0)=$P(^PS(55,DFN,"P",0),"^",1,3)_"^"_($P(^(0),"^",4)-1) ;--- --- --- --- ;IHS/DSD/ENM 11/29/95 I $P(%APSITE,U,15)="Y" S APSPPDFN=DFN D ^APSPCCD K APSPPDFN ;IHS/DSD/ENM 11/29/95 F I=0:0 S I=$O(^PS(55,DFN,"P","A",I)) Q:'I I $D(^(I,RXN)) K ^(RXN) K RX,RXN Q:+$G(PSORX("INTERVENE")) G:$G(PSDEL) PSORXDL ; KILL K PSDEL,I,II,J,N,PHYS,PS,RFDATE,RFL,RFL1,ST,ST0,%,%Y,D0,DA,DI,DIC,DIE,DIH,DIU,DIV,DR,Z,DIG,X,Y,PSOIB,RX,RXN Q ACT ;adds activity info for deleted rx S RXF=0 F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I S RXF=I K ^PSRX("ACP",$P(^PSRX(RXN,0),"^",2),$P(^PSRX(RXN,1,I,0),"^"),I,RXN) S DA=0 F FDA=0:0 S FDA=$O(^PSRX(RXN,"A",FDA)) Q:'FDA S DA=FDA D NOW^%DTC S DA=DA+1,^PSRX(RXN,"A",0)="^52.3DA^"_DA_"^"_DA,^PSRX(RXN,"A",DA,0)=%_"^"_"D"_"^"_DUZ_"^"_RXF_"^"_"RX DELETED on "_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3) EX W !,"...PRESCRIPTION #"_$P(RX,"^")_" MARKED DELETED!!" K RXF,I,FDA,DIC,DIE,%,%I,%H S DA=RXN Q PSORXDLR PSORXDLR ;IHS/DSD/ENM/POC - DELETE LAST REFILL [ 05/26/1998 4:20 PM ] ;;6.0;OUTPATIENT PHARMACY;**1**;09/03/97 ;CALLED BY PSORXDL CREATED 01/28/98 S APSDDISP=0 F S APSDDISP=$O(^PSRX(DA,1,APSDDISP)) Q:APSDDISP'=+APSDDISP S APSDDTE=$$FMTE^XLFDT(+^PSRX(DA,1,APSDDISP,0)) W !,APSDDTE S APSDLAST=APSDDTE ;LATEST DATE ASK W !,"DO YOU WANT TO DELETE A REFILL" S %=2 D YN^DICN Q:%'=1 ;DID NOT ANSWER YES S APSDDIEN=DA,APSDDRUG=$P(^PSRX(APSDDIEN,0),"^",6) N DA ;SO IT WILL BE AS IT WAS BEFORE CALL ;APSDDIEN IS IEN OF RX ;SET RX STRINGS F I=0,2,3 S @("RX"_I)=@("^PSRX("_APSDDIEN_","_I_")") ; DIC S DA(1)=APSDDIEN,DIC="^PSRX("_DA(1)_",1,",DIC(0)="AEQ" S DIC("B")=APSDLAST D ^DIC K DIC I Y=-1 G ASK Q:$D(DTOUT)!$D(DUOUT) S APSDDIE=+Y,APSDDATE=$P(Y,"^",2) ASKA ;ASK IF FOR SURE ;NEXT TWO LINES WARNING ABOUT RETURN TO STOCK IHS/DSD/POC/ENM 5/21/98 S APSDTURN=$P(^PSRX(APSDDIEN,1,APSDDIE,0),U,16)]"" I APSDTURN W !,"WARNING-WARNING !",!,"THIS REFILL HAS BEEN RETURNED TO STOCK. IF DELETED INVENTORY WILL NOT BE UPDATED AS INVENTORY WAS UPDATED WHEN REFILL WAS RETURNED TO STOCK!" W !,"THE NUMBER OF REFILLS WILL BE DECREASED BY ONE AS THE RETURN TO STOCK OPTION ADDED ONE REFILL" W !,"ARE YOU SURE YOU WANT TO DELETE THE REFILL "_$$FMTE^XLFDT(APSDDATE) S %=2 D YN^DICN Q:%'=1 Q:$D(DTOUT)!$D(DUOUT) ;LOCK THE ENTRY L +^PSRX(APSDDIEN):0 I '$T W *7,!!,"RX BEING ACCESSED BY OTHER USER" H 5 Q ;SAVE SOME VARIABLES S APSDSIEN=^PSRX(APSDDIEN,1,APSDDIE,0) ;KEEP REFILL INFO ;S:$P(%APSITE,"^",15)="Y" APSRM=$G(^PSRX(APSDDIEN,1,APSDDIE,999999911)) S:$P(%APSITE,"^",15)="Y" PS="EDIT" ;IHS/DSD/ENM/POC FOR X REF ON REFILL PCC LINK S APSDQTY=$P(APSDSIEN,"^",4) ;SAVE QTY S APSDRFDT=+APSDSIEN ;FIRST PIECE OF SUBNODE S APSDRFN=APSDDIE ;THE 1ST, 2ND, 3RD REFILL ETC ;S:APSDRFN>5 APSDRFN=APSDRFN+1 ; BECAUSE DD HAS 6 AS PARTIAL ;CHECK THIS OUT ***** ABOVE ;NEED TO MODIFY DD FOR ACTIVITY LOG OF 52 FOR ABOVE **** ; S DA=APSDDIE,DA(1)=APSDDIEN S DIK="^PSRX("_DA(1)_",1," S PS="EDIT" ;FOR XREF APCC D ^DIK K DIK,DA ;FIX QTY IN DRUG FILE ;WON'T ADD BACK TO INVENTORY IF RETURNED TO STOCK ;IHS/DSD/POC 4/21/98 I 'APSDTURN S:$D(^PSDRUG(APSDDRUG,660.1)) ^(660.1)=^(660.1)+APSDQTY I APSDTURN S $P(^PSRX(APSDRTDA,0),"^",9)=$P(^PSRX(APSDRTDA,0),"^",9)-1 ;IHS/DSD/POC/ENM DEC #OF REF ;CHECK THIS OUT ****** ABOVE ;SET THE ACTIVITY LOG S K=1,D1=0 F Z=0:0 S Z=$O(^PSRX(APSDDIEN,"A",Z)) Q:'Z S D1=Z,K=K+1 S D1=D1+1 S:'$D(^PSRX(APSDDIEN,"A",0))#10 ^(0)="^52.3DA^^^" S ^(0)=$P(^(0),"^",1,2)_"^"_D1_"^"_K D NOW^%DTC S ^PSRX(APSDDIEN,"A",D1,0)=%_"^D^"_DUZ_"^"_APSDRFN_"^"_"REFILL DELETED FOR DATE "_$$FMTE^XLFDT(APSDDATE) ;DO THE NUMBER OF REFILLS GET RESET ?? ***** ;EXPIRATION DATE AND STATUS S REPRINT="" S (PPL,J)=APSDDIEN,OEXDT=+$P(RX2,"^",6) D ^PSOEXDT S NEXDT=+$P(RX2,"^",6) I OEXDT'=NEXDT D .S D=$P(^PSRX(DA,0),"^",2) K ^PS(55,D,"P","A",OEXDT,APSDDIEN) .S ^PS(55,D,"P","A",NEXDT,APSDDIEN)="" K D,OEXDT,NEXDT .Q ;NEXT POSSIBLE REFILL AND LAST REFILL S IRXN=APSDDIEN ;F I="RXO","RX2","RX3","IRXN" S @("APSD("_I_")")=@I F I="RX0","RX2","RX3","IRXN" S @"APSD"@(I)=@I D NEXT^PSOUTIL(.APSD) K DIE,DR,DA S DIE="^PSRX(",DA=APSD("IRXN") S DR="101///"_$P(APSD("RX3"),"^")_";102///"_$P(APSD("RX3"),"^",2) D ^DIE K DIE,DA,DR,X,Y ;IS THIS SOME KIND OF COPAY XREF I'VE NEVER SEEN IT K ^PSRX("ACP",$P(^PSRX(APSDDIEN,0),"^",2),APSDRFDT,APSDDIE,APSDDIEN) ;APSDDIE=IEN OF SUBFILE APSDDIEN=IEN OF ROOT L -^PSRX(APSDDIEN) ;PCC LINK ;I $P(%APSITE,"^",15)="Y" D ^APSPCCD ;IHS/DSD/POC 05/26/98 ;CLEAN UP TIME K PS D EN^XBVK("APSD") Q PSORXED PSORXED ;IHS/DSD/JCM - EDIT RX UTILITY [ 08/25/1999 3:12 PM ] ;;6.0;OUTPATIENT PHARMACY;**1,2**;09/03/97 ;;6.0;OUTPATIENT PHARMACY;**13,30,44,74,94,73,124**;09/03/97 START D INIT,LKUP G:PSORXED("QFLG") END D PARSE,EOJ G START END D EOJ Q INIT S PSORXED("QFLG")=0 Q LKUP ;S PSONUM="RX",PSONUM("A")="EDIT",PSOQFLG=0 D EN1^PSONUM I PSOQFLG!($Q(PSOLIST)']"") S PSORXED("QFLG")=1 ;IHS/DSD/ENM 08/08/96 N PSOOPT S PSOOPT=3 ;IHS/DSD/ENM 08/08/96 K PSOSD ;IHS/DSD/ENM/POC 01/29/98 FORCE REBUILD AFTER EDIT S PSONUM("A")="EDIT ",PSOQFLG=0 D ^PSONUM I PSOQFLG!($Q(PSOLIST)']"") S PSORXED("QFLG")=1 ;IHS/DSD/ENM 08/08/96 K PSOQFLG Q ; PARSE F PSORXED("LIST")=1:1 Q:'$D(PSOLIST(PSORXED("LIST")))!PSORXED("QFLG") F PSORXED("I")=1:1:$L(PSOLIST(PSORXED("LIST"))) S PSORXED("IRXN")=$P(PSOLIST(PSORXED("LIST")),",",PSORXED("I")) D:+PSORXED("IRXN") PROCESS Q PROCESS S PSORXED("DFLG")=0 G:$G(^PSRX(PSORXED("IRXN"),0))']"" PROCESSX S PSORXED("RX0")=^PSRX(PSORXED("IRXN"),0),PSORXED("RX2")=^(2),PSORXED("RX3")=^(3),PSODAYS=$P(PSORXED("RX0"),"^",8) ;--- --- --- --- --- ;IHS/DSD/ENM 11/28/95 SET PAR FOR PCC LINK ;I $P(%APSITE,U,15)="Y" S APSRX=PSORXED("IRXN"),APSRCT=0 I $D(D1),$D(^PSRX(APSRX,1,D1,0)) S APSRCT=D1 ;IHS/DSD/ENM/POC 01/29/98 LINE MOVED BELOW S (I,RFD,RFDT)=0 F S I=$O(^PSRX(PSORXED("IRXN"),1,I)) Q:'I S RFD=I,PSORXED("RX1")=^PSRX(PSORXED("IRXN"),1,I,0),RFDT=$P(^(0),"^"),PSODAYS=$P(^(0),"^",10) S:$P(^(0),"^",17) PSONEW("PROVIDER NAME")=$P(^VA(200,$P(^(0),"^",17),0),"^") I $P(%APSITE,U,15)="Y" S APSRX=PSORXED("IRXN"),APSRCT=0 I $D(RFD),$D(^PSRX(APSRX,1,RFD,0)) S APSRCT=RFD ;IHS/DSD/ENM/POC 11/29/98 S APSRM=$G(^PSRX(APSRX,1,RFD,999999911)) ;IHS/DSD/ENM/POC VMED VALUE S APSPRIEN=APSRX ;IHS/DSD/ENM/POC 01/29/98 S PSORXST=+$P($G(^PS(53,+$P(PSORXED("RX0"),"^",3),0)),"^",7) N DA S DA=PSORXED("IRXN") D EN^PSORXPR D CHECK G:PSORXED("DFLG") PROCESSX D DIE,LOG,POST PROCESSX Q CHECK L +^PSRX(PSORXED("IRXN")):0 I '$T W *7,!!,"Rx Number is Locked by Another User!",! S PSORXED("DFLG")=1 H 5 Q I $G(^PSDRUG($P(PSORXED("RX0"),"^",6),"I"))]"",^("I")
0 S PSORXI("DA")=+Y I PSOZZZ>0 S PSORXI("DA")=+PSOZZZ ;NEXT LINE FOR INTERACTING DRUG TO BE RECORDED I PSOZZZ>0 D:$G(PSORX("INTERVENE"))=1!($G(PSORX("INTERVENE"))=2) ;IHS/DSD/ENM 01/06/98 .S PSOZDATE=$P(Y,"^",2) .S ^APSPQA(32.4,+Y,13,0)="^^1^1^"_PSOZDATE_"^",^(1,0)="INTERACTING DRUG IS "_DRG .Q ;E S PSORXI("QFLG")=1 G DICX I PSOZZZ<1 S PSORXI("QFLG")=1 G DICX ;IHS/DSD/ENM 01/06/98 END OF OKCA/POC MOD D DIE DICX K X,Y Q DIE ; K DIE,DIC,DR,DA S DIE="^APSPQA(32.4,",DA=PSORXI("DA"),DR=$S($G(PSORXI("EDIT"))]"":".03:1600",1:".03;.08") L +^APSPQA(32.4,PSORXI("DA")) D ^DIE K DIE,DIC,DR,X,Y,DA L -^APSPQA(32.4,PSORXI("DA")) W *7,!!,"See 'Pharmacy Intervention Menu' if you want to delete this",!,"intervention or for more options.",! Q EDIT ; K DIR W ! S DIR(0)="Y",DIR("A")="Would you like to edit this intervention " S DIR("B")="N" D ^DIR K DIR I $D(DIRUT)!'Y G EDITX S PSORXI("EDIT")=1 D DIE G EDIT EDITX K X,Y Q ; EOJ ; K PSORXI Q ; EN1(PSOX) ; Entry Point if have internal rx # N PSODFN,PSONEW,PSODRUG,PSOY I $G(^PSRX(+$G(PSOX),0))']"" W !,*7,"No prescription data" G EN1X S PSORXI("IRXN")=PSOX K PSOY S PSOY=^PSRX(PSORXI("IRXN"),0) S PSODFN=$P(PSOY,"^",2),PSONEW("PROVIDER")=$P(PSOY,"^",4) S PSODRUG("IEN")=$P(PSOY,"^",6) D START EN1X Q PSORXPAR PSORXPAR ;BHAM/ISC/SAB - PARTIAL PRESCRIPTIONS [ 05/14/1998 4:04 PM ] ;;6.0;OUTPATIENT PHARMACY;**1**;09/03/97 ;;6.0;OUTPATIENT PHARMACY;**17,50,66,74**;09/03/97 ASK S PS="PARTIAL" S DIC("S")="I '$P(^PSRX(+Y,0),""^"",15),+$G(^(2)),$P($G(^(2)),""^"",6)'$P(^PSRX(RX,2),"^",6) W !!,*7,"Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) S $P(^PSRX(RX,0),"^",15)=11 G LRP S DFN=$P(PDA,"^",2) D DEM^VADPT I $P(VADM(6),"^",2)]"" D G LRP .W *7,!!,$P(^DPT($P(PDA,"^",2),0),"^")_" Died "_$P(VADM(6),"^",2)_".",! .S $P(^PSRX(RX,0),"^",15)=12,PCOM="Patient Expired "_$P(VADM(6),"^",2),ST="C" .D ACT1,KILL S X=$O(^PS(52.5,"B",DA,0)) I X,'$G(^PS(52.5,X,"P")) W !,*7,"RX MAY NOT BE PRINTED using this option, use SUSPENSE FUNCTIONS Options." K X G LRP K X I $D(^PS(52.4,DA)) W !,"PRESCRIPTION IS NON-VERIFIED",!! G LRP S DFN=$P(^PSRX(DA,0),"^",2) I $D(^PS(52.4,"AREF",DFN,DA)) W !,"PRESCRIPTION IS WAITING FOR OTHERS TO BE VERIFIED",!! G LRP I $G(PSODIV),$D(^PSRX(DA,2)),+$P(^(2),"^",9),+$P(^(2),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=DA D CHK1^PSOUTLA G:PSPOP LRP I $P(PDA,"^",15)=3 W !?3,"PRESCRIPTION IS ON HOLD" G LRP I $P(PDA,"^",15)=4 W !?3,"PRESCRIPTION IS PENDING DUE TO DRUG/DRUG INTERACTIONS" G LRP I $P(PDA,"^",15)=12 W !?3,"PRESCRIPTION IS CANCELLED" G LRP S COPIES=$S($P(PDA,"^",18)]"":$P(PDA,"^",18),1:1) ZZ ;IHS/DSD/ENM 09/14/94 Nbr of Copies changed to 999 ;K DIR S DIR("A")="NUMBER OF COPIES? ",DIR("B")=COPIES,DIR(0)="N^1:99:0",DIR("?")="ENTER THE NUMBER OF COPIES YOU WANT (1 TO 99)" K DIR S DIR("A")="NUMBER OF COPIES? ",DIR("B")=COPIES,DIR(0)="N^1:999:0",DIR("?")="ENTER THE NUMBER OF COPIES YOU WANT (1 TO 999)" D ^DIR K DIR G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) KILL S COPIES=X ZZE ;IHS/DSD/ENM 09/15/94 next 4 lines disabled (for VA labels) ;K DIR S DIR("A")="PRINT 'LEFT' SIDE OF LABEL ONLY? ",DIR(0)="SA^Y:YES;N:NO",DIR("B")="N",DIR("?",1)="If both sides of the label are to print press Return for default." ;S DIR("?")="Else if only package and mailing label are to print enter 'Y'" D ^DIR K DIR I $D(DUOUT) D KILL G LRP ;G:$D(DTOUT)!($D(DIRUT))!($D(DIROUT)) KILL ;S SIDE=$S(X="Y":1,1:0) D ACT I $D(DUOUT)!($D(DTOUT))!($D(DIRUT))!($D(DIROUT)) D KILL G LRP D ACT I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)) D KILL G LRP ;IHS/DSD/ENM 9-15-94 ;DIRUT REMOVED G LRP:$D(PCOM) F I=1,2,4,6,7,10,13,16 S P(I)=$P(PDA,"^",I) S P(6)=+P(6) I $D(^PSRX(DA,"TN")),^("TN")]"" S P(6)=^("TN") W !!,P(1),?23,$E(P(13),4,5),"/",$E(P(13),6,7),"/",$E(P(13),2,3),!,$S($D(^DPT(+P(2),0)):$P(^(0),"^"),1:"NOT ON FILE"),?30,"#",P(7),!,P(10) W !!,$S((P(6)=+P(6))&$D(^PSDRUG(P(6),0)):$P(^(0),"^"),1:P(6)),! S PHYS=$S($D(^VA(200,+P(4),0)):$P(^(0),"^"),1:"UNKNOWN"),ZCK=$P($G(^VA(200,+P(16),0)),"^",2) W PHYS,?25,ZCK,! K PHYS ;IHS/DSD/ENM 3.23.95 G INITIALS ;W !!,$S((P(6)=+P(6))&$D(^PSDRUG(P(6),0)):$P(^(0),"^"),1:P(6)),! S PHYS=$S($D(^VA(200,+P(4),0)):$P(^(0),"^"),1:"UNKNOWN") W PHYS,?25,P(16),! K PHYS ;D @$S($P($G(PSOPAR),"^",26):"^PSORXL",1:"Q^PSORXL") K PSPOP,PPL,COPIES,SIDE,REPRINT,PCOM,IOP,PSL,PSNP G LRP ;IHS/DSD/ENM 10/23/96 D P^PSORXL K PSPOP,PPL,COPIES,SIDE,REPRINT,PCOM,IOP,PSL,PSNP G LRP ;IHS/DSD/ENM 10/23/96 ; ;IHS/DSD/ENM 09/07/95 'O' ADDED TO DIR(0) BELOW ACT K DIR S DIR("A")="COMMENTS: ",DIR(0)="FAO^5:60",DIR("?")="5-60 characters input required for activity log." S:$G(PCOMX)]"" DIR("B")=$G(PCOMX) ;D ^DIR K DIR Q:$D(DUOUT)!($D(DTOUT))!($D(DIRUT))!($D(DIROUT)) S (PCOM,PCOMX)=X D ^DIR K DIR Q:$D(DUOUT)!($D(DTOUT))!($D(DIROUT)) S (PCOM,PCOMX)=X ;IHS/DSD/ENM 09/07/95 DIRUT REMOVED I '$D(PSOCLC) S PSOCLC=DUZ ACT1 S RXF=0 F J=0:0 S J=$O(^PSRX(DA,1,J)) Q:'J S RXF=J S IR=0 F J=0:0 S J=$O(^PSRX(DA,"A",J)) Q:'J S IR=J S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^"_$S($G(ST)'="C":"W",1:"C")_"^"_DUZ_"^"_RXF_"^"_PCOM_$S($G(ST)'="C":" ("_COPIES_" COPIES)",1:""),PCOMX=PCOM K PC,IR,PS,PCOM,XX,%,%H,%I,RXF Q ; KILL K %,DIR,DUOUT,DTOUT,DIROUT,DIRUT,PCOM,PCOMX,C,DA,DIC,I,J,JJJ,K,RX,RXF,X,Y,Z,ZD,DFN,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT D KVA^VADPT K APSHRN,APSP,APSPDY,APSPLOT,APSPM0,APSPMF,APSPZ,APSPZZ,APSPZZN,ARRAY,LOT,PSZB,PSZE,PSZK,PSZL,PSZQ,PSZRM,PSZTAB,PSZW ;IHS/DSD/ENM 01/24/97 PSORXVW PSORXVW ;BHAM/ISC/SAB - VIEW OF A PRESCRIPTION [ 05/14/1998 4:04 PM ] ;;6.0;OUTPATIENT PHARMACY;**1**;09/03/97 S PS="VIEW" A1 W ! S DIC("S")="I $P(^(0),""^"",15)'=13",DIC=52,DIC(0)="QEAM",DIC("A")=PS_" PRESCRIPTION: " D ^DIC K DIC("A") G KILL:X=""!(X="^") G A1:Y<0 S DA=+Y D:PS="PARTIAL" Q:$G(X)="^" .S DFN=$P(^PSRX(DA,0),"^",2) D DEM^VADPT I +VADM(6) W !!,*7,"PATIENT DIED "_$P(VADM(6),"^",2),! S X="^" .I $P($G(^PSRX(DA,0)),"^",15)=12 W !!,*7,"Medication Cancelled !",! S X="" I $G(PSODIV),PS'="VIEW",$P($G(^PSRX(DA,2)),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=DA D CHK1^PSOUTLA G:PSPOP A1 K PSPOP,PSPRXN S %=1 D OUT S:PS="REINSTATE" PS="CANCEL" G A1:%'=1 Q OUT ;D ^PSORXPR S %=2 Q:PS="VIEW" S APSPLTYP="V" D ^PSORXPR S %=2 Q:PS="VIEW" ;IHS/DSD/ENM 1/20/95 ASK ;IHS/DSD/ENM/POC 01/20/98 DON'T DELETE RX'S WITH REFILLS ;I PS="DELETE",$O(^PSRX(DA,1,0)) W !!,"YOU CAN'T DELETE RXS WITH REFILLS" S X="^" Q ;IHS/DSD/ENM/POC 01/28/98 CALL NOW MADE IN PSORXDL W !!,PS D YN^DICN S X=% I %Y["?" W !!,"Enter 'Y' for 'Yes' or Press Return for 'No'",! S %=2 G ASK S:%=2 X="^" Q A11 I PSODIV,$D(^PSRX(DA,2)),+$P(^(2),"^",9),+$P(^(2),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=DA D CHK^PSOUTLA Q:PSPOP K PSPOP,PSPRXN S %=1 D OUT1 S:PS="REINSTATE" PS="CANCEL" Q OUT1 D ^PSORXPR S %=2 Q ; KILL I PS="PARTIAL" S APSP("PM")=$G(APSPMM),APSP("PD")=$G(APSPD),APSP("PL")=$G(APSPL) ;IHS/DSD/ENM 09/02/96 MFG VAR USED AT PARTIAL RX I PS="VIEW" K %,DA,DIC,I,II,J,N,PHYS,PS,RFDATE,RFL,RFL1,ST,ST0,X,Y,Z,RFLL,APSPMM,APSPL,APSPD,APSP,APSPCP,APSPLTYP,APSPRXX Q PSOUTL PSOUTL ;BHAM/ISC/SAB - UTILITY ROUTINE USED THROUGHOUT PSO* [ 05/14/1998 4:04 PM ] ;;6.0;OUTPATIENT PHARMACY;**1**;09/03/97 ;;6.0;OUTPATIENT PHARMACY;**10,58,71**;09/03/97 SUSPCAN ;CANCEL RX FROM SUSPENSE USED IN NEW, RENEW and VERIFICATION OF RXs S PSLAST=0 F PSI=0:0 S PSI=$O(^PSRX(PSRX,1,PSI)) Q:'PSI S PSLAST=PSI I PSLAST S PSI=^PSRX(PSRX,1,PSLAST,0) K ^PSRX(PSRX,1,PSLAST),^PSRX(PSRX,1,"B",+PSI,PSLAST) S ^(0)=$P(^PSRX(PSRX,1,0),"^",1,3)_"^"_($P(^(0),"^",4)-1) K PSLAST,PSI,SUSX,SUS1,SUS2 Q S $P(^PSRX(PSRX,3),"^",7)="CANCELLED FROM SUSPENSE BEFORE FILLING" K PSI,SUSX,SUS1,SUS2 Q ; ACTLOG ;ENTER MESSAGE INTO RX ACTIVITY LOG F PSI=0:0 S PSI=$O(^PSRX(PSRX,"A",PSI)) I 'PSI!'$O(^(PSI)) S ^PSRX(PSRX,"A",+PSI+1,0)=DT_"^"_PSREA_"^"_PSOCLC_"^"_PSRXREF_"^"_PSMSG,^PSRX(PSRX,"A",0)="^52.3DA^"_(+PSI+1)_"^"_(+PSI+1) Q ACTOUT I PSREA="C" S PSI=$S($D(^PSRX(PSRX,2)):+$P(^(2),"^",6),1:0) K:$D(^PS(55,PSDFN,"P","A",PSI,PSRX)) ^(PSRX) S ^PS(55,PSDFN,"P","A",DT,PSRX)="" Q I PSREA="R" F PSI=0:0 S PSI=$O(^PSRX(PSRX,"A",PSI)) Q:'PSI I $D(^(PSI,0)),$P(^(0),"^",2)="C" S PSS=+^(0) I $D(PSS),PSS K:$D(^PS(55,PSDFN,"P","A",PSS,PSRX)) ^(PSRX) I PSREA="R",$D(^PSRX(PSRX,2))#2 S ^PS(55,PSDFN,"P","A",+$P(^PSRX(PSRX,2),"^",6),PSRX)="" Q ; QUES ;DISPLAY CHOICE INSTRUCTIONS FOR RENEW AND REFILL W !?5,"Enter the item #(s) or RX #(s) you wish to ",$S(PSFROM="N":"renew ",PSFROM="R":"REFILL "),"separated by commas." W !?5,"For example: 1,2,5 or 123456,33254A,232323B." W !?5,"Do not enter the same number twice, duplicates are not allowed." Q ENDVCHK S PSOPOP=0 Q:'PSODIV Q:'$P(^PSRX(PSRX,2),"^",9)!($P(^(2),"^",9)=PSOSITE) CHK1 I '$P(PSOSYS,"^",2) W !?10,*7,"RX# ",$P(^PSRX(PSRX,0),"^")," is not a valid choice. (Different Division)" S PSPOP=1 Q I $P(PSOSYS,"^",3) W !?10,*7,"RX# ",$P(^PSRX(PSRX,0),"^")," is from another division. Continue? (Y/N) " R ANS:DTIME I ANS="^"!(ANS="") S PSPOP=1 Q I (ANS']"")!("YNyn"'[$E(ANS)) W !?10,*7,"Answer 'YES' or 'NO'." G CHK1 S:$E(ANS)["Nn" PSPOP=1 Q K52 S SFN=+$O(^PS(52.5,"B",DA(1),0)) G:X'=""&(SFN)&($G(Y)=1) KILL I $G(Y)'=1,SFN S SDT=+$P(^PS(52.5,SFN,0),"^",2) K ^PS(52.5,"C",SDT,SFN),^PS(52.5,"AC",+$P(^PS(52.5,SFN,0),"^",3),SDT,SFN),SFN,SDT Q S52 S RIFN=0 F S RIFN=$O(^PSRX(DA(1),1,RIFN)) Q:'RIFN S RFID=$P(^PSRX(DA(1),1,RIFN,0),"^") S SFN=+$O(^PS(52.5,"B",DA(1),0)) I SFN,'$G(^PS(52.5,SFN,"P")),$P($G(^PSRX($P($G(^PS(52.5,SFN,0)),"^"),0)),"^",15)=5 D .S $P(^PS(52.5,SFN,0),"^",2)=RFID,^PS(52.5,"C",RFID,SFN)="",^PS(52.5,"AC",+$P(^PS(52.5,SFN,0),"^",3),RFID,SFN)="" K SFN,RFIN,RFID Q KILL S $P(^PSRX(DA(1),0),"^",15)=0,DFN=+$P(^PS(52.5,SFN,0),"^",3),PAT=$P(^DPT(DFN,0),"^") K ^PS(52.5,"B",+$P(^PS(52.5,SFN,0),"^"),SFN),^PS(52.5,"C",+$P(^PS(52.5,SFN,0),"^",2),SFN),^PS(52.5,"D",PAT,SFN),^PS(52.5,"AC",DFN,+$P(^PS(52.5,SFN,0),"^",2),SFN),^PS(52.5,SFN,0),^PS(52.5,SFN,"P"),DFN,SFN,PAT S CNT=0 F SUB=0:0 S SUB=$O(^PSRX(DA(1),"A",SUB)) Q:'SUB S CNT=SUB D NOW^%DTC S CNT=CNT+1 L +^PSRX(DA(1),0) S ^PSRX(DA(1),"A",0)="^52.3DA^"_CNT_"^"_CNT,^PSRX(DA(1),"A",CNT,0)=%_"^D^"_DUZ_"^"_DA_"^"_"Refill deleted during Rx edit." L -^PSRX(DA(1),0) K CNT,SUB Q CID ;calculates six months limit on past issue dates S PSID=X,X="T-6M",%DT="X" D ^%DT S %DT(0)=Y,X=PSID,%DT="EX" D ^%DT K PSID ;IHS/DSD/ENM/POC 01/16/98 NEXT LINE PREVENTS FUTURE DATES S X=Y,%DT(0)=-DT,%DT="EX" D ^%DT Q CIDH S X="T-6M",%DT="X" D ^%DT X ^DD("DD") W !,"Issue Date must be greater or equal to "_Y Q SPR F RF=0:0 S RF=$O(^PSRX(DA(1),1,RF)) Q:'RF S NODE=RF I NODE=1 S $P(^PSRX(DA(1),3),"^",4)=$P(^PSRX(DA(1),2),"^",2) Q SREF I $G(NODE) S NODE=NODE-1 G:'$D(^PSRX(DA(1),1,NODE,0)) SREF I NODE=0 S $P(^PSRX(DA(1),3),"^",4)=$P(^PSRX(DA(1),2),"^",2) Q S $P(^PSRX(DA(1),3),"^",4)=$P(^PSRX(DA(1),1,NODE,0),"^",1) Q K NODE,RF Q KPR F RF=0:0 S RF=$O(^PSRX(DA(1),1,RF)) Q:'RF S NODE=RF I NODE=DA&(X'="") S NODE=NODE-1 S:NODE=1 NODE=0 G:'NODE ORIG G:NODE>1 KREF I NODE=1 S $P(^PSRX(DA(1),3),"^",4)=$P(^PSRX(DA(1),2),"^",2) G EX KREF S NODE=NODE-1 G:'NODE EX I NODE=1 S $P(^PSRX(DA(1),3),"^",4)=$P(^PSRX(DA(1),2),"^",2) G EX G:NODE=DA&(X'="") KREF G:'$D(^PSRX(DA(1),1,NODE,0)) KREF ORIG I 'NODE S $P(^PSRX(DA(1),3),"^",4)=$P(^PSRX(DA(1),2),"^",2) G EX S $P(^PSRX(DA(1),3),"^",4)=$P(^PSRX(DA(1),1,NODE,0),"^",1) G EX EX K NODE,RF Q FLD K DIR S DIR("A")=$P(^DD(52,99,0),"^"),DIR(0)="52,99" D ^DIR Q:$D(DUOUT)!($D(DIRUT)) S FLD(99)=Y I $G(FLD(99))=99 K DIR S DIR("A")=$P(^DD(52,99.1,0),"^"),DIR(0)="52,99.1" D ^DIR Q:$D(DUOUT)!($D(DIRUT)) S FLD(99.1)=Y Q E S FLD(99.1)="" Q