PSNPPIP ;BIR/DMA-WRT-print a medication instruction sheet ; 12 Apr 2007 8:38 AM
;;4.0; NATIONAL DRUG FILE;**3,7,30,62,84,141,181**; 30 Oct 98;Build 3
;
; Reference to ^PS(59.7 supported by IA #2613
; Reference to ^PSDRUG supported by IA #221
; Reference to ^ps(55 supported by IA #2191
;
PICK ;select a drug from file 50
D DEFLT
I $D(PSNDRUG) Q
;
I '$D(^PS(50.621))!'$D(^PS(50.622)) W !,"Patient Medication Instruction Sheets data has not been installed",!! G PAUSE
;
K DRG F S DIC=50,DIC(0)="AEQMZ",DIC("S")="I $S('$G(^PSDRUG(+Y,""I"")):1,DT'>^(""I""):1,1:0)" D ^DIC K DIC Q:Y<0 D
.I '$G(^PSDRUG(+Y,"ND")) W !,"Drug not matched to NDF" Q
.;
.S PSNGCN=""
.S X=^PSDRUG(+Y,"ND"),X=$P($G(^PSNDF(50.68,+$P(X,"^",3),1)),"^",5) I 'X W !,"Sorry No PMI sheet available" Q
.S DRG(+Y)=X
I '$O(DRG(0)) G PAUSE
EN1 ; entry
K DIR S DIR(0)="S^1:English;2:Spanish",DIR("A")="Select Language " S:$D(PSNLANG) DIR("B")=PSNLANG D ^DIR K DIR I $D(DIRUT) G PAUSE
;
;If PSNTYPE=2 then branch to English 50.621 at DOONE
;If PSNTYPE=5 then branch to Spanish 50.622 at DOONE
S PSNTYPE=$S(Y=1:2,1:5)
;order in the file is 1=English, 2=Spanish
;
S DIR(0)="N^1:100:0",DIR("A")="How many copies? ",DIR("B")=1 D ^DIR K DIR I $D(DIRUT) G PAUSE
S NUM=Y
K ZTSAVE S (ZTSAVE("PSNTYPE"),ZTSAVE("DRG("),ZTSAVE("NUM"),ZTSAVE("PSNDFN"),ZTSAVE("PSNTRADE"),ZTSAVE("PSRX"))="" S:$D(PSNPRTR) %ZIS("B")=PSNPRTR
D EN^XUTMDEVQ("DOMORE^PSNPPIP","Print Medication Information Sheets",.ZTSAVE,.%ZIS) I 'POP G QUIT
W !,"No device selected and no PMIS printed",!
PAUSE R !,"Press return to continue",X:10
QUIT K ^TMP($J,"W"),CNTI,CNTO,DIRUT,DRUG,DRG,IN,J,K,LIN0,LINE,LM,NAM,NUM,PG,POP,PSNGCN,PPIN1,PPIN2,PPIND,RM,QUIT,SPEC,TYP,PSNTYPE,X,Y,ZTDESC,ZTRTN,ZTSAVE,DEFLANG,DEFPRTR,PSNDEV,PSNLANG,PSNPRTR,I,N,L,LENGTH,PROD,P,PSNALPHA
K PSNBND,PSNBOLD,PSNEMAP,PSNENG,PSNFLAG,PSNLAST,PSNORM,PSNSP D:'$D(PSODFN) KILL^%ZISS Q
Q
;
Q
;
DOMORE ;multiple
S DRG=0 F S DRG=$O(DRG(DRG)) Q:'DRG S PSNGCN=DRG(DRG) D DOONE
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" Q
;
DOONE ;Print one PMI sheet
;needs PSNTYPE=1-6 (English, etc.),NUM=# of copies
;DRG=IFN in file 50
;optional DFN=DFN for a particular patient
;
N LINE,LIN0,CNTI,CNTO,X,IN,RM,LM,J,K,DRUG,SPEC,NAM
S NUM=$G(NUM,1),PSNTYPE=$G(PSNTYPE,2)
;default is one copy of Standard English
K ^TMP($J,"W")
I $D(PSNDFN) S DFN=PSNDFN,NAM=$P(^DPT(DFN,0),"^") D DEM^VADPT
S LM=3,RM=IOM-5,$P(LIN0," ",LM)="",LINE=LIN0 ;,SPEC("[]")="[] "
;Get drug name -
;1.TRADE NAME from 52 if called from PSO
;2. VA PRINT NAME from 50.68
;3. GENERIC NAME from 50
;
K DRUG I $G(PSNTRADE)'="" S DRUG=PSNTRADE
I '$D(DRUG) S DRUG=$P(^PSDRUG(DRG,0),"^"),X=$G(^("ND")),J=+X,K=+$P(X,"^",3),X=$P($G(^PSNDF(50.68,K,1)),"^") I X]"" S DRUG=X
;
;NEW CODE Takes GCNSEQNO (PSNGCN) and finds the drug IEN in
;the PMI MAP-English file (50.623) That IEN points to the text
;in the PMIS-English file
;
;Select files based on whether user wants English or Spanish
I PSNTYPE=2 S PSNFILE1=50.623 ;PMI-MAP ENGLISH file
I PSNTYPE=2 S PSNFILE2=50.621 ;PMI-ENGLISH file
I PSNTYPE=5 S PSNFILE1=50.624 ;PMI-MAP SPANISH file
I PSNTYPE=5 S PSNFILE2=50.622 ;PMI-SPANISH file
;
; S PSNEMAP=0,PSNENG=""
S PSNEMAP="",PSNENG=""
I '$O(^PS(PSNFILE1,"B",PSNGCN,0)) I '$D(PSODFN) W @IOF W !,"Drug is not linked to a valid Medication Information Sheet for language selected" K PSNGCN,PSNDF,PSNPN Q
I '$O(^PS(PSNFILE1,"B",PSNGCN,0)) I $D(PSODFN) S PSNPPI("MESSAGE")="Drug is not linked to a valid Medication Information Sheet for language selected",PSNFLAG=0 K PSNGCN,PSNDF,PSNPN W PSNPPI("MESSAGE"),! Q
S PSNEMAP=$O(^PS(PSNFILE1,"B",PSNGCN,0)) D
.I $P(^PS(PSNFILE1,PSNEMAP,0),U)=PSNGCN D
..S PSNENG=$P(^PS(PSNFILE1,PSNEMAP,0),U,2) ;Drug D0 Eng/Span file
I +PSNENG=0 W !,"No PMI sheet available" Q
;
S CNTI=0,CNTO=1,PSNSP="" ;NOTE PSNSP is a blank line insert
;
IMP ;Important note about the drug of choice
;
I $D(IOST(0)) S X="IOINHI;IOINORM;IOINLOW" D ENDR^%ZISS
S PSNALPHA=""
S PSNALPHA="Z" D TXT1
;
TITLE ;Title and phonic pronunciation
;
I '$D(^PS(PSNFILE2,+PSNENG,"F")) D
.S ^TMP($J,"W",CNTO)=$G(IOINHI)_^PS(PSNFILE2,+PSNENG,CNTI)
.S CNTO=CNTO+1
; .S ^TMP($J,"W",CNTO)=PSNSP S CNTO=CNTO+1 ;Insert blank line
;
I $D(^PS(PSNFILE2,+PSNENG,"F")) D
.S ^TMP($J,"W",CNTO)=$G(IOINHI)_^PS(PSNFILE2,+PSNENG,CNTI)_" "_$G(IOINORM)_^PS(PSNFILE2,+PSNENG,"F",1,0) S CNTO=CNTO+1
S ^TMP($J,"W",CNTO)=PSNSP S CNTO=CNTO+1 ;Insert blank line
;
;
BRAND ;Common Brand Name
;
D ^PSNPPIP1
;
F PSNALPHA="W","U","H","S","M","P","I","O","N","D","R" D:$D(^PS(PSNFILE2,+PSNENG,PSNALPHA)) TXT1
D PRINT
Q
;
TXT1 ;Text portion
;
S J=0,N=1,LINE(N)="",PSNLAST=999
S L=1,LINE(L)="",PSNBOLD="",PSNORM=""
;
S PSNLAST=$O(^PS(PSNFILE2,+PSNENG,PSNALPHA,PSNLAST),-1) ;Last subscripT
;
F S J=$O(^PS(PSNFILE2,+PSNENG,PSNALPHA,J)) Q:'J D ONELN^PSNPPIP1 D
.S LINE=^PS(PSNFILE2,+PSNENG,PSNALPHA,J,0)
.I J=PSNLAST D Q
..I (N-1)'=0 S LINE(L)=LINE(N-1)_" "_LINE ;Last lines
..I $L(LINE(L))>IOM D ;S LINE(M)=$E(LINE(L),1,IOM) D
...F I=IOM:-1:1 I $E(LINE(L),I)[" " D Q
....S ^TMP($J,"W",CNTO)=$E(LINE(L),1,I) S CNTO=CNTO+1
....S ^TMP($J,"W",CNTO)=$E(LINE(L),I+1,999)
....S CNTO=CNTO+1
..I $L(LINE(L))'>IOM D
...S ^TMP($J,"W",CNTO)=LINE(L) S CNTO=CNTO+1
.I N>1 S LINE(N-1)=LINE(N-1)_" "_$E(LINE,1,A) D ;Middle lines
..I $L(LINE(N-1))<IOM S A=IOM-$L(LINE(N-1)) Q
..D BRK
..S N=N+1,CNTO=CNTO+1
.I N=1 S LINE(N)=LINE(N)_" "_LINE,P=LINE(N) D
..F I=1:1:$L(P) I $E(P,I)=":" D
...S PSNBOLD=$G(IOINHI)_$E(P,1,I-1),PSNORM=$G(IOINORM)_$E(P,I,999) ;BOLD Section header
..S LINE(N)=PSNBOLD_PSNORM
..I $E(LINE(N),1)[" " S LINE(N)=$E(LINE(N),2,999) ;Remove lead space
..S LENGTH=$L(LINE(N)),A=IOM-LENGTH
..S N=N+1
;
S:$D(^PS(PSNFILE2,+PSNENG,PSNALPHA)) ^TMP($J,"W",CNTO)=PSNSP S:$D(^PS(PSNFILE2,+PSNENG,PSNALPHA)) CNTO=CNTO+1 ;Insert blank line
Q
;
BRK ;Break line between words rather than within a word
;
F I=IOM:-1:1 I $E(LINE(N-1),I)[" " D Q
.S ^TMP($J,"W",CNTO)=$E(LINE(N-1),1,I)
.S LINE(N)=$E(LINE(N-1),I+1,999)_$E(LINE,A+1,999)
.I $E(LINE(N),1)[" " S LINE(N)=$E(LINE(N),2,999) ;Remove lead space
.S LENGTH=$L(LINE(N)),A=IOM-LENGTH
;
Q
;
PRINT ;
S QUIT=0 F J=1:1:NUM Q:QUIT S PG=1 D HEAD Q:QUIT F K=1:1 Q:'$D(^TMP($J,"W",K)) W ^(K),! I $Y+4>IOSL D HEAD Q:QUIT
Q
HEAD ;
I PG>1,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR I 'Y S QUIT=1 Q
W:$Y @IOF W !!,?70,$S(PSNTYPE<4:"Page ",1:"P"_$C(160)_"gina "),PG,!,LIN0,$S(PSNTYPE<4:"Medication instructions for ",1:"Informaci"_$C(162)_"n sobre su medicin a "),DRUG S PG=PG+1
I $D(NAM) W !!,?2,"Printed for: ",NAM,?60,$$HTE^XLFDT(+$H),!,?2,"Rx Number: "_$G(PSRX)
W !!! Q
;
;
DICS ;set DIC("S") to screen out inactives and entries in file 50
;that are not linked through NDF to a PMI sheet
N QQQ S QQQ=$G(^PSDRUG(+Y,"ND")),QQQ=$P($G(^PSNDF(50.68,+$P(QQQ,"^",3),1)),"^",5) I QQQ,$D(PSNGCN),$S('$G(^PSDRUG(+Y,"I")):1,DT'>^("I"):1,1:0)
S QQQ=$G(^PSDRUG(+Y,0))
;reset naked indicator
Q
ENOP(PSNDRUG,PSNTRADE,PSRX,PSNDFN) ;
;
; entry point from Outpatient Pharmacy
; PSNDRUG = IFN from the DRUG file (50) ** REQUIRED **
; PSRX = IFN from the PRESCRIPTION file (52) ** OPTIONAL **
; PSNTRADE = Trade Name in printable format ** OPTIONAL **
; PSNDFN = Patient's DFN ** OPTIONAL **
;
; This entry point returns the variable PSNFLAG, it will
; be equal to 1 if the information sheet can be printed or
; it will be equal to 0 if an information sheet cannot be
; printed. If PSNFLAG=0, the variable PSNPPI("MESSAGE") will
; be returned containing a message stating why an information
; sheet could not be printed.
;
K DRG,PSNPN
S PSNFLAG=1,DRG=PSNDRUG,PSNDF=$G(^PSDRUG(PSNDRUG,"ND"))
S PSNPN=$P(PSNDF,"^",3),PSNDF=+PSNDF
I 'PSNDF S PSNPPI("MESSAGE")="This drug is not matched to the National Drug File; therefore, a Medication Information Sheet cannot be printed.",PSNFLAG=0 K PSNDF,DRG,PSNPN Q
LANGE S DEFLANG=$P($G(^PS(59.7,1,10)),"^",7) I DEFLANG]"" S PSNLANG=$S(DEFLANG=1:"English",1:"Spanish") S:PSNLANG="English" PSNTYPE=2 S:PSNLANG="Spanish" PSNTYPE=5
S PSNGCN=$P($G(^PSNDF(50.68,PSNPN,1)),"^",5)
;
I 'PSNGCN S PSNPPI("MESSAGE")="This drug is not linked to a Medication Information Sheet.",PSNFLAG=0 K PSNGCN,DRG,PSNDF,PSNPN Q
I PSNFLAG S DRG(DRG)=PSNGCN D EN1
K PSNDRUG,PSNTRADE,PSNDF,PSNPN,PSNGCN,DRG
;
Q
DEFLT S DEFLANG=$P($G(^PS(59.7,1,10)),"^",7) I DEFLANG]"" S PSNLANG=$S(DEFLANG=1:"English",1:"Spanish")
N A1 S A1=$$GET1^DIQ(55,$G(PSNDFN)_",",106.1,"I"),DEFLANG=$S(A1=2:"Spanish",A1=1:"English",1:DEFLANG)
S DEFPRTR=$P($G(^PS(59.7,1,10)),"^",6) I DEFPRTR]"" S DIC="^%ZIS(1,",DA=DEFPRTR,DR=".01",DIQ="PSNDEV",DIQ(0)="E" D EN^DIQ1 S PSNPRTR=$G(PSNDEV(3.5,DA,.01,DIQ(0)))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNPPIP 8943 printed Sep 23, 2025@20:00:37 Page 2
PSNPPIP ;BIR/DMA-WRT-print a medication instruction sheet ; 12 Apr 2007 8:38 AM
+1 ;;4.0; NATIONAL DRUG FILE;**3,7,30,62,84,141,181**; 30 Oct 98;Build 3
+2 ;
+3 ; Reference to ^PS(59.7 supported by IA #2613
+4 ; Reference to ^PSDRUG supported by IA #221
+5 ; Reference to ^ps(55 supported by IA #2191
+6 ;
PICK ;select a drug from file 50
+1 DO DEFLT
+2 IF $DATA(PSNDRUG)
QUIT
+3 ;
+4 IF '$DATA(^PS(50.621))!'$DATA(^PS(50.622))
WRITE !,"Patient Medication Instruction Sheets data has not been installed",!!
GOTO PAUSE
+5 ;
+6 KILL DRG
FOR
SET DIC=50
SET DIC(0)="AEQMZ"
SET DIC("S")="I $S('$G(^PSDRUG(+Y,""I"")):1,DT'>^(""I""):1,1:0)"
DO ^DIC
KILL DIC
if Y<0
QUIT
Begin DoDot:1
+7 IF '$GET(^PSDRUG(+Y,"ND"))
WRITE !,"Drug not matched to NDF"
QUIT
+8 ;
+9 SET PSNGCN=""
+10 SET X=^PSDRUG(+Y,"ND")
SET X=$PIECE($GET(^PSNDF(50.68,+$PIECE(X,"^",3),1)),"^",5)
IF 'X
WRITE !,"Sorry No PMI sheet available"
QUIT
+11 SET DRG(+Y)=X
End DoDot:1
+12 IF '$ORDER(DRG(0))
GOTO PAUSE
EN1 ; entry
+1 KILL DIR
SET DIR(0)="S^1:English;2:Spanish"
SET DIR("A")="Select Language "
if $DATA(PSNLANG)
SET DIR("B")=PSNLANG
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO PAUSE
+2 ;
+3 ;If PSNTYPE=2 then branch to English 50.621 at DOONE
+4 ;If PSNTYPE=5 then branch to Spanish 50.622 at DOONE
+5 SET PSNTYPE=$SELECT(Y=1:2,1:5)
+6 ;order in the file is 1=English, 2=Spanish
+7 ;
+8 SET DIR(0)="N^1:100:0"
SET DIR("A")="How many copies? "
SET DIR("B")=1
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO PAUSE
+9 SET NUM=Y
+10 KILL ZTSAVE
SET (ZTSAVE("PSNTYPE"),ZTSAVE("DRG("),ZTSAVE("NUM"),ZTSAVE("PSNDFN"),ZTSAVE("PSNTRADE"),ZTSAVE("PSRX"))=""
if $DATA(PSNPRTR)
SET %ZIS("B")=PSNPRTR
+11 DO EN^XUTMDEVQ("DOMORE^PSNPPIP","Print Medication Information Sheets",.ZTSAVE,.%ZIS)
IF 'POP
GOTO QUIT
+12 WRITE !,"No device selected and no PMIS printed",!
PAUSE READ !,"Press return to continue",X:10
QUIT KILL ^TMP($JOB,"W"),CNTI,CNTO,DIRUT,DRUG,DRG,IN,J,K,LIN0,LINE,LM,NAM,NUM,PG,POP,PSNGCN,PPIN1,PPIN2,PPIND,RM,QUIT,SPEC,TYP,PSNTYPE,X,Y,ZTDESC,ZTRTN,ZTSAVE,DEFLANG,DEFPRTR,PSNDEV,PSNLANG,PSNPRTR,I,N,L,LENGTH,PROD,P,PSNALPHA
+1 KILL PSNBND,PSNBOLD,PSNEMAP,PSNENG,PSNFLAG,PSNLAST,PSNORM,PSNSP
if '$DATA(PSODFN)
DO KILL^%ZISS
QUIT
+2 QUIT
+3 ;
+4 QUIT
+5 ;
DOMORE ;multiple
+1 SET DRG=0
FOR
SET DRG=$ORDER(DRG(DRG))
if 'DRG
QUIT
SET PSNGCN=DRG(DRG)
DO DOONE
+2 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+3 ;
DOONE ;Print one PMI sheet
+1 ;needs PSNTYPE=1-6 (English, etc.),NUM=# of copies
+2 ;DRG=IFN in file 50
+3 ;optional DFN=DFN for a particular patient
+4 ;
+5 NEW LINE,LIN0,CNTI,CNTO,X,IN,RM,LM,J,K,DRUG,SPEC,NAM
+6 SET NUM=$GET(NUM,1)
SET PSNTYPE=$GET(PSNTYPE,2)
+7 ;default is one copy of Standard English
+8 KILL ^TMP($JOB,"W")
+9 IF $DATA(PSNDFN)
SET DFN=PSNDFN
SET NAM=$PIECE(^DPT(DFN,0),"^")
DO DEM^VADPT
+10 ;,SPEC("[]")="[] "
SET LM=3
SET RM=IOM-5
SET $PIECE(LIN0," ",LM)=""
SET LINE=LIN0
+11 ;Get drug name -
+12 ;1.TRADE NAME from 52 if called from PSO
+13 ;2. VA PRINT NAME from 50.68
+14 ;3. GENERIC NAME from 50
+15 ;
+16 KILL DRUG
IF $GET(PSNTRADE)'=""
SET DRUG=PSNTRADE
+17 IF '$DATA(DRUG)
SET DRUG=$PIECE(^PSDRUG(DRG,0),"^")
SET X=$GET(^("ND"))
SET J=+X
SET K=+$PIECE(X,"^",3)
SET X=$PIECE($GET(^PSNDF(50.68,K,1)),"^")
IF X]""
SET DRUG=X
+18 ;
+19 ;NEW CODE Takes GCNSEQNO (PSNGCN) and finds the drug IEN in
+20 ;the PMI MAP-English file (50.623) That IEN points to the text
+21 ;in the PMIS-English file
+22 ;
+23 ;Select files based on whether user wants English or Spanish
+24 ;PMI-MAP ENGLISH file
IF PSNTYPE=2
SET PSNFILE1=50.623
+25 ;PMI-ENGLISH file
IF PSNTYPE=2
SET PSNFILE2=50.621
+26 ;PMI-MAP SPANISH file
IF PSNTYPE=5
SET PSNFILE1=50.624
+27 ;PMI-SPANISH file
IF PSNTYPE=5
SET PSNFILE2=50.622
+28 ;
+29 ; S PSNEMAP=0,PSNENG=""
+30 SET PSNEMAP=""
SET PSNENG=""
+31 IF '$ORDER(^PS(PSNFILE1,"B",PSNGCN,0))
IF '$DATA(PSODFN)
WRITE @IOF
WRITE !,"Drug is not linked to a valid Medication Information Sheet for language selected"
KILL PSNGCN,PSNDF,PSNPN
QUIT
+32 IF '$ORDER(^PS(PSNFILE1,"B",PSNGCN,0))
IF $DATA(PSODFN)
SET PSNPPI("MESSAGE")="Drug is not linked to a valid Medication Information Sheet for language selected"
SET PSNFLAG=0
KILL PSNGCN,PSNDF,PSNPN
WRITE PSNPPI("MESSAGE"),!
QUIT
+33 SET PSNEMAP=$ORDER(^PS(PSNFILE1,"B",PSNGCN,0))
Begin DoDot:1
+34 IF $PIECE(^PS(PSNFILE1,PSNEMAP,0),U)=PSNGCN
Begin DoDot:2
+35 ;Drug D0 Eng/Span file
SET PSNENG=$PIECE(^PS(PSNFILE1,PSNEMAP,0),U,2)
End DoDot:2
End DoDot:1
+36 IF +PSNENG=0
WRITE !,"No PMI sheet available"
QUIT
+37 ;
+38 ;NOTE PSNSP is a blank line insert
SET CNTI=0
SET CNTO=1
SET PSNSP=""
+39 ;
IMP ;Important note about the drug of choice
+1 ;
+2 IF $DATA(IOST(0))
SET X="IOINHI;IOINORM;IOINLOW"
DO ENDR^%ZISS
+3 SET PSNALPHA=""
+4 SET PSNALPHA="Z"
DO TXT1
+5 ;
TITLE ;Title and phonic pronunciation
+1 ;
+2 IF '$DATA(^PS(PSNFILE2,+PSNENG,"F"))
Begin DoDot:1
+3 SET ^TMP($JOB,"W",CNTO)=$GET(IOINHI)_^PS(PSNFILE2,+PSNENG,CNTI)
+4 SET CNTO=CNTO+1
End DoDot:1
+5 ; .S ^TMP($J,"W",CNTO)=PSNSP S CNTO=CNTO+1 ;Insert blank line
+6 ;
+7 IF $DATA(^PS(PSNFILE2,+PSNENG,"F"))
Begin DoDot:1
+8 SET ^TMP($JOB,"W",CNTO)=$GET(IOINHI)_^PS(PSNFILE2,+PSNENG,CNTI)_" "_$GET(IOINORM)_^PS(PSNFILE2,+PSNENG,"F",1,0)
SET CNTO=CNTO+1
End DoDot:1
+9 ;Insert blank line
SET ^TMP($JOB,"W",CNTO)=PSNSP
SET CNTO=CNTO+1
+10 ;
+11 ;
BRAND ;Common Brand Name
+1 ;
+2 DO ^PSNPPIP1
+3 ;
+4 FOR PSNALPHA="W","U","H","S","M","P","I","O","N","D","R"
if $DATA(^PS(PSNFILE2,+PSNENG,PSNALPHA))
DO TXT1
+5 DO PRINT
+6 QUIT
+7 ;
TXT1 ;Text portion
+1 ;
+2 SET J=0
SET N=1
SET LINE(N)=""
SET PSNLAST=999
+3 SET L=1
SET LINE(L)=""
SET PSNBOLD=""
SET PSNORM=""
+4 ;
+5 ;Last subscripT
SET PSNLAST=$ORDER(^PS(PSNFILE2,+PSNENG,PSNALPHA,PSNLAST),-1)
+6 ;
+7 FOR
SET J=$ORDER(^PS(PSNFILE2,+PSNENG,PSNALPHA,J))
if 'J
QUIT
DO ONELN^PSNPPIP1
Begin DoDot:1
+8 SET LINE=^PS(PSNFILE2,+PSNENG,PSNALPHA,J,0)
+9 IF J=PSNLAST
Begin DoDot:2
+10 ;Last lines
IF (N-1)'=0
SET LINE(L)=LINE(N-1)_" "_LINE
+11 ;S LINE(M)=$E(LINE(L),1,IOM) D
IF $LENGTH(LINE(L))>IOM
Begin DoDot:3
+12 FOR I=IOM:-1:1
IF $EXTRACT(LINE(L),I)[" "
Begin DoDot:4
+13 SET ^TMP($JOB,"W",CNTO)=$EXTRACT(LINE(L),1,I)
SET CNTO=CNTO+1
+14 SET ^TMP($JOB,"W",CNTO)=$EXTRACT(LINE(L),I+1,999)
+15 SET CNTO=CNTO+1
End DoDot:4
QUIT
End DoDot:3
+16 IF $LENGTH(LINE(L))'>IOM
Begin DoDot:3
+17 SET ^TMP($JOB,"W",CNTO)=LINE(L)
SET CNTO=CNTO+1
End DoDot:3
End DoDot:2
QUIT
+18 ;Middle lines
IF N>1
SET LINE(N-1)=LINE(N-1)_" "_$EXTRACT(LINE,1,A)
Begin DoDot:2
+19 IF $LENGTH(LINE(N-1))<IOM
SET A=IOM-$LENGTH(LINE(N-1))
QUIT
+20 DO BRK
+21 SET N=N+1
SET CNTO=CNTO+1
End DoDot:2
+22 IF N=1
SET LINE(N)=LINE(N)_" "_LINE
SET P=LINE(N)
Begin DoDot:2
+23 FOR I=1:1:$LENGTH(P)
IF $EXTRACT(P,I)=":"
Begin DoDot:3
+24 ;BOLD Section header
SET PSNBOLD=$GET(IOINHI)_$EXTRACT(P,1,I-1)
SET PSNORM=$GET(IOINORM)_$EXTRACT(P,I,999)
End DoDot:3
+25 SET LINE(N)=PSNBOLD_PSNORM
+26 ;Remove lead space
IF $EXTRACT(LINE(N),1)[" "
SET LINE(N)=$EXTRACT(LINE(N),2,999)
+27 SET LENGTH=$LENGTH(LINE(N))
SET A=IOM-LENGTH
+28 SET N=N+1
End DoDot:2
End DoDot:1
+29 ;
+30 ;Insert blank line
if $DATA(^PS(PSNFILE2,+PSNENG,PSNALPHA))
SET ^TMP($JOB,"W",CNTO)=PSNSP
if $DATA(^PS(PSNFILE2,+PSNENG,PSNALPHA))
SET CNTO=CNTO+1
+31 QUIT
+32 ;
BRK ;Break line between words rather than within a word
+1 ;
+2 FOR I=IOM:-1:1
IF $EXTRACT(LINE(N-1),I)[" "
Begin DoDot:1
+3 SET ^TMP($JOB,"W",CNTO)=$EXTRACT(LINE(N-1),1,I)
+4 SET LINE(N)=$EXTRACT(LINE(N-1),I+1,999)_$EXTRACT(LINE,A+1,999)
+5 ;Remove lead space
IF $EXTRACT(LINE(N),1)[" "
SET LINE(N)=$EXTRACT(LINE(N),2,999)
+6 SET LENGTH=$LENGTH(LINE(N))
SET A=IOM-LENGTH
End DoDot:1
QUIT
+7 ;
+8 QUIT
+9 ;
PRINT ;
+1 SET QUIT=0
FOR J=1:1:NUM
if QUIT
QUIT
SET PG=1
DO HEAD
if QUIT
QUIT
FOR K=1:1
if '$DATA(^TMP($JOB,"W",K))
QUIT
WRITE ^(K),!
IF $Y+4>IOSL
DO HEAD
if QUIT
QUIT
+2 QUIT
HEAD ;
+1 IF PG>1
IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET QUIT=1
QUIT
+2 if $Y
WRITE @IOF
WRITE !!,?70,$SELECT(PSNTYPE<4:"Page ",1:"P"_$CHAR(160)_"gina "),PG,!,LIN0,$SELECT(PSNTYPE<4:"Medication instructions for ",1:"Informaci"_$CHAR(162)_"n sobre su medicin a "),DRUG
SET PG=PG+1
+3 IF $DATA(NAM)
WRITE !!,?2,"Printed for: ",NAM,?60,$$HTE^XLFDT(+$HOROLOG),!,?2,"Rx Number: "_$GET(PSRX)
+4 WRITE !!!
QUIT
+5 ;
+6 ;
DICS ;set DIC("S") to screen out inactives and entries in file 50
+1 ;that are not linked through NDF to a PMI sheet
+2 NEW QQQ
SET QQQ=$GET(^PSDRUG(+Y,"ND"))
SET QQQ=$PIECE($GET(^PSNDF(50.68,+$PIECE(QQQ,"^",3),1)),"^",5)
IF QQQ
IF $DATA(PSNGCN)
IF $SELECT('$GET(^PSDRUG(+Y,"I")):1,DT'>^("I"):1,1:0)
+3 SET QQQ=$GET(^PSDRUG(+Y,0))
+4 ;reset naked indicator
+5 QUIT
ENOP(PSNDRUG,PSNTRADE,PSRX,PSNDFN) ;
+1 ;
+2 ; entry point from Outpatient Pharmacy
+3 ; PSNDRUG = IFN from the DRUG file (50) ** REQUIRED **
+4 ; PSRX = IFN from the PRESCRIPTION file (52) ** OPTIONAL **
+5 ; PSNTRADE = Trade Name in printable format ** OPTIONAL **
+6 ; PSNDFN = Patient's DFN ** OPTIONAL **
+7 ;
+8 ; This entry point returns the variable PSNFLAG, it will
+9 ; be equal to 1 if the information sheet can be printed or
+10 ; it will be equal to 0 if an information sheet cannot be
+11 ; printed. If PSNFLAG=0, the variable PSNPPI("MESSAGE") will
+12 ; be returned containing a message stating why an information
+13 ; sheet could not be printed.
+14 ;
+15 KILL DRG,PSNPN
+16 SET PSNFLAG=1
SET DRG=PSNDRUG
SET PSNDF=$GET(^PSDRUG(PSNDRUG,"ND"))
+17 SET PSNPN=$PIECE(PSNDF,"^",3)
SET PSNDF=+PSNDF
+18 IF 'PSNDF
SET PSNPPI("MESSAGE")="This drug is not matched to the National Drug File; therefore, a Medication Information Sheet cannot be printed."
SET PSNFLAG=0
KILL PSNDF,DRG,PSNPN
QUIT
LANGE SET DEFLANG=$PIECE($GET(^PS(59.7,1,10)),"^",7)
IF DEFLANG]""
SET PSNLANG=$SELECT(DEFLANG=1:"English",1:"Spanish")
if PSNLANG="English"
SET PSNTYPE=2
if PSNLANG="Spanish"
SET PSNTYPE=5
+1 SET PSNGCN=$PIECE($GET(^PSNDF(50.68,PSNPN,1)),"^",5)
+2 ;
+3 IF 'PSNGCN
SET PSNPPI("MESSAGE")="This drug is not linked to a Medication Information Sheet."
SET PSNFLAG=0
KILL PSNGCN,DRG,PSNDF,PSNPN
QUIT
+4 IF PSNFLAG
SET DRG(DRG)=PSNGCN
DO EN1
+5 KILL PSNDRUG,PSNTRADE,PSNDF,PSNPN,PSNGCN,DRG
+6 ;
+7 QUIT
DEFLT SET DEFLANG=$PIECE($GET(^PS(59.7,1,10)),"^",7)
IF DEFLANG]""
SET PSNLANG=$SELECT(DEFLANG=1:"English",1:"Spanish")
+1 NEW A1
SET A1=$$GET1^DIQ(55,$GET(PSNDFN)_",",106.1,"I")
SET DEFLANG=$SELECT(A1=2:"Spanish",A1=1:"English",1:DEFLANG)
+2 SET DEFPRTR=$PIECE($GET(^PS(59.7,1,10)),"^",6)
IF DEFPRTR]""
SET DIC="^%ZIS(1,"
SET DA=DEFPRTR
SET DR=".01"
SET DIQ="PSNDEV"
SET DIQ(0)="E"
DO EN^DIQ1
SET PSNPRTR=$GET(PSNDEV(3.5,DA,.01,DIQ(0)))
+3 QUIT
