- 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 Jan 18, 2025@03:37:16 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