100 lines
2.7 KiB
Mathematica
100 lines
2.7 KiB
Mathematica
PPPPRT1 ;ALB/DMB - PRINT FOREIGN PROFILE ROUTINES ; 3/3/92
|
|
;;V1.0;PHARMACY PRESCRIPTION PRACTICE;;APR 7,1995
|
|
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
;
|
|
VFM(PATDFN,PHRMARRY) ; View/print foreign medication for 1 patient.
|
|
;
|
|
N %ZIS,PPPARRY,PPPDOB,PPPNAME,PPPSSN,PPPTMP
|
|
N DA,DIC,DIR,DOB,DR,ERR,LKUPERR,NAME,ND,NODE,NODELEN,OPENERR
|
|
N OUT,PARMERR,POP,QUEERR,SSN,TMP,DIQ
|
|
N ZTDESC,ZTDTH,ZTIO,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK
|
|
;
|
|
S PARMERR=-9001
|
|
S LKUPERR=-9003
|
|
S OPENERR=-9011
|
|
S QUEERR=-9012
|
|
S ERR=0
|
|
;
|
|
S DIC=2,DA=PATDFN,DR=".01;.03;.09",DIQ="PPPTMP"
|
|
D EN^DIQ1
|
|
I '$D(PPPTMP) Q LKUPERR
|
|
S NAME=PPPTMP(2,DA,.01)
|
|
S DOB=PPPTMP(2,DA,.03)
|
|
S SSN=PPPTMP(2,DA,.09)
|
|
;
|
|
PWHERE ; Ask where to send the listing
|
|
;
|
|
S %ZIS="QM",%ZIS("A")="Print Profile On What Device? "
|
|
D ^%ZIS
|
|
I POP D Q OPENERR
|
|
.W !,*7,"Error Opening Print Device."
|
|
.R !,"Press <RETURN> To Continue...",TMP:DTIME
|
|
QTSK I IO'=IO(0) D
|
|
.I '$D(IO("Q")) S ZTDTH=$H
|
|
.S ZTRTN="START^PPPPRT1"
|
|
.S ZTIO=ION
|
|
.S ZTDESC="FOREIGN MEDICATION PRINT"
|
|
.S ZTSAVE("PPPNAME")=NAME
|
|
.S ZTSAVE("PPPDOB")=DOB
|
|
.S ZTSAVE("PPPSSN")=SSN
|
|
.S ZTSAVE("PPPARRY")=PHRMARRY
|
|
.D ^%ZTLOAD
|
|
QERR .I '$D(ZTSK) D Q
|
|
..D HOME^%ZIS
|
|
..W !!,*7,"Error... Print task was not started successfully"
|
|
..R !,"Press <RETURN> To Continue...",TMP:DTIME
|
|
..S ERR=QUEERR
|
|
.I $D(IO("Q")) W !!,"Request Queued On ",ION
|
|
E D
|
|
.S PPPNAME=NAME
|
|
.S PPPDOB=DOB
|
|
.S PPPSSN=SSN
|
|
.S PPPARRY=PHRMARRY
|
|
.D START
|
|
Q ERR
|
|
;
|
|
START ;
|
|
;
|
|
N PAGE,OUT,BNR1,BNR2,DIR,I,X,Y
|
|
;
|
|
S BNR1="Pharmacy Prscription Practices"
|
|
S BNR2="Foreign Medication Profile"
|
|
S PAGE=1
|
|
S OUT=""
|
|
;
|
|
D HEADING,QUERY
|
|
W @IOF
|
|
I $D(ZTQUEUED) S ZTREQ="@"
|
|
D ^%ZISC
|
|
K @PPPARRY,PPPNAME,PPPSSN,PPPDOB,PPPARRY
|
|
Q
|
|
;
|
|
HEADING ; Write the page heading, Pause if a crt.
|
|
;
|
|
I PAGE>1,$E(IOST,1,2)="C-" D Q:OUT["^"
|
|
.S DIR(0)="E" D ^DIR
|
|
.I +Y=0 S OUT="^"
|
|
W @IOF,!
|
|
W ?((IOM-$L(BNR1))\2),BNR1,?(IOM-15),"Page ",PAGE,!
|
|
W ?((IOM-$L(BNR2))\2),BNR2,!
|
|
W !,"Patient: ",PPPNAME_" ("_PPPSSN_")",?60,"DOB: ",PPPDOB
|
|
W !!,"RX #",?9,"DRUG",?41,"ST",?45,"QTY",?51,"ISSUED",?65,"LAST FILLED"
|
|
W ! F I=1:1:IOM-1 W "-"
|
|
S PAGE=PAGE+1
|
|
Q
|
|
;
|
|
QUERY ; Query through the array and print the data
|
|
;
|
|
S NODE=PPPARRY
|
|
S NODELEN=$L(PPPARRY)
|
|
F I=0:0 D Q:($E(NODE,1,NODELEN-1)'=$E(PPPARRY,1,NODELEN-1))!(OUT["^")
|
|
.S NODE=$Q(@NODE) Q:($E(NODE,1,NODELEN-1)'=$E(PPPARRY,1,NODELEN-1))
|
|
.S ND=@NODE
|
|
.I $Y+5>IOSL D HEADING Q:OUT["^"
|
|
.W !!,$P(ND,"^"),?9,$E($P(ND,"^",2),1,30),?41,$E($P(ND,"^",3),1),?45,$P(ND,"^",4),?51,$$SLASHDT^PPPCNV1($P(ND,"^",5)),?65,$$SLASHDT^PPPCNV1($P(ND,"^",6))
|
|
.W !,?9,"SIG: ",$E($P(ND,"^",7),1,25),?40,"ISSUED AT ",$P(ND,"^",8)," (",$P(ND,"^",9),")"
|
|
I $E(IOST,1,2)="C-"&(OUT'["^") D
|
|
.W !!,*7,"Listing Complete."
|
|
.R !,"Press <RETURN> to continue...",OUT:DTIME
|
|
Q
|