- 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 Jan 18, 2025@03:25:36 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