PSOUTLA2 ;BHAM ISC/GSN-Pharmacy utility program cont. ;6/6/05 12:19pm
;;7.0;OUTPATIENT PHARMACY;**210,410,507,694,753**;DEC 1997;Build 53
Q
;
WORDWRAP(STR,IEN,GL,LM) ;Wraps words at spaces normally and will breakup long
; words at a delimiter & wrap at those break points
; Input: STR - a text string
; IEN - ien of global
; GL - global root
; LM - left margin
; Output: Populated global (usually in ^TMP)
;
; When a long word is encountered, i.e. text with no spaces, an
; attempt will be made to locate a delimiter & break the line there.
; If it can't find a valid delimiter without a restricted scenario,
; i.e. a number like 1,000 , then it will be forced to break at the
; End of Line (EOL).
;
; Delimiters searched for and order they are picked for use:
; preferred: , ;
; alternate: : =
; do not use: - . ) ( / (to critical, used in dosing)
; example: "TAKE 1/2-1 TAB(7.5MG) TABLET(S)"
;
; Key Variables: WORD - current word from text string
; WORD1 - 1st part of word that will fit
; WORD2 - 2nd part of word for new line
; WORD0 - remnant that won't fit on the new line
;
N QQ,DL,DLM,WD,LL,TL,UL,MAXLN,LSTD,CURD,GWRD,LC,WORD0,WORD,WORD1,WORD2
S IEN=+$G(IEN),@GL@(IEN,0)=$G(@GL@(IEN,0)),WORD0=""
;loop thru words, quit if no more words & no remnants - i.e. WORD0
F QQ=1:1 S WORD=$P(STR," ",QQ) D Q:(QQ'<$L(STR," "))&(WORD0="")
. ;if remnant exists, prepend to next Word
. S:WORD0]"" WORD=WORD0_WORD,WORD0=""
. ;wrap short words at spaces, check if last char is already a space
. S GWRD=@GL@(IEN,0)
. S LC=$E(@GL@(IEN,0),$L(GWRD))
. I LC=" ",$L(GWRD_WORD)<81 S @GL@(IEN,0)=@GL@(IEN,0)_WORD Q
. I LC'=" ",$L(GWRD_" "_WORD)<81 S @GL@(IEN,0)=@GL@(IEN,0)_" "_WORD Q
. I $L(WORD)<20,$L(LM+1+$L(WORD))<81 D Q
. . S WORD1="",WORD2=WORD,DLM="" D ADDWORDS S WORD0=WORD2 Q
. ;
. ;word>80, so wrap long words @ a specific delimiter, if found
. S MAXLN=79-$L(@GL@(IEN,0))
. ;search backwards & pick 1st dl > 1 count of preferred delims
. F DL=";","," S DL($L(WORD,DL))=DL
. S DL=$O(DL(DL),-1) S DLM=$S(DL>1:DL(DL),1:"")
. I DLM="" F DL="=",":" S DL($L(WORD,DL))=DL D ;try these alt delims
. . S DL=$O(DL(DL),-1) S DLM=$S(DL>1:DL(DL),1:"")
. ;
. ;no good delimiter, will have to break at end of line
. I DLM="" D Q
. . S WORD1=$E(WORD,1,MAXLN),WORD2=$E(WORD,MAXLN+1,$L(WORD))
. . D ADDWORDS S WORD0=WORD2
. ;
. ;good delimiter, will break at last dlm that fits within maxln
. S (LSTD,LL)=0,CURD=1 F TL=0:0 S CURD=$F(WORD,DLM,CURD) Q:'CURD D
. . S TL=TL+1
. . S WD(TL)=CURD_"^"_$E(WORD,CURD-2,CURD)
. . S:CURD'>MAXLN LSTD=CURD,LL=TL
. ;special check of "," embedded in a number e.g. 1,000
. ;backup to previous delimiter if pattern match
. I DLM="," F UL=LL:-1:0 Q:$P($G(WD(UL)),"^",2)'?1N1","1N
. I DLM=",",+$G(WD(UL))<LSTD S LSTD=+$G(WD(UL))
. ;
. ;*410
. ;if WORD is longer than 60 characters and a valid delimiter is
. ;found after character position 57 (58 or later), ignore the
. ;delimiter and break at end of line since entire word will not
. ;fit on one line
. N WORDLN S WORDLN=$L(WORD) I DLM]"",DLM'="," S WORDLN=$F(WORD,DLM,1)-1
. S WORD1=$E(WORD,1,WORDLN),WORD2=$E(WORD,WORDLN+1,$L(WORD))
. I (LM+1+$L(WORD1))>80 S WORD1=$E(WORD,1,MAXLN),WORD2=$E(WORD,MAXLN+1,$L(WORD))
. I DLM]"",($F(WORD,DLM,1)-1)>57,$L(WORD)'<60 D Q
. . D ADDWORDS S WORD0=WORD2
. ;
. ;'LSTD usually means no valid Dlm's found in Word, but if line
. ;found to have some valid Dlm's later in the Word, then go ahead
. ;defer entire string to next line via Addwords Api
. I 'LSTD,TL>LL,$P($G(WD(TL)),"^",2)'?1N1","1N D Q
. . D ADDWORDS S WORD0=WORD2
. ;
. ;no valid Dlm's found in word, can't determine a word, break @EOL
. I 'LSTD,$L(WORD)>(MAXLN) D Q
. . S WORD1=$E(WORD,1,MAXLN),WORD2=$E(WORD,MAXLN+1,$L(WORD))
. . D ADDWORDS S WORD0=WORD2
. ;no valid Dlm's found in word, and can add Word to curr line
. I 'LSTD,$L(WORD)'>(MAXLN) S @GL@(IEN,0)=@GL@(IEN,0)_WORD Q
. ;
. ;valid Dlm's & location found indicated by SS
. I LSTD D Q
. . S WORD1=$E(WORD,1,LSTD-1),WORD2=$E(WORD,LSTD,$L(WORD))
. . D ADDWORDS S WORD0=WORD2
Q
;
ADDWORDS ;Add words to curr line and to a new line
N CH
;if last character is the DLM or a " ", then don't add a space when
;adding Word1 to current line
S CH=$E(@GL@(IEN,0),$L(@GL@(IEN,0)))
I (CH=DLM)!(CH=" ") D
. S @GL@(IEN,0)=@GL@(IEN,0)_WORD1
E D
. S @GL@(IEN,0)=@GL@(IEN,0)_" "_WORD1
;create new line to hold Word2
S IEN=IEN+1,$P(@GL@(IEN,0)," ",LM+1)=" "
S MAXLN=79-$L(@GL@(IEN,0))
;word2 won't fit, quit for further wrapping
Q:$L(WORD2)>(80-LM)
;word2 will fit add it
S @GL@(IEN,0)=@GL@(IEN,0)_WORD2,WORD2=""
Q
;
DMACTN ;Entry point for DM hidden action from backdoor OE *507
D FULL^VALM1
N IFN S IFN=+$G(PSODRUG("IEN")) D SHOWDR
S VALMBCK="R"
Q
;
PICKDR ;Entry point for Selecting a diff Drug
N IFN,Y
W ! K DIC S DIC="^PSDRUG(",DIC(0)="AEQMVTN",DIC("T")="" W "Return to continue or" D ^DIC K DIC I Y<0 Q
S IFN=+Y
;
SHOWDR ;Entry point to Display Drug hidden action info (defaulted IFN via DM actn)
N DIR,OIPTR
I 'IFN W !!,"** NO Dispense Drug entered for this order",! G PICKDR
W #,!,"DRUG NAME: ",$$GET1^DIQ(50,IFN_",","GENERIC NAME")," (IEN: "_IFN_")"
S OIPTR=^PSDRUG(IFN,2) S:$P(OIPTR,"^",1)]"" OIPTR=$P(OIPTR,"^",1)
I OIPTR]"" W !," ORDERABLE ITEM TEXT: ",! D DMOITXT
W !," MESSAGE: ",$$GET1^DIQ(50,IFN_",","MESSAGE") D FULL
W !," QTY DISP MESSAGE: ",$$GET1^DIQ(50,IFN_",","QUANTITY DISPENSE MESSAGE"),! D FULL
K Y
G PICKDR
;
DMOITXT ;Get Pharmacy Orderable Item drug text fields
N DDD,QUIT,TXT,TEXT,TEXTPTR
I $D(^PS(50.7,OIPTR,1,0)) F TXT=0:0 S TXT=$O(^PS(50.7,OIPTR,1,TXT)) Q:'TXT D
. S TEXTPTR=^PS(50.7,OIPTR,1,TXT,0)
. F DDD=0:0 S DDD=$O(^PS(51.7,TEXTPTR,2,DDD)) Q:'DDD I '$$INACDATE S TEXT=^PS(51.7,TEXTPTR,2,DDD,0) D FULL Q:$G(QUIT) W " ",TEXT,!
Q
;
FULL ;Screen is full, pause
D:($Y+3)>IOSL&('$G(QUIT)) FSCRN
Q
;
FSCRN ;User Wait as screen if full
Q:$G(QUIT) K DIR S DIR(0)="E",DIR("A")="Press Return to continue,'^' to exit" D ^DIR W @IOF S:Y'=1 QUIT=1
Q
;
INACDATE() ;Check Inactive date
Q $P($G(^PS(51.7,TEXTPTR,0)),"^",2)
;
VPACTN ;Entry point for VP hidden action from backdoor OE *507
D FULL^VALM1
N IFN
S IFN=+$G(PSONEW("PROVIDER")) D SHOWVP
S VALMBCK="R"
Q
;
PICKVP ;Entry Point For Selecting a diff provider
N IFN,Y
W ! K DIC S DIC="^VA(200,",DIC(0)="AEQMVTN",DIC("T")="" W !,"Return to continue or" D ^DIC K DIC I Y<0 Q
S IFN=+Y
;
SHOWVP ;Entry point to Display Provider hidden action info (via defaulted IFN)
N DIR
I 'IFN W !,"No provider entered for this order",! G PICKVP
W #,"PROVIDER TITLE: ",$$GET1^DIQ(200,IFN_",","TITLE")
W !!,"PROVIDER REMARKS: ",$$GET1^DIQ(200,IFN_",","REMARKS")
W !!,"PROVIDER SPECIALTY: ",$$GET1^DIQ(200,IFN_",","PROVIDER CLASS"),!," "_$$GET1^DIQ(200,IFN_",","SERVICE/SECTION")
K Y
G PICKVP
Q
;
SUSPDAYS(IEN) ; Return correct suspense days parameter value per Rx IEN in Suspense file *694
; IEN = Internal entry number for the RX SUSPENSE file
N RTN,PIEN,MAIL,LOCTST,CS,LCSV,LNCSV,CCSV,CNCSV,RXIENSD
S RTN=""
S PIEN=$$GET1^DIQ(52.5,IEN,.03,"I"),MAIL=$$GET1^DIQ(55,PIEN,.03,"I")
;
S RXIENSD=$$GET1^DIQ(52.5,IEN,.01,"I") ;p753
I $$GET1^DIQ(52,RXIENSD,100.2,"I")]"" S MAIL=$$GET1^DIQ(52,RXIENSD,100.2,"I") ;p753
;
S LOCTST=$S(MAIL<2&'$$CKCMOP(IEN):"LOCAL",MAIL>2:"LOCAL",1:"")
S CS=$$CHKCS(IEN)
;pull ahead Days params for - Local CS, Local Non=CS, CMOP CS, CMOP Non-CS
S LCSV=$P(PSOPAR,U,34),LNCSV=$P(PSOPAR,U,27),CCSV=$P(PSOPAR,U,9),CNCSV=$P(PSOPAR,U,35)
S RTN=$S(LOCTST="LOCAL"&(CS):LCSV,LOCTST="LOCAL"&('CS):LNCSV,$$CKCMOP(IEN)&(CS):CCSV,$$CKCMOP(IEN)&('CS):CNCSV,1:0)
Q RTN
;
CKCMOP(IEN) ; See if CMOP dispenable by Rx drug setting *694
; IEN = Internal entry number for the RX SUSPENSE file
N RXIEN,DGIEN,RTN
S RXIEN=$$GET1^DIQ(52.5,IEN,.01,"I")
S DGIEN=$$GET1^DIQ(52,RXIEN,6,"I")
S RTN=+$$GET1^DIQ(50,DGIEN,213,"I")
Q RTN
;
CHKCS(IEN) ; See if Rx drug is contolled substance (CS) *694
; IEN = Internal entry number for the RX SUSPENSE file
N RXIEN,DGIEN,DEA,RTN
S RXIEN=$$GET1^DIQ(52.5,IEN,.01,"I")
S DGIEN=$$GET1^DIQ(52,RXIEN,6,"I")
S DEA=$$GET1^DIQ(50,DGIEN,3)
S RTN=$S((DEA>1)&(DEA<6):1,1:0)
Q RTN
;
HLPTXT33 ;HELP TEXT FOR FIELD 3.3 FILE #59
N PSOHLP
S PSOHLP(1)="This parameter defines the number of days to pull ahead (bundle) for"
S PSOHLP(2)="prescriptions suspended for local dispensing of controlled substances."
S PSOHLP(3)="Enter the value in days between 0 and 15."
D EN^DDIOL(.PSOHLP)
Q
;
HLPTXT3 ;HELP TEXT FOR FIELD 3 FILE #59
N PSOHLP
S PSOHLP(1)="This parameter defines the number of days to pull ahead (bundle) for"
S PSOHLP(2)="prescriptions suspended for local dispensing of non-controlled substances."
S PSOHLP(3)="Enter the value in days between 0 and 15."
D EN^DDIOL(.PSOHLP)
Q
;
HLPTXT31 ;HELP TEXT FOR FIELD 3.1 FILE #59
N PSOHLP
S PSOHLP(1)="This parameter defines the number of days to pull ahead (bundle) in"
S PSOHLP(2)="addition to the CS DAYS TO TRANSMIT parameter for controlled substance"
S PSOHLP(3)="prescriptions suspended for CMOP mail. Enter the value in days between 0"
S PSOHLP(4)="and 15."
D EN^DDIOL(.PSOHLP)
Q
;
HLPTXT34 ;HELP TEXT FOR FIELD 3.4 FILE #59
N PSOHLP
S PSOHLP(1)="This parameter defines the number of days to pull ahead (bundle) in"
S PSOHLP(2)="addition to the NON-CS DAYS TO TRANSMIT parameter for non-controlled"
S PSOHLP(3)="substance prescriptions suspended for CMOP mail. Enter the value in days"
S PSOHLP(4)="between 0 and 15."
D EN^DDIOL(.PSOHLP)
Q
;
MAILEX ;entry for speed mail exemption selection
;called from the protocol Mail Exemption for Prescription [PSO LM MAIL EXEMPTION]
;
D FULL^VALM1
D MAILDISP ;display prescriptions with indicator
;
K PSOIEN,VALMCNT,ORD,ORN,LST
I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="R" Q
W !
K DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR S LST=Y
I $D(DTOUT)!($D(DUOUT)) D ^PSOBUILD,BLD^PSOORUT1 K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="R" Q
K DIR,DIRUT,DTOUT I '+LST D ^PSOBUILD,BLD^PSOORUT1 S VALMBCK="" Q
K Y,MAILEX,FDA,MSG,PSOMAIL
D FULL^VALM1
K DIR S DIR(0)="SO^0:REGULAR MAIL;1:CERTIFIED MAIL;2:DO NOT MAIL;3:LOCAL - REGULAR MAIL;4:LOCAL - CERTIFIED MAIL;@:DELETE"
S DIR("A")="Select Mail Exemption"
S DIR("L",1)="For Pharmacy Order Mail Exemptions enter: "
S DIR("L",2)="0 for REGULAR MAIL"
S DIR("L",3)="1 for CERTIFIED MAIL"
S DIR("L",4)="2 for DO NOT MAIL"
S DIR("L",5)="3 for LOCAL - REGULAR"
S DIR("L",6)="4 for LOCAL - CERTIFIED"
S DIR("L",7)="@ for DELETE EXEMPTION VALUE"
S DIR("L")="^ or Enter for Exit"
D ^DIR K DIR
I (Y="")!("01234"'[Y)&(X'="@") S VALMBCK="R" Q
I X="@" S MAILEX="@"
I X'="@" S MAILEX=Y
; order selection
D FULL^VALM1
F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']"" D
.S ORN=$P(LST,",",ORD),PSOIEN=$P(PSOLST(ORN),"^",2)
.S PSOMAILF=$$GET1^DIQ(52,PSOIEN,100.2)
.S FDA(52,PSOIEN_",",100.2)=MAILEX D FILE^DIE(,"FDA","MSG")
.S PSOMAIL=$$GET1^DIQ(52,PSOIEN,100.2)
.I PSOMAILF']"" D RXACT^PSOBPSU2(PSOIEN,,"Mail Exemption changed to "_PSOMAIL_".","E") Q
.I PSOMAIL]"" D RXACT^PSOBPSU2(PSOIEN,,"Mail Exemption changed from "_PSOMAILF_" to "_PSOMAIL_".","E") Q
.I PSOMAIL']"" D RXACT^PSOBPSU2(PSOIEN,,"Mail Exemption "_PSOMAILF_" deleted.","E") Q
.S VALMBCK="R"
K PSOIEN,VALMCNT,PSOIEN,ORD,ORN,LST
K Y,MAILEX,FDA,MSG,PSOMAIL,PSOMAILF
G MAILEX
Q
;
MAILDISP ;display prescriptions with indicators
N RXIEN,STA,DRUG,X1,X2,PSODTCUT,X,Y,LINE,POS,ORNUM,ECME,TITRX,DRUGIEN,MAILD
S X2=-120,X1=DT D C^%DTC S PSODTCUT=X ;date cutoff for prescriptions
D ^PSOBUILD ;build psosd array
I $G(PSOSD)=0 W !,"<No local prescriptions found.>" Q
S MAILD=+$P($G(^PS(55,PSODFN,0)),"^",3) D
.W !!,"Prescription Mail Delivery (patient level): "_$S(MAILD=1:"Certified Mail",MAILD=2:"DO NOT MAIL",MAILD=3:"Local - Regular Mail",MAILD=4:"Local - Certified Mail",1:"Regular Mail"),!
W !," # RX # DRUG MAIL EXEMPTION"
S PSOCNT=0
S STA="" F S STA=$O(PSOSD(STA)) Q:STA="" I "^PENDING^ZNONVA^"'[STA D
.S POS=80-$L(STA)/2,LINE="",$P(LINE,"-",81)="",$E(LINE,POS+1,POS+$L(STA))=STA W !,$E(LINE,1,80)
.S DRUG="" F S DRUG=$O(PSOSD(STA,DRUG)) Q:DRUG="" D
..S PSOCNT=PSOCNT+1
..S RXIEN=+PSOSD(STA,DRUG)
..I RXIEN=0 Q ;no prescription
..S MAILEX=$$GET1^DIQ(52,RXIEN,100.2,"E")
..S MAILEXI=$$GET1^DIQ(52,RXIEN,100.2,"I")
..S ECME=$$ECME^PSOBPSUT(+RXIEN)
..S TITRX=$$TITRX^PSOUTL(+RXIEN)
..S ORNUM=$$GET1^DIQ(52,+RXIEN,39.3,"I")
..I ORNUM S ERXIEN=$$CHKERX^PSOERXU1(ORNUM)
..W !,$J(PSOCNT,2)_$S($L(PSOCNT)<3:" ",1:"")_$S($G(ERXIEN):"& ",1:"")_$P(^PSRX(+RXIEN,0),"^")
..W $S($G(^PSRX(+RXIEN,"IB")):"$",1:"")_ECME_TITRX_$S(MAILEX]"":"x",1:""),?17,DRUG
..I MAILEXI]"" W ?59,MAILEXI,"-",MAILEX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOUTLA2 13295 printed Oct 16, 2024@18:36:46 Page 2
PSOUTLA2 ;BHAM ISC/GSN-Pharmacy utility program cont. ;6/6/05 12:19pm
+1 ;;7.0;OUTPATIENT PHARMACY;**210,410,507,694,753**;DEC 1997;Build 53
+2 QUIT
+3 ;
WORDWRAP(STR,IEN,GL,LM) ;Wraps words at spaces normally and will breakup long
+1 ; words at a delimiter & wrap at those break points
+2 ; Input: STR - a text string
+3 ; IEN - ien of global
+4 ; GL - global root
+5 ; LM - left margin
+6 ; Output: Populated global (usually in ^TMP)
+7 ;
+8 ; When a long word is encountered, i.e. text with no spaces, an
+9 ; attempt will be made to locate a delimiter & break the line there.
+10 ; If it can't find a valid delimiter without a restricted scenario,
+11 ; i.e. a number like 1,000 , then it will be forced to break at the
+12 ; End of Line (EOL).
+13 ;
+14 ; Delimiters searched for and order they are picked for use:
+15 ; preferred: , ;
+16 ; alternate: : =
+17 ; do not use: - . ) ( / (to critical, used in dosing)
+18 ; example: "TAKE 1/2-1 TAB(7.5MG) TABLET(S)"
+19 ;
+20 ; Key Variables: WORD - current word from text string
+21 ; WORD1 - 1st part of word that will fit
+22 ; WORD2 - 2nd part of word for new line
+23 ; WORD0 - remnant that won't fit on the new line
+24 ;
+25 NEW QQ,DL,DLM,WD,LL,TL,UL,MAXLN,LSTD,CURD,GWRD,LC,WORD0,WORD,WORD1,WORD2
+26 SET IEN=+$GET(IEN)
SET @GL@(IEN,0)=$GET(@GL@(IEN,0))
SET WORD0=""
+27 ;loop thru words, quit if no more words & no remnants - i.e. WORD0
+28 FOR QQ=1:1
SET WORD=$PIECE(STR," ",QQ)
Begin DoDot:1
+29 ;if remnant exists, prepend to next Word
+30 if WORD0]""
SET WORD=WORD0_WORD
SET WORD0=""
+31 ;wrap short words at spaces, check if last char is already a space
+32 SET GWRD=@GL@(IEN,0)
+33 SET LC=$EXTRACT(@GL@(IEN,0),$LENGTH(GWRD))
+34 IF LC=" "
IF $LENGTH(GWRD_WORD)<81
SET @GL@(IEN,0)=@GL@(IEN,0)_WORD
QUIT
+35 IF LC'=" "
IF $LENGTH(GWRD_" "_WORD)<81
SET @GL@(IEN,0)=@GL@(IEN,0)_" "_WORD
QUIT
+36 IF $LENGTH(WORD)<20
IF $LENGTH(LM+1+$LENGTH(WORD))<81
Begin DoDot:2
+37 SET WORD1=""
SET WORD2=WORD
SET DLM=""
DO ADDWORDS
SET WORD0=WORD2
QUIT
End DoDot:2
QUIT
+38 ;
+39 ;word>80, so wrap long words @ a specific delimiter, if found
+40 SET MAXLN=79-$LENGTH(@GL@(IEN,0))
+41 ;search backwards & pick 1st dl > 1 count of preferred delims
+42 FOR DL=";",","
SET DL($LENGTH(WORD,DL))=DL
+43 SET DL=$ORDER(DL(DL),-1)
SET DLM=$SELECT(DL>1:DL(DL),1:"")
+44 ;try these alt delims
IF DLM=""
FOR DL="=",":"
SET DL($LENGTH(WORD,DL))=DL
Begin DoDot:2
+45 SET DL=$ORDER(DL(DL),-1)
SET DLM=$SELECT(DL>1:DL(DL),1:"")
End DoDot:2
+46 ;
+47 ;no good delimiter, will have to break at end of line
+48 IF DLM=""
Begin DoDot:2
+49 SET WORD1=$EXTRACT(WORD,1,MAXLN)
SET WORD2=$EXTRACT(WORD,MAXLN+1,$LENGTH(WORD))
+50 DO ADDWORDS
SET WORD0=WORD2
End DoDot:2
QUIT
+51 ;
+52 ;good delimiter, will break at last dlm that fits within maxln
+53 SET (LSTD,LL)=0
SET CURD=1
FOR TL=0:0
SET CURD=$FIND(WORD,DLM,CURD)
if 'CURD
QUIT
Begin DoDot:2
+54 SET TL=TL+1
+55 SET WD(TL)=CURD_"^"_$EXTRACT(WORD,CURD-2,CURD)
+56 if CURD'>MAXLN
SET LSTD=CURD
SET LL=TL
End DoDot:2
+57 ;special check of "," embedded in a number e.g. 1,000
+58 ;backup to previous delimiter if pattern match
+59 IF DLM=","
FOR UL=LL:-1:0
if $PIECE($GET(WD(UL)),"^",2)'?1N1","1N
QUIT
+60 IF DLM=","
IF +$GET(WD(UL))<LSTD
SET LSTD=+$GET(WD(UL))
+61 ;
+62 ;*410
+63 ;if WORD is longer than 60 characters and a valid delimiter is
+64 ;found after character position 57 (58 or later), ignore the
+65 ;delimiter and break at end of line since entire word will not
+66 ;fit on one line
+67 NEW WORDLN
SET WORDLN=$LENGTH(WORD)
IF DLM]""
IF DLM'=","
SET WORDLN=$FIND(WORD,DLM,1)-1
+68 SET WORD1=$EXTRACT(WORD,1,WORDLN)
SET WORD2=$EXTRACT(WORD,WORDLN+1,$LENGTH(WORD))
+69 IF (LM+1+$LENGTH(WORD1))>80
SET WORD1=$EXTRACT(WORD,1,MAXLN)
SET WORD2=$EXTRACT(WORD,MAXLN+1,$LENGTH(WORD))
+70 IF DLM]""
IF ($FIND(WORD,DLM,1)-1)>57
IF $LENGTH(WORD)'<60
Begin DoDot:2
+71 DO ADDWORDS
SET WORD0=WORD2
End DoDot:2
QUIT
+72 ;
+73 ;'LSTD usually means no valid Dlm's found in Word, but if line
+74 ;found to have some valid Dlm's later in the Word, then go ahead
+75 ;defer entire string to next line via Addwords Api
+76 IF 'LSTD
IF TL>LL
IF $PIECE($GET(WD(TL)),"^",2)'?1N1","1N
Begin DoDot:2
+77 DO ADDWORDS
SET WORD0=WORD2
End DoDot:2
QUIT
+78 ;
+79 ;no valid Dlm's found in word, can't determine a word, break @EOL
+80 IF 'LSTD
IF $LENGTH(WORD)>(MAXLN)
Begin DoDot:2
+81 SET WORD1=$EXTRACT(WORD,1,MAXLN)
SET WORD2=$EXTRACT(WORD,MAXLN+1,$LENGTH(WORD))
+82 DO ADDWORDS
SET WORD0=WORD2
End DoDot:2
QUIT
+83 ;no valid Dlm's found in word, and can add Word to curr line
+84 IF 'LSTD
IF $LENGTH(WORD)'>(MAXLN)
SET @GL@(IEN,0)=@GL@(IEN,0)_WORD
QUIT
+85 ;
+86 ;valid Dlm's & location found indicated by SS
+87 IF LSTD
Begin DoDot:2
+88 SET WORD1=$EXTRACT(WORD,1,LSTD-1)
SET WORD2=$EXTRACT(WORD,LSTD,$LENGTH(WORD))
+89 DO ADDWORDS
SET WORD0=WORD2
End DoDot:2
QUIT
End DoDot:1
if (QQ'<$LENGTH(STR," "))&(WORD0="")
QUIT
+90 QUIT
+91 ;
ADDWORDS ;Add words to curr line and to a new line
+1 NEW CH
+2 ;if last character is the DLM or a " ", then don't add a space when
+3 ;adding Word1 to current line
+4 SET CH=$EXTRACT(@GL@(IEN,0),$LENGTH(@GL@(IEN,0)))
+5 IF (CH=DLM)!(CH=" ")
Begin DoDot:1
+6 SET @GL@(IEN,0)=@GL@(IEN,0)_WORD1
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 SET @GL@(IEN,0)=@GL@(IEN,0)_" "_WORD1
End DoDot:1
+9 ;create new line to hold Word2
+10 SET IEN=IEN+1
SET $PIECE(@GL@(IEN,0)," ",LM+1)=" "
+11 SET MAXLN=79-$LENGTH(@GL@(IEN,0))
+12 ;word2 won't fit, quit for further wrapping
+13 if $LENGTH(WORD2)>(80-LM)
QUIT
+14 ;word2 will fit add it
+15 SET @GL@(IEN,0)=@GL@(IEN,0)_WORD2
SET WORD2=""
+16 QUIT
+17 ;
DMACTN ;Entry point for DM hidden action from backdoor OE *507
+1 DO FULL^VALM1
+2 NEW IFN
SET IFN=+$GET(PSODRUG("IEN"))
DO SHOWDR
+3 SET VALMBCK="R"
+4 QUIT
+5 ;
PICKDR ;Entry point for Selecting a diff Drug
+1 NEW IFN,Y
+2 WRITE !
KILL DIC
SET DIC="^PSDRUG("
SET DIC(0)="AEQMVTN"
SET DIC("T")=""
WRITE "Return to continue or"
DO ^DIC
KILL DIC
IF Y<0
QUIT
+3 SET IFN=+Y
+4 ;
SHOWDR ;Entry point to Display Drug hidden action info (defaulted IFN via DM actn)
+1 NEW DIR,OIPTR
+2 IF 'IFN
WRITE !!,"** NO Dispense Drug entered for this order",!
GOTO PICKDR
+3 WRITE #,!,"DRUG NAME: ",$$GET1^DIQ(50,IFN_",","GENERIC NAME")," (IEN: "_IFN_")"
+4 SET OIPTR=^PSDRUG(IFN,2)
if $PIECE(OIPTR,"^",1)]""
SET OIPTR=$PIECE(OIPTR,"^",1)
+5 IF OIPTR]""
WRITE !," ORDERABLE ITEM TEXT: ",!
DO DMOITXT
+6 WRITE !," MESSAGE: ",$$GET1^DIQ(50,IFN_",","MESSAGE")
DO FULL
+7 WRITE !," QTY DISP MESSAGE: ",$$GET1^DIQ(50,IFN_",","QUANTITY DISPENSE MESSAGE"),!
DO FULL
+8 KILL Y
+9 GOTO PICKDR
+10 ;
DMOITXT ;Get Pharmacy Orderable Item drug text fields
+1 NEW DDD,QUIT,TXT,TEXT,TEXTPTR
+2 IF $DATA(^PS(50.7,OIPTR,1,0))
FOR TXT=0:0
SET TXT=$ORDER(^PS(50.7,OIPTR,1,TXT))
if 'TXT
QUIT
Begin DoDot:1
+3 SET TEXTPTR=^PS(50.7,OIPTR,1,TXT,0)
+4 FOR DDD=0:0
SET DDD=$ORDER(^PS(51.7,TEXTPTR,2,DDD))
if 'DDD
QUIT
IF '$$INACDATE
SET TEXT=^PS(51.7,TEXTPTR,2,DDD,0)
DO FULL
if $GET(QUIT)
QUIT
WRITE " ",TEXT,!
End DoDot:1
+5 QUIT
+6 ;
FULL ;Screen is full, pause
+1 if ($Y+3)>IOSL&('$GET(QUIT))
DO FSCRN
+2 QUIT
+3 ;
FSCRN ;User Wait as screen if full
+1 if $GET(QUIT)
QUIT
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue,'^' to exit"
DO ^DIR
WRITE @IOF
if Y'=1
SET QUIT=1
+2 QUIT
+3 ;
INACDATE() ;Check Inactive date
+1 QUIT $PIECE($GET(^PS(51.7,TEXTPTR,0)),"^",2)
+2 ;
VPACTN ;Entry point for VP hidden action from backdoor OE *507
+1 DO FULL^VALM1
+2 NEW IFN
+3 SET IFN=+$GET(PSONEW("PROVIDER"))
DO SHOWVP
+4 SET VALMBCK="R"
+5 QUIT
+6 ;
PICKVP ;Entry Point For Selecting a diff provider
+1 NEW IFN,Y
+2 WRITE !
KILL DIC
SET DIC="^VA(200,"
SET DIC(0)="AEQMVTN"
SET DIC("T")=""
WRITE !,"Return to continue or"
DO ^DIC
KILL DIC
IF Y<0
QUIT
+3 SET IFN=+Y
+4 ;
SHOWVP ;Entry point to Display Provider hidden action info (via defaulted IFN)
+1 NEW DIR
+2 IF 'IFN
WRITE !,"No provider entered for this order",!
GOTO PICKVP
+3 WRITE #,"PROVIDER TITLE: ",$$GET1^DIQ(200,IFN_",","TITLE")
+4 WRITE !!,"PROVIDER REMARKS: ",$$GET1^DIQ(200,IFN_",","REMARKS")
+5 WRITE !!,"PROVIDER SPECIALTY: ",$$GET1^DIQ(200,IFN_",","PROVIDER CLASS"),!," "_$$GET1^DIQ(200,IFN_",","SERVICE/SECTION")
+6 KILL Y
+7 GOTO PICKVP
+8 QUIT
+9 ;
SUSPDAYS(IEN) ; Return correct suspense days parameter value per Rx IEN in Suspense file *694
+1 ; IEN = Internal entry number for the RX SUSPENSE file
+2 NEW RTN,PIEN,MAIL,LOCTST,CS,LCSV,LNCSV,CCSV,CNCSV,RXIENSD
+3 SET RTN=""
+4 SET PIEN=$$GET1^DIQ(52.5,IEN,.03,"I")
SET MAIL=$$GET1^DIQ(55,PIEN,.03,"I")
+5 ;
+6 ;p753
SET RXIENSD=$$GET1^DIQ(52.5,IEN,.01,"I")
+7 ;p753
IF $$GET1^DIQ(52,RXIENSD,100.2,"I")]""
SET MAIL=$$GET1^DIQ(52,RXIENSD,100.2,"I")
+8 ;
+9 SET LOCTST=$SELECT(MAIL<2&'$$CKCMOP(IEN):"LOCAL",MAIL>2:"LOCAL",1:"")
+10 SET CS=$$CHKCS(IEN)
+11 ;pull ahead Days params for - Local CS, Local Non=CS, CMOP CS, CMOP Non-CS
+12 SET LCSV=$PIECE(PSOPAR,U,34)
SET LNCSV=$PIECE(PSOPAR,U,27)
SET CCSV=$PIECE(PSOPAR,U,9)
SET CNCSV=$PIECE(PSOPAR,U,35)
+13 SET RTN=$SELECT(LOCTST="LOCAL"&(CS):LCSV,LOCTST="LOCAL"&('CS):LNCSV,$$CKCMOP(IEN)&(CS):CCSV,$$CKCMOP(IEN)&('CS):CNCSV,1:0)
+14 QUIT RTN
+15 ;
CKCMOP(IEN) ; See if CMOP dispenable by Rx drug setting *694
+1 ; IEN = Internal entry number for the RX SUSPENSE file
+2 NEW RXIEN,DGIEN,RTN
+3 SET RXIEN=$$GET1^DIQ(52.5,IEN,.01,"I")
+4 SET DGIEN=$$GET1^DIQ(52,RXIEN,6,"I")
+5 SET RTN=+$$GET1^DIQ(50,DGIEN,213,"I")
+6 QUIT RTN
+7 ;
CHKCS(IEN) ; See if Rx drug is contolled substance (CS) *694
+1 ; IEN = Internal entry number for the RX SUSPENSE file
+2 NEW RXIEN,DGIEN,DEA,RTN
+3 SET RXIEN=$$GET1^DIQ(52.5,IEN,.01,"I")
+4 SET DGIEN=$$GET1^DIQ(52,RXIEN,6,"I")
+5 SET DEA=$$GET1^DIQ(50,DGIEN,3)
+6 SET RTN=$SELECT((DEA>1)&(DEA<6):1,1:0)
+7 QUIT RTN
+8 ;
HLPTXT33 ;HELP TEXT FOR FIELD 3.3 FILE #59
+1 NEW PSOHLP
+2 SET PSOHLP(1)="This parameter defines the number of days to pull ahead (bundle) for"
+3 SET PSOHLP(2)="prescriptions suspended for local dispensing of controlled substances."
+4 SET PSOHLP(3)="Enter the value in days between 0 and 15."
+5 DO EN^DDIOL(.PSOHLP)
+6 QUIT
+7 ;
HLPTXT3 ;HELP TEXT FOR FIELD 3 FILE #59
+1 NEW PSOHLP
+2 SET PSOHLP(1)="This parameter defines the number of days to pull ahead (bundle) for"
+3 SET PSOHLP(2)="prescriptions suspended for local dispensing of non-controlled substances."
+4 SET PSOHLP(3)="Enter the value in days between 0 and 15."
+5 DO EN^DDIOL(.PSOHLP)
+6 QUIT
+7 ;
HLPTXT31 ;HELP TEXT FOR FIELD 3.1 FILE #59
+1 NEW PSOHLP
+2 SET PSOHLP(1)="This parameter defines the number of days to pull ahead (bundle) in"
+3 SET PSOHLP(2)="addition to the CS DAYS TO TRANSMIT parameter for controlled substance"
+4 SET PSOHLP(3)="prescriptions suspended for CMOP mail. Enter the value in days between 0"
+5 SET PSOHLP(4)="and 15."
+6 DO EN^DDIOL(.PSOHLP)
+7 QUIT
+8 ;
HLPTXT34 ;HELP TEXT FOR FIELD 3.4 FILE #59
+1 NEW PSOHLP
+2 SET PSOHLP(1)="This parameter defines the number of days to pull ahead (bundle) in"
+3 SET PSOHLP(2)="addition to the NON-CS DAYS TO TRANSMIT parameter for non-controlled"
+4 SET PSOHLP(3)="substance prescriptions suspended for CMOP mail. Enter the value in days"
+5 SET PSOHLP(4)="between 0 and 15."
+6 DO EN^DDIOL(.PSOHLP)
+7 QUIT
+8 ;
MAILEX ;entry for speed mail exemption selection
+1 ;called from the protocol Mail Exemption for Prescription [PSO LM MAIL EXEMPTION]
+2 ;
+3 DO FULL^VALM1
+4 ;display prescriptions with indicator
DO MAILDISP
+5 ;
+6 KILL PSOIEN,VALMCNT,ORD,ORN,LST
+7 IF '$GET(PSOCNT)
SET VALMSG="This patient has no Prescriptions!"
SET VALMBCK="R"
QUIT
+8 WRITE !
+9 KILL DIR,DUOUT,DIRUT
SET DIR("A")="Select Orders by number"
SET DIR(0)="LO^1:"_PSOCNT
DO ^DIR
SET LST=Y
+10 IF $DATA(DTOUT)!($DATA(DUOUT))
DO ^PSOBUILD
DO BLD^PSOORUT1
KILL DIR,DIRUT,DTOUT,DUOUT
SET VALMBCK="R"
QUIT
+11 KILL DIR,DIRUT,DTOUT
IF '+LST
DO ^PSOBUILD
DO BLD^PSOORUT1
SET VALMBCK=""
QUIT
+12 KILL Y,MAILEX,FDA,MSG,PSOMAIL
+13 DO FULL^VALM1
+14 KILL DIR
SET DIR(0)="SO^0:REGULAR MAIL;1:CERTIFIED MAIL;2:DO NOT MAIL;3:LOCAL - REGULAR MAIL;4:LOCAL - CERTIFIED MAIL;@:DELETE"
+15 SET DIR("A")="Select Mail Exemption"
+16 SET DIR("L",1)="For Pharmacy Order Mail Exemptions enter: "
+17 SET DIR("L",2)="0 for REGULAR MAIL"
+18 SET DIR("L",3)="1 for CERTIFIED MAIL"
+19 SET DIR("L",4)="2 for DO NOT MAIL"
+20 SET DIR("L",5)="3 for LOCAL - REGULAR"
+21 SET DIR("L",6)="4 for LOCAL - CERTIFIED"
+22 SET DIR("L",7)="@ for DELETE EXEMPTION VALUE"
+23 SET DIR("L")="^ or Enter for Exit"
+24 DO ^DIR
KILL DIR
+25 IF (Y="")!("01234"'[Y)&(X'="@")
SET VALMBCK="R"
QUIT
+26 IF X="@"
SET MAILEX="@"
+27 IF X'="@"
SET MAILEX=Y
+28 ; order selection
+29 DO FULL^VALM1
+30 FOR ORD=1:1:$LENGTH(LST,",")
if $PIECE(LST,",",ORD)']""
QUIT
Begin DoDot:1
+31 SET ORN=$PIECE(LST,",",ORD)
SET PSOIEN=$PIECE(PSOLST(ORN),"^",2)
+32 SET PSOMAILF=$$GET1^DIQ(52,PSOIEN,100.2)
+33 SET FDA(52,PSOIEN_",",100.2)=MAILEX
DO FILE^DIE(,"FDA","MSG")
+34 SET PSOMAIL=$$GET1^DIQ(52,PSOIEN,100.2)
+35 IF PSOMAILF']""
DO RXACT^PSOBPSU2(PSOIEN,,"Mail Exemption changed to "_PSOMAIL_".","E")
QUIT
+36 IF PSOMAIL]""
DO RXACT^PSOBPSU2(PSOIEN,,"Mail Exemption changed from "_PSOMAILF_" to "_PSOMAIL_".","E")
QUIT
+37 IF PSOMAIL']""
DO RXACT^PSOBPSU2(PSOIEN,,"Mail Exemption "_PSOMAILF_" deleted.","E")
QUIT
+38 SET VALMBCK="R"
End DoDot:1
+39 KILL PSOIEN,VALMCNT,PSOIEN,ORD,ORN,LST
+40 KILL Y,MAILEX,FDA,MSG,PSOMAIL,PSOMAILF
+41 GOTO MAILEX
+42 QUIT
+43 ;
MAILDISP ;display prescriptions with indicators
+1 NEW RXIEN,STA,DRUG,X1,X2,PSODTCUT,X,Y,LINE,POS,ORNUM,ECME,TITRX,DRUGIEN,MAILD
+2 ;date cutoff for prescriptions
SET X2=-120
SET X1=DT
DO C^%DTC
SET PSODTCUT=X
+3 ;build psosd array
DO ^PSOBUILD
+4 IF $GET(PSOSD)=0
WRITE !,"<No local prescriptions found.>"
QUIT
+5 SET MAILD=+$PIECE($GET(^PS(55,PSODFN,0)),"^",3)
Begin DoDot:1
+6 WRITE !!,"Prescription Mail Delivery (patient level): "_$SELECT(MAILD=1:"Certified Mail",MAILD=2:"DO NOT MAIL",MAILD=3:"Local - Regular Mail",MAILD=4:"Local - Certified Mail",1:"Regular Mail"),!
End DoDot:1
+7 WRITE !," # RX # DRUG MAIL EXEMPTION"
+8 SET PSOCNT=0
+9 SET STA=""
FOR
SET STA=$ORDER(PSOSD(STA))
if STA=""
QUIT
IF "^PENDING^ZNONVA^"'[STA
Begin DoDot:1
+10 SET POS=80-$LENGTH(STA)/2
SET LINE=""
SET $PIECE(LINE,"-",81)=""
SET $EXTRACT(LINE,POS+1,POS+$LENGTH(STA))=STA
WRITE !,$EXTRACT(LINE,1,80)
+11 SET DRUG=""
FOR
SET DRUG=$ORDER(PSOSD(STA,DRUG))
if DRUG=""
QUIT
Begin DoDot:2
+12 SET PSOCNT=PSOCNT+1
+13 SET RXIEN=+PSOSD(STA,DRUG)
+14 ;no prescription
IF RXIEN=0
QUIT
+15 SET MAILEX=$$GET1^DIQ(52,RXIEN,100.2,"E")
+16 SET MAILEXI=$$GET1^DIQ(52,RXIEN,100.2,"I")
+17 SET ECME=$$ECME^PSOBPSUT(+RXIEN)
+18 SET TITRX=$$TITRX^PSOUTL(+RXIEN)
+19 SET ORNUM=$$GET1^DIQ(52,+RXIEN,39.3,"I")
+20 IF ORNUM
SET ERXIEN=$$CHKERX^PSOERXU1(ORNUM)
+21 WRITE !,$JUSTIFY(PSOCNT,2)_$SELECT($LENGTH(PSOCNT)<3:" ",1:"")_$SELECT($GET(ERXIEN):"& ",1:"")_$PIECE(^PSRX(+RXIEN,0),"^")
+22 WRITE $SELECT($GET(^PSRX(+RXIEN,"IB")):"$",1:"")_ECME_TITRX_$SELECT(MAILEX]"":"x",1:""),?17,DRUG
+23 IF MAILEXI]""
WRITE ?59,MAILEXI,"-",MAILEX
End DoDot:2
End DoDot:1
+24 QUIT
