Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOUTLA2

PSOUTLA2.m

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