- PSODRG ;IHS/DSD/JCM - ORDER ENTRY DRUG SELECTION ;10/23/18 8:47am
- ;;7.0;OUTPATIENT PHARMACY;**20,23,36,53,54,46,112,139,207,148,243,268,324,251,375,387,398,390,427,411,458,504,517,457,574,524,747**;DEC 1997;Build 7
- ; Reference to ^PSDRUG( in ICR #221
- ; Reference to ^PS(50.7 in ICR #2223
- ; Reference to $$PROMPT^PSSDIN in ICR #3166
- ; Reference to EN^PSSDIN in ICR #3166
- ; Reference to $$GETNDC^PSSNDCUT in ICR #4707
- ; Reference to ^OROCAPI in ICR #5367
- ; Reference to $$OITM^ORX8 in ICR #5469
- ; Reference to ^VADPT in ICR #10061
- ; Reference to IN^PSSHRQ2 in ICR #5369
- ; Reference to ^XTMP("ORRDI" in ICR #5440
- ;
- ;*524 Add HAZ Handle & Haz Dispose Alert pre-order checks
- ;----------------------------------------------------------
- START ;
- S (PSONEW("DFLG"),PSONEW("FIELD"),PSODRG("QFLG"))=0 K PSORX("DFLG")
- D @($S(+$G(PSOEDIT)=1&('$D(DA)):"SELECT^PSODRGN",1:"SELECT"))
- G:$G(PSORXED("DFLG")) END ; Select Drug
- ;PATCH PSO*7*517 - Blocking action FN if issuing a controlled substance to a patient without a zipcode
- N DRGIEN S DRGIEN=$P($G(PSOY),U)
- I $$CSBLOCK^PSOORNEW(PSODFN,DRGIEN) D S DIR(0)="E" W ! D ^DIR K DIR,Y G END
- .W !,"Controlled substance prescriptions require a patient address. Please update"
- .W !,"patient address information. This action will also invalidate a digitally"
- .W !,"signed prescription and require the provider to re-enter the order."
- .S PSONEW("DFLG")=1
- ;PSO*7*517 - END
- I $G(PSORX("EDIT")),$G(PSOY),$G(PSODRUG("IEN"))=+PSOY D G:$G(PSORXED("DFLG")) END
- . N NDC D NDC(+$G(PSORXED("IRXN")),0,+PSOY,.NDC) I $G(NDC)="^" S PSORXED("DFLG")=1 Q
- . I $G(NDC)'="" S (PSODRUG("NDC"),PSORXED("FLD",27))=NDC
- ;
- I $G(PSORX("EDIT"))]"",'PSONEW("FIELD") D TRADE
- G:$G(PSONEW("DFLG"))!($G(PSODRG("QFLG")))!($G(PSORXED("DFLG"))) END
- D SET ; Set various drug information
- D NFI ; Display dispense drug/orderable item text
- D:'$G(PSOEDIT) POST I $G(PSORX("DFLG")) S PSONEW("DFLG")=1 K:'$G(PSORX("EDIT")) PSORX("DFLG") ; Do any post selection action
- END ;D EOJ
- Q
- ;------------------------------------------------------------
- ;
- SELECT ;
- K:'$G(PSORXED) CLOZPAT
- K IT,DIC,X,Y,PSODRUG("TRADE NAME"),PSODRUG("NDC"),PSODRUG("DAW"),PSODRUG("BAD") S:$G(POERR)&($P($G(OR0),"^",9)) Y=$$GET1^DIQ(50,$P(OR0,"^",9),.01)
- I $G(PSODRUG("IEN"))]"" S Y=PSODRUG("NAME"),PSONEW("OLD VAL")=PSODRUG("IEN")
- W !,"DRUG: "_$S($G(Y)]"":Y_"// ",1:"") R X:$S($D(DTIME):DTIME,1:300) I '$T S DTOUT=1
- I X="",$G(Y)]"" S:Y X=Y S:'X X=$G(PSODRUG("IEN")) S:X X="`"_X
- G:X="" SELECT
- I X?1."?" W !!,"Answer with DRUG NUMBER, or GENERIC NAME, or VA PRODUCT NAME, or",!,"NATIONAL DRUG CLASS, or SYNONYM" G SELECT
- I $G(PSORXED),X["^" S PSORXED("DFLG")=1 G SELECTX
- I X="^"!(X["^^")!($D(DTOUT)) S PSONEW("DFLG")=1 G SELECTX
- I '$G(POERR),X[U,$L(X)>1 S PSODIR("FLD")=PSONEW("FLD") D JUMP^PSODIR1 S:$G(PSODIR("FIELD")) PSONEW("FIELD")=PSODIR("FIELD") K PSODIR S PSODRG("QFLG")=1 G SELECTX
- S DIC=50,DIC(0)="EMQZVT",DIC("T")="",D="B^C^VAPN^VAC"
- S DIC("S")="I $S('$$GET1^DIQ(50,+Y,100,""I""):1,DT'>$$GET1^DIQ(50,+Y,100,""I""):1,1:0),$S($$GET1^DIQ(50,+Y,63,""I"")'[""O"":0,1:1)" ;,$D(^PSDRUG(""ASP"",+$G(^(2)),+Y))"
- D MIX^DIC1 K DIC,D
- I $D(DTOUT) S PSONEW("DFLG")=1 G SELECTX
- I $D(DUOUT) K DUOUT G SELECT
- I Y<0 G SELECT
- S:$G(PSONEW("OLD VAL"))=+Y&('$G(PSOEDIT)) PSODRG("QFLG")=1
- K PSOY S PSOY=Y,PSOY(0)=Y(0)
- I $P(PSOY(0),"^")="OTHER DRUG"!($P(PSOY(0),"^")="OUTSIDE DRUG") D TRADE
- SELECTX K X,Y,DTOUT,DUOUT,PSONEW("OLD VAL")
- Q
- ;
- NDC(RX,RFL,DRG,NDC) ; Editing NDC for Released Rx's or for Unresolved ECME Rejects
- S NDC=$S($G(NDC)'="":$G(NDC),1:$$GETNDC^PSONDCUT(RX,.RFL))
- ; Check if we should edit the NDC
- ; Needs to be released or have unresolved billable rejects (PSO*7*427)
- ;
- N PSOCONT S PSOCONT=0 ; continue flag
- D Q:'PSOCONT ; get out if NDC edit not allowed
- . I $$RXRLDT^PSOBPSUT(RX,RFL) S PSOCONT=1 Q ; Released - continue and allow edit
- . I $$FIND^PSOREJUT(RX,RFL),$$STATUS^PSOBPSUT(RX,RFL)'="" S PSOCONT=1 Q ; unreleased w/unresolved billable rejections
- . Q
- ;
- S NDC=$S($G(NDC)'="":$G(NDC),1:$$GETNDC^PSONDCUT(RX,.RFL))
- D NDCEDT^PSONDCUT(RX,.RFL,$G(DRG),$G(PSOSITE),.NDC)
- Q
- ;
- TRADE ;
- K DIR,DIC,DA,X,Y
- S DIR(0)="52,6.5" S:$G(PSOTRN)]"" DIR("B")=$G(PSOTRN) D ^DIR K DIR,DIC
- I X="@" S Y=X K DIRUT
- I $D(DIRUT) S:$D(DUOUT)!$D(DTOUT)&('$D(PSORX("EDIT"))) PSONEW("DFLG")=1 G TRADEX
- S PSODRUG("TRADE NAME")=Y
- TRADEX I $G(PSORXED("DFLG")),$D(DIRUT) S PSORXED("DFLG")=1
- K DIRUT,DTOUT,DUOUT,X,Y,DA,DR,DIE
- Q
- SET ;
- N PSOHZ S PSOHZ=0 ;init haz alert shown to user=no *524
- N STAT S PSODRUG("IEN")=+PSOY,PSODRUG("VA CLASS")=$P(PSOY(0),"^",2)
- S PSODRUG("NAME")=$P(PSOY(0),"^")
- S PSODRUG("OI")=+$$GET1^DIQ(50,+PSOY,2.1,"I"),PSODRUG("OIN")=$$GET1^DIQ(50,+PSOY,2.1)
- S PSODRUG("NDF")=$S(PSODRUG("OI"):$$GET1^DIQ(50,+PSOY,20,"I")_"A"_$$GET1^DIQ(50,+PSOY,22,"I"),1:0)
- S PSODRUG("MAXDOSE")=$P(PSOY(0),"^",4),PSODRUG("DEA")=$P(PSOY(0),"^",3)
- ; (#25) NATIONAL DRUG CLASS [6P:50.605]
- S PSODRUG("CLN")=+$$GET1^DIQ(50,+PSOY,25,"I") ; zero if field is null
- S PSODRUG("SIG")=$P(PSOY(0),"^",5)
- I $G(PSODRUG("NDC"))="" S PSODRUG("NDC")=$$GETNDC^PSSNDCUT(+PSOY,$G(PSOSITE))
- S PSODRUG("DAW")=$$GET1^DIQ(50,+PSOY,81)
- I PSODRUG("DAW")="" S PSODRUG("DAW")=0
- S PSODRUG("STKLVL")=$$GET1^DIQ(50,+PSOY,50)
- ;PSO*7*574 - Defect 1181628 Replaced code for PRICE PER DISPENSE UNIT display
- G:$G(^PSDRUG(+PSOY,660))']"" SETX
- S PSOX1=$G(^PSDRUG(+PSOY,660))
- S PSODRUG("COST")=$$GET1^DIQ(50,+PSOY,16) ; PSO*7*574 changed field to (#16) PRICE PER DISPENSE UNIT [6N]
- S PSODRUG("UNIT")=$$GET1^DIQ(50,+PSOY,14.5)
- S PSODRUG("EXPIRATION DATE")=$$GET1^DIQ(50,+PSOY,17.1,"I")
- SETX K PSOX1,PSOY
- Q
- NFI ;display restriction/guidelines
- D EN^PSSDIN(PSODRUG("OI"),PSODRUG("IEN")) S NFI=$$PROMPT^PSSDIN
- I NFI]"","ODY"[NFI D TD^PSONFI
- K NFI Q
- POST ;order checks
- ;add Hazardous to Handle/Dispose warning messages *524
- N HAZ,HAZH,HAZD,HTXT,LL S HAZ=$$HAZ^PSSUTIL(PSODRUG("IEN")),HAZH=$P(HAZ,U),HAZD=$P(HAZ,U,2)
- I ('$G(PSOHZ)!(PSODRUG("IEN")'=$G(PSOLSTDR))),(HAZH!HAZD) D
- . S PSOHZ=1,PSOLSTDR=PSODRUG("IEN")
- . D HAZWARNG^PSSUTIL(PSODRUG("IEN"),"O",HAZH,HAZD,.HTXT)
- . S $P(LL,"-",80)="-"
- . W #,$C(7),LL,!
- . W $J("***** WARNING *****",47)
- . D WRAPTEXT(HTXT,65,5) W !
- . W LL,!
- . K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to continue" D ^DIR
- N LIST S LIST="PSOPEPS"
- K PSODOSD,^TMP("PSORXDC",$J),^TMP($J,LIST),^TMP("PSODAOC",$J)
- K ZDGDG,ZTHER,IT,PSODLQT,PSODOSD
- I $D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) S ^TMP("PSODAOC",$J,"NORDI",1,0)="Remote data not available - Only local order checks processed."
- S ^TMP($J,LIST,"IN","PING")="" D IN^PSSHRQ2(LIST)
- K DIR I $P(^TMP($J,LIST,"OUT",0),"^")=-1 D
- .D DATACK^PSODDPRE
- .S ^TMP("PSODAOC",$J,"NOSYS",1,0)="No Enhanced Order Checks can be performed. Reason(s): "_$P($G(^TMP($J,LIST,"OUT",0)),"^",2)
- K ^TMP($J,LIST,"IN"),^TMP($J,LIST,"OUT","EXCEPTIONS")
- G:$G(PSORX("DFLG"))!($G(PSORXED("DFLG"))) POSTX
- K PSORX("INTERVENE"),PSOQUIT N STAT,SIG,PTR,NDF,VAP S PSORX("DFLG")=0
- W !! D HD^PSODDPR2():(($Y+5)'>IOSL)
- D ^PSOBUILD
- D:'$D(PSODGCK) @$S($G(COPY):"^PSOCPPRE",1:"^PSODDPRE") ; Duplicate drug check
- G:$G(PSORX("DFLG")) POSTX
- D HD^PSODDPR2():(($Y+5)'>IOSL)
- I $$GET1^DIQ(50,+$G(PSODRUG("IEN")),17.5)="PSOCLO1" D CLOZ
- G:PSORX("DFLG") POSTX
- D HD^PSODDPR2():(($Y+5)'>IOSL)
- W !,"Now doing allergy checks. Please wait...",! H 1
- S PSONOAL="" D ALLERGY^PSOORUT2 D:PSONOAL'="" NOALRGY K PSONOAL
- D HD^PSODDPR2():(($Y+5)'>IOSL)
- I '$G(PSODGCKX) D ^PSODGAL1 K PSORX("INTERVENE")
- G:PSORX("DFLG")!$G(PSOQUIT) POSTX
- ;This is the allergy check for profile drugs CK action
- I $D(PSODGCK),$D(PSOSD) D PRFLP^PSOUTL
- G:$G(PSORX("DFLG")) POSTX ;pso*7*412
- G:$G(PSOSPRNW)&($G(PSORENW("DFLG"))) POSTX ;speed renew
- ;aminoglycoside
- N AOC,CROCPFLG S CROCPFLG=0
- D HD^PSODDPR2():(($Y+5)'>IOSL)
- S AOC=$$AOC^OROCAPI(PSODFN,$P(PSODRUG("NDF"),"A",2)) I $P(AOC,"^",4)]"" D
- .S CROCPFLG=1
- .W !!,"***Aminoglycoside Ordered***",!!
- .K ^UTILITY($J,"W") S DIWL=1,DIWR=78,DIWF="" S X=$P(AOC,"^",4) D ^DIWP
- .W ! F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX W ?2,^UTILITY($J,"W",1,ZX,0),! D HD^PSODDPR2():(($Y+5)'>IOSL)
- .K ^UTILITY($J,"W")
- .S ^TMP("PSODAOC",$J,"CPRS",$P(AOC,"^",2),0)=PSODRUG("IEN")_"^"_$P(AOC,"^",4)
- .W !
- D HD^PSODDPR2():(($Y+5)'>IOSL)
- ;dangerous meds for pat >64
- I $G(PSODRUG("OI")) D
- .N OI,OIR S OI=$$OITM^ORX8(PSODRUG("OI"),"99PSP") Q:'OI
- .S OIR=$$DOC^OROCAPI(PSODFN,OI) I $P(OIR,"^",4)]"" D
- ..S CROCPFLG=1
- ..D HD^PSODDPR2():(($Y+5)'>IOSL) W !!,"***Dangerous Meds for Patient >64***",!! S DFN=PSODFN D DEM^VADPT
- ..K ^UTILITY($J,"W") S DIWL=1,DIWR=78,DIWF="" S X=$P(OIR,"^",4) D ^DIWP
- ..F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX W ?2,^UTILITY($J,"W",1,ZX,0),! D HD^PSODDPR2():(($Y+5)'>IOSL)
- ..K ^UTILITY($J,"W")
- ..S ^TMP("PSODAOC",$J,"CPRS",$P(OIR,"^",2),0)=PSODRUG("IEN")_"^"_$P(OIR,"^",4)
- ..W !
- D HD^PSODDPR2():(($Y+5)'>IOSL)
- ;metformin lab results
- N GOC S GOC=$$GOC^OROCAPI(PSODFN,PSODRUG("NAME")) I $P(GOC,"^",4)]"" D
- .S CROCPFLG=1
- .W !!,"***Metformin Lab Results***",!!
- .K ^UTILITY($J,"W") S DIWL=1,DIWR=78,DIWF="" S X=$P(GOC,"^",4) D ^DIWP
- .F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX W ?2,^UTILITY($J,"W",1,ZX,0),! D HD^PSODDPR2():(($Y+5)'>IOSL)
- .K ^UTILITY($J,"W")
- .S ^TMP("PSODAOC",$J,"CPRS",$P(GOC,"^",2),0)=PSODRUG("IEN")_"^"_$P(GOC,"^",4)
- .W !
- D HD^PSODDPR2():(($Y+5)'>IOSL)
- ;clinical reminder oc
- D:'$G(PSONCROC) CK^PSOCROC K CROCPFLG I $G(PSORX("DFLG")) Q
- K DIWF,DIWL,DIWR,ZX,DFN,CROCPFLG
- I $G(PSODRUG("DEA"))["S"!($E($G(PSODRUG("VA CLASS")),1,2)="XA"),'$G(PSODGCK) D G POSTX ;stops if drug is supply
- .W !,"Now Processing Enhanced Order Checks! Please wait...",! H 1
- ;enhanced OC
- D HD^PSODDPR2():(($Y+5)'>IOSL)
- W ! D @$S($G(COPY):"OBX^PSOCPPRE",1:"OBX^PSODDPRE") ; Set PSORX("DFLG")=1 if process to stop new enhanced order checks
- POSTX ;
- K IT,^TMP($J,"DI"),PSORX("INTERVENE"),DA,^TMP($J,"PSODRDI"),ZDGDG,ZTHER,^TMP($J,"DI"_PSODFN),PSZZQUIT
- I '$G(PSORXED),'$G(PSOREINS) K PSOQUIT
- Q
- ;
- EOJ ;
- K PSODRG
- Q
- WAIT ;
- K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to continue..." W !
- D ^DIR K DIRUT,DUOUT,DIR,X,Y
- Q
- ;
- CLOZ ;
- S ANQRTN=$$GET1^DIQ(50,+$G(PSODRUG("IEN")),17.5),ANQX=0
- S P(5)=PSODRUG("IEN"),DFN=PSODFN,X=ANQRTN
- X ^%ZOSF("TEST") I D ^PSOCLO1 S:$G(ANQX) PSORX("DFLG")=1
- K P(5),ANQRTN,ANQX,X,DFN
- Q
- ;
- EN(DRG) ;returns lab test identified for clozapine order checking
- K LAB I $$GET1^DIQ(50,+$G(DRG),17.5)'="PSOCLO1" S LAB("NOT")=0 Q
- N LABARR D LIST^DIC(50.02,","_DRG_",","2;3","I",,,,,,,"LABARR")
- I +LABARR("DILIST",0)'=2 S LAB("BAD TEST")=0 K CNT Q
- K CNT F I=1:1 Q:'$D(LABARR("DILIST",2,I)) D
- .S LABT=$S(LABARR("DILIST","ID",I,3)=1:"WBC",1:"ANC")
- .S LAB(LABT)=LABARR("DILIST",1,I)_"^"_LABARR("DILIST","ID",I,2)_"^"_LABARR("DILIST","ID",I,3)
- K LABT,I
- Q
- NOALRGY ;
- D HD^PSODDPR2():(($Y+5)'>IOSL)
- N DIR S DIR(0)="SA^1:YES;0:NO"
- I $D(^TMP($J,"PSOINTERVENE",+PSODFN)) D Q
- .S DIR("A")="No Allergy Assessment - Do you want to duplicate Intervention?: ",DIR("B")="Yes"
- .D ^DIR
- .I 'Y D Q
- ..I Y=0 D ^PSORXI Q
- ..S PSORX("DFLG")=1
- .D DUPINV^PSORXI
- W $C(7),!,"There is no allergy assessment on file for this patient."
- W !,"You will be prompted to intervene if you continue with this prescription"
- I $D(PSODGCK) W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue..." D ^DIR K DIR
- Q:$D(PSODGCK)
- N DUOUT,DTOUT,RXIEN,RXSTA ;*398
- S DIR("A")="Do you want to Continue?: ",DIR("B")="N" D ^DIR
- I 'Y!($D(DUOUT))!($D(DTOUT)) D Q ;*398 - Exit/Timeout
- .I $D(PSONV) S PSZZQUIT=1 Q
- .S PSORX("DFLG")=1
- .I '$O(PSCAN(0)) Q ;*398 - Array has Rx IEN
- .I $G(REA)'="R" Q ;*398 - Reinstate only
- .S RXIEN=+$G(PSCAN(RX)) I 'RXIEN Q ;*398 - Get Rx IEN
- .S RXSTA=$$GET1^DIQ(52,RXIEN,100,"I") ;*398 - Get status
- .I RXSTA=12 Q ;*398 - Correct status
- .S DIE="^PSRX(",DA=RXIEN,DR="100///12" ;*398 - Discontinued
- .D ^DIE ;*398 - Update Rx file
- I $D(PSONV) S PSORX("INTERVENE")=0 D EN1^PSORXI(PSONV) Q
- D ^PSORXI
- Q
- ;
- WRAPTEXT(TEXT,LIMIT,CSPACES) ;Wrap text util copied in from a PSO routine originally *524
- ;;FUNCTION TO DISPLAY (WRITE) TEXT WRAPPED TO A CERTAIN COLUMN LENGTH
- ;;DEFAULT=74 CHARACTERS WITH NO SPACES IN FRONT
- N WORDS,COUNT,LINE,NEXTWORD
- Q:$G(TEXT)']"" ""
- S LIMIT=$G(LIMIT,74)
- S CSPACES=$S($G(CSPACES):CSPACES,1:0)
- S WORDS=$L(TEXT," ")
- W !,$$REPEAT^XLFSTR(" ",CSPACES)
- F COUNT=1:1:WORDS D
- . S NEXTWORD=$P(TEXT," ",COUNT)
- . Q:NEXTWORD="" ;TO REMOVE LEADING OR DOUBLE SPACES
- . S LINE=$G(LINE)_NEXTWORD_" "
- . I $L($G(LINE))>LIMIT W !,$$REPEAT^XLFSTR(" ",CSPACES) K LINE
- . W NEXTWORD_" "
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODRG 13017 printed Jan 18, 2025@03:28:32 Page 2
- PSODRG ;IHS/DSD/JCM - ORDER ENTRY DRUG SELECTION ;10/23/18 8:47am
- +1 ;;7.0;OUTPATIENT PHARMACY;**20,23,36,53,54,46,112,139,207,148,243,268,324,251,375,387,398,390,427,411,458,504,517,457,574,524,747**;DEC 1997;Build 7
- +2 ; Reference to ^PSDRUG( in ICR #221
- +3 ; Reference to ^PS(50.7 in ICR #2223
- +4 ; Reference to $$PROMPT^PSSDIN in ICR #3166
- +5 ; Reference to EN^PSSDIN in ICR #3166
- +6 ; Reference to $$GETNDC^PSSNDCUT in ICR #4707
- +7 ; Reference to ^OROCAPI in ICR #5367
- +8 ; Reference to $$OITM^ORX8 in ICR #5469
- +9 ; Reference to ^VADPT in ICR #10061
- +10 ; Reference to IN^PSSHRQ2 in ICR #5369
- +11 ; Reference to ^XTMP("ORRDI" in ICR #5440
- +12 ;
- +13 ;*524 Add HAZ Handle & Haz Dispose Alert pre-order checks
- +14 ;----------------------------------------------------------
- START ;
- +1 SET (PSONEW("DFLG"),PSONEW("FIELD"),PSODRG("QFLG"))=0
- KILL PSORX("DFLG")
- +2 DO @($SELECT(+$GET(PSOEDIT)=1&('$DATA(DA)):"SELECT^PSODRGN",1:"SELECT"))
- +3 ; Select Drug
- if $GET(PSORXED("DFLG"))
- GOTO END
- +4 ;PATCH PSO*7*517 - Blocking action FN if issuing a controlled substance to a patient without a zipcode
- +5 NEW DRGIEN
- SET DRGIEN=$PIECE($GET(PSOY),U)
- +6 IF $$CSBLOCK^PSOORNEW(PSODFN,DRGIEN)
- Begin DoDot:1
- +7 WRITE !,"Controlled substance prescriptions require a patient address. Please update"
- +8 WRITE !,"patient address information. This action will also invalidate a digitally"
- +9 WRITE !,"signed prescription and require the provider to re-enter the order."
- +10 SET PSONEW("DFLG")=1
- End DoDot:1
- SET DIR(0)="E"
- WRITE !
- DO ^DIR
- KILL DIR,Y
- GOTO END
- +11 ;PSO*7*517 - END
- +12 IF $GET(PSORX("EDIT"))
- IF $GET(PSOY)
- IF $GET(PSODRUG("IEN"))=+PSOY
- Begin DoDot:1
- +13 NEW NDC
- DO NDC(+$GET(PSORXED("IRXN")),0,+PSOY,.NDC)
- IF $GET(NDC)="^"
- SET PSORXED("DFLG")=1
- QUIT
- +14 IF $GET(NDC)'=""
- SET (PSODRUG("NDC"),PSORXED("FLD",27))=NDC
- End DoDot:1
- if $GET(PSORXED("DFLG"))
- GOTO END
- +15 ;
- +16 IF $GET(PSORX("EDIT"))]""
- IF 'PSONEW("FIELD")
- DO TRADE
- +17 if $GET(PSONEW("DFLG"))!($GET(PSODRG("QFLG")))!($GET(PSORXED("DFLG")))
- GOTO END
- +18 ; Set various drug information
- DO SET
- +19 ; Display dispense drug/orderable item text
- DO NFI
- +20 ; Do any post selection action
- if '$GET(PSOEDIT)
- DO POST
- IF $GET(PSORX("DFLG"))
- SET PSONEW("DFLG")=1
- if '$GET(PSORX("EDIT"))
- KILL PSORX("DFLG")
- END ;D EOJ
- +1 QUIT
- +2 ;------------------------------------------------------------
- +3 ;
- SELECT ;
- +1 if '$GET(PSORXED)
- KILL CLOZPAT
- +2 KILL IT,DIC,X,Y,PSODRUG("TRADE NAME"),PSODRUG("NDC"),PSODRUG("DAW"),PSODRUG("BAD")
- if $GET(POERR)&($PIECE($GET(OR0),"^",9))
- SET Y=$$GET1^DIQ(50,$PIECE(OR0,"^",9),.01)
- +3 IF $GET(PSODRUG("IEN"))]""
- SET Y=PSODRUG("NAME")
- SET PSONEW("OLD VAL")=PSODRUG("IEN")
- +4 WRITE !,"DRUG: "_$SELECT($GET(Y)]"":Y_"// ",1:"")
- READ X:$SELECT($DATA(DTIME):DTIME,1:300)
- IF '$TEST
- SET DTOUT=1
- +5 IF X=""
- IF $GET(Y)]""
- if Y
- SET X=Y
- if 'X
- SET X=$GET(PSODRUG("IEN"))
- if X
- SET X="`"_X
- +6 if X=""
- GOTO SELECT
- +7 IF X?1."?"
- WRITE !!,"Answer with DRUG NUMBER, or GENERIC NAME, or VA PRODUCT NAME, or",!,"NATIONAL DRUG CLASS, or SYNONYM"
- GOTO SELECT
- +8 IF $GET(PSORXED)
- IF X["^"
- SET PSORXED("DFLG")=1
- GOTO SELECTX
- +9 IF X="^"!(X["^^")!($DATA(DTOUT))
- SET PSONEW("DFLG")=1
- GOTO SELECTX
- +10 IF '$GET(POERR)
- IF X[U
- IF $LENGTH(X)>1
- SET PSODIR("FLD")=PSONEW("FLD")
- DO JUMP^PSODIR1
- if $GET(PSODIR("FIELD"))
- SET PSONEW("FIELD")=PSODIR("FIELD")
- KILL PSODIR
- SET PSODRG("QFLG")=1
- GOTO SELECTX
- +11 SET DIC=50
- SET DIC(0)="EMQZVT"
- SET DIC("T")=""
- SET D="B^C^VAPN^VAC"
- +12 ;,$D(^PSDRUG(""ASP"",+$G(^(2)),+Y))"
- SET DIC("S")="I $S('$$GET1^DIQ(50,+Y,100,""I""):1,DT'>$$GET1^DIQ(50,+Y,100,""I""):1,1:0),$S($$GET1^DIQ(50,+Y,63,""I"")'[""O"":0,1:1)"
- +13 DO MIX^DIC1
- KILL DIC,D
- +14 IF $DATA(DTOUT)
- SET PSONEW("DFLG")=1
- GOTO SELECTX
- +15 IF $DATA(DUOUT)
- KILL DUOUT
- GOTO SELECT
- +16 IF Y<0
- GOTO SELECT
- +17 if $GET(PSONEW("OLD VAL"))=+Y&('$GET(PSOEDIT))
- SET PSODRG("QFLG")=1
- +18 KILL PSOY
- SET PSOY=Y
- SET PSOY(0)=Y(0)
- +19 IF $PIECE(PSOY(0),"^")="OTHER DRUG"!($PIECE(PSOY(0),"^")="OUTSIDE DRUG")
- DO TRADE
- SELECTX KILL X,Y,DTOUT,DUOUT,PSONEW("OLD VAL")
- +1 QUIT
- +2 ;
- NDC(RX,RFL,DRG,NDC) ; Editing NDC for Released Rx's or for Unresolved ECME Rejects
- +1 SET NDC=$SELECT($GET(NDC)'="":$GET(NDC),1:$$GETNDC^PSONDCUT(RX,.RFL))
- +2 ; Check if we should edit the NDC
- +3 ; Needs to be released or have unresolved billable rejects (PSO*7*427)
- +4 ;
- +5 ; continue flag
- NEW PSOCONT
- SET PSOCONT=0
- +6 ; get out if NDC edit not allowed
- Begin DoDot:1
- +7 ; Released - continue and allow edit
- IF $$RXRLDT^PSOBPSUT(RX,RFL)
- SET PSOCONT=1
- QUIT
- +8 ; unreleased w/unresolved billable rejections
- IF $$FIND^PSOREJUT(RX,RFL)
- IF $$STATUS^PSOBPSUT(RX,RFL)'=""
- SET PSOCONT=1
- QUIT
- +9 QUIT
- End DoDot:1
- if 'PSOCONT
- QUIT
- +10 ;
- +11 SET NDC=$SELECT($GET(NDC)'="":$GET(NDC),1:$$GETNDC^PSONDCUT(RX,.RFL))
- +12 DO NDCEDT^PSONDCUT(RX,.RFL,$GET(DRG),$GET(PSOSITE),.NDC)
- +13 QUIT
- +14 ;
- TRADE ;
- +1 KILL DIR,DIC,DA,X,Y
- +2 SET DIR(0)="52,6.5"
- if $GET(PSOTRN)]""
- SET DIR("B")=$GET(PSOTRN)
- DO ^DIR
- KILL DIR,DIC
- +3 IF X="@"
- SET Y=X
- KILL DIRUT
- +4 IF $DATA(DIRUT)
- if $DATA(DUOUT)!$DATA(DTOUT)&('$DATA(PSORX("EDIT")))
- SET PSONEW("DFLG")=1
- GOTO TRADEX
- +5 SET PSODRUG("TRADE NAME")=Y
- TRADEX IF $GET(PSORXED("DFLG"))
- IF $DATA(DIRUT)
- SET PSORXED("DFLG")=1
- +1 KILL DIRUT,DTOUT,DUOUT,X,Y,DA,DR,DIE
- +2 QUIT
- SET ;
- +1 ;init haz alert shown to user=no *524
- NEW PSOHZ
- SET PSOHZ=0
- +2 NEW STAT
- SET PSODRUG("IEN")=+PSOY
- SET PSODRUG("VA CLASS")=$PIECE(PSOY(0),"^",2)
- +3 SET PSODRUG("NAME")=$PIECE(PSOY(0),"^")
- +4 SET PSODRUG("OI")=+$$GET1^DIQ(50,+PSOY,2.1,"I")
- SET PSODRUG("OIN")=$$GET1^DIQ(50,+PSOY,2.1)
- +5 SET PSODRUG("NDF")=$SELECT(PSODRUG("OI"):$$GET1^DIQ(50,+PSOY,20,"I")_"A"_$$GET1^DIQ(50,+PSOY,22,"I"),1:0)
- +6 SET PSODRUG("MAXDOSE")=$PIECE(PSOY(0),"^",4)
- SET PSODRUG("DEA")=$PIECE(PSOY(0),"^",3)
- +7 ; (#25) NATIONAL DRUG CLASS [6P:50.605]
- +8 ; zero if field is null
- SET PSODRUG("CLN")=+$$GET1^DIQ(50,+PSOY,25,"I")
- +9 SET PSODRUG("SIG")=$PIECE(PSOY(0),"^",5)
- +10 IF $GET(PSODRUG("NDC"))=""
- SET PSODRUG("NDC")=$$GETNDC^PSSNDCUT(+PSOY,$GET(PSOSITE))
- +11 SET PSODRUG("DAW")=$$GET1^DIQ(50,+PSOY,81)
- +12 IF PSODRUG("DAW")=""
- SET PSODRUG("DAW")=0
- +13 SET PSODRUG("STKLVL")=$$GET1^DIQ(50,+PSOY,50)
- +14 ;PSO*7*574 - Defect 1181628 Replaced code for PRICE PER DISPENSE UNIT display
- +15 if $GET(^PSDRUG(+PSOY,660))']""
- GOTO SETX
- +16 SET PSOX1=$GET(^PSDRUG(+PSOY,660))
- +17 ; PSO*7*574 changed field to (#16) PRICE PER DISPENSE UNIT [6N]
- SET PSODRUG("COST")=$$GET1^DIQ(50,+PSOY,16)
- +18 SET PSODRUG("UNIT")=$$GET1^DIQ(50,+PSOY,14.5)
- +19 SET PSODRUG("EXPIRATION DATE")=$$GET1^DIQ(50,+PSOY,17.1,"I")
- SETX KILL PSOX1,PSOY
- +1 QUIT
- NFI ;display restriction/guidelines
- +1 DO EN^PSSDIN(PSODRUG("OI"),PSODRUG("IEN"))
- SET NFI=$$PROMPT^PSSDIN
- +2 IF NFI]""
- IF "ODY"[NFI
- DO TD^PSONFI
- +3 KILL NFI
- QUIT
- POST ;order checks
- +1 ;add Hazardous to Handle/Dispose warning messages *524
- +2 NEW HAZ,HAZH,HAZD,HTXT,LL
- SET HAZ=$$HAZ^PSSUTIL(PSODRUG("IEN"))
- SET HAZH=$PIECE(HAZ,U)
- SET HAZD=$PIECE(HAZ,U,2)
- +3 IF ('$GET(PSOHZ)!(PSODRUG("IEN")'=$GET(PSOLSTDR)))
- IF (HAZH!HAZD)
- Begin DoDot:1
- +4 SET PSOHZ=1
- SET PSOLSTDR=PSODRUG("IEN")
- +5 DO HAZWARNG^PSSUTIL(PSODRUG("IEN"),"O",HAZH,HAZD,.HTXT)
- +6 SET $PIECE(LL,"-",80)="-"
- +7 WRITE #,$CHAR(7),LL,!
- +8 WRITE $JUSTIFY("***** WARNING *****",47)
- +9 DO WRAPTEXT(HTXT,65,5)
- WRITE !
- +10 WRITE LL,!
- +11 KILL DIR
- SET DIR(0)="E"
- SET DIR("?")="Press Return to continue"
- SET DIR("A")="Press Return to continue"
- DO ^DIR
- End DoDot:1
- +12 NEW LIST
- SET LIST="PSOPEPS"
- +13 KILL PSODOSD,^TMP("PSORXDC",$JOB),^TMP($JOB,LIST),^TMP("PSODAOC",$JOB)
- +14 KILL ZDGDG,ZTHER,IT,PSODLQT,PSODOSD
- +15 IF $DATA(^XTMP("ORRDI","OUTAGE INFO","DOWN"))
- SET ^TMP("PSODAOC",$JOB,"NORDI",1,0)="Remote data not available - Only local order checks processed."
- +16 SET ^TMP($JOB,LIST,"IN","PING")=""
- DO IN^PSSHRQ2(LIST)
- +17 KILL DIR
- IF $PIECE(^TMP($JOB,LIST,"OUT",0),"^")=-1
- Begin DoDot:1
- +18 DO DATACK^PSODDPRE
- +19 SET ^TMP("PSODAOC",$JOB,"NOSYS",1,0)="No Enhanced Order Checks can be performed. Reason(s): "_$PIECE($GET(^TMP($JOB,LIST,"OUT",0)),"^",2)
- End DoDot:1
- +20 KILL ^TMP($JOB,LIST,"IN"),^TMP($JOB,LIST,"OUT","EXCEPTIONS")
- +21 if $GET(PSORX("DFLG"))!($GET(PSORXED("DFLG")))
- GOTO POSTX
- +22 KILL PSORX("INTERVENE"),PSOQUIT
- NEW STAT,SIG,PTR,NDF,VAP
- SET PSORX("DFLG")=0
- +23 WRITE !!
- if (($Y+5)'>IOSL)
- DO HD^PSODDPR2()
- +24 DO ^PSOBUILD
- +25 ; Duplicate drug check
- if '$DATA(PSODGCK)
- DO @$SELECT($GET(COPY):"^PSOCPPRE",1:"^PSODDPRE")
- +26 if $GET(PSORX("DFLG"))
- GOTO POSTX
- +27 if (($Y+5)'>IOSL)
- DO HD^PSODDPR2()
- +28 IF $$GET1^DIQ(50,+$GET(PSODRUG("IEN")),17.5)="PSOCLO1"
- DO CLOZ
- +29 if PSORX("DFLG")
- GOTO POSTX
- +30 if (($Y+5)'>IOSL)
- DO HD^PSODDPR2()
- +31 WRITE !,"Now doing allergy checks. Please wait...",!
- HANG 1
- +32 SET PSONOAL=""
- DO ALLERGY^PSOORUT2
- if PSONOAL'=""
- DO NOALRGY
- KILL PSONOAL
- +33 if (($Y+5)'>IOSL)
- DO HD^PSODDPR2()
- +34 IF '$GET(PSODGCKX)
- DO ^PSODGAL1
- KILL PSORX("INTERVENE")
- +35 if PSORX("DFLG")!$GET(PSOQUIT)
- GOTO POSTX
- +36 ;This is the allergy check for profile drugs CK action
- +37 IF $DATA(PSODGCK)
- IF $DATA(PSOSD)
- DO PRFLP^PSOUTL
- +38 ;pso*7*412
- if $GET(PSORX("DFLG"))
- GOTO POSTX
- +39 ;speed renew
- if $GET(PSOSPRNW)&($GET(PSORENW("DFLG")))
- GOTO POSTX
- +40 ;aminoglycoside
- +41 NEW AOC,CROCPFLG
- SET CROCPFLG=0
- +42 if (($Y+5)'>IOSL)
- DO HD^PSODDPR2()
- +43 SET AOC=$$AOC^OROCAPI(PSODFN,$PIECE(PSODRUG("NDF"),"A",2))
- IF $PIECE(AOC,"^",4)]""
- Begin DoDot:1
- +44 SET CROCPFLG=1
- +45 WRITE !!,"***Aminoglycoside Ordered***",!!
- +46 KILL ^UTILITY($JOB,"W")
- SET DIWL=1
- SET DIWR=78
- SET DIWF=""
- SET X=$PIECE(AOC,"^",4)
- DO ^DIWP
- +47 WRITE !
- FOR ZX=0:0
- SET ZX=$ORDER(^UTILITY($JOB,"W",1,ZX))
- if 'ZX
- QUIT
- WRITE ?2,^UTILITY($JOB,"W",1,ZX,0),!
- if (($Y+5)'>IOSL)
- DO HD^PSODDPR2()
- +48 KILL ^UTILITY($JOB,"W")
- +49 SET ^TMP("PSODAOC",$JOB,"CPRS",$PIECE(AOC,"^",2),0)=PSODRUG("IEN")_"^"_$PIECE(AOC,"^",4)
- +50 WRITE !
- End DoDot:1
- +51 if (($Y+5)'>IOSL)
- DO HD^PSODDPR2()
- +52 ;dangerous meds for pat >64
- +53 IF $GET(PSODRUG("OI"))
- Begin DoDot:1
- +54 NEW OI,OIR
- SET OI=$$OITM^ORX8(PSODRUG("OI"),"99PSP")
- if 'OI
- QUIT
- +55 SET OIR=$$DOC^OROCAPI(PSODFN,OI)
- IF $PIECE(OIR,"^",4)]""
- Begin DoDot:2
- +56 SET CROCPFLG=1
- +57 if (($Y+5)'>IOSL)
- DO HD^PSODDPR2()
- WRITE !!,"***Dangerous Meds for Patient >64***",!!
- SET DFN=PSODFN
- DO DEM^VADPT
- +58 KILL ^UTILITY($JOB,"W")
- SET DIWL=1
- SET DIWR=78
- SET DIWF=""
- SET X=$PIECE(OIR,"^",4)
- DO ^DIWP
- +59 FOR ZX=0:0
- SET ZX=$ORDER(^UTILITY($JOB,"W",1,ZX))
- if 'ZX
- QUIT
- WRITE ?2,^UTILITY($JOB,"W",1,ZX,0),!
- if (($Y+5)'>IOSL)
- DO HD^PSODDPR2()
- +60 KILL ^UTILITY($JOB,"W")
- +61 SET ^TMP("PSODAOC",$JOB,"CPRS",$PIECE(OIR,"^",2),0)=PSODRUG("IEN")_"^"_$PIECE(OIR,"^",4)
- +62 WRITE !
- End DoDot:2
- End DoDot:1
- +63 if (($Y+5)'>IOSL)
- DO HD^PSODDPR2()
- +64 ;metformin lab results
- +65 NEW GOC
- SET GOC=$$GOC^OROCAPI(PSODFN,PSODRUG("NAME"))
- IF $PIECE(GOC,"^",4)]""
- Begin DoDot:1
- +66 SET CROCPFLG=1
- +67 WRITE !!,"***Metformin Lab Results***",!!
- +68 KILL ^UTILITY($JOB,"W")
- SET DIWL=1
- SET DIWR=78
- SET DIWF=""
- SET X=$PIECE(GOC,"^",4)
- DO ^DIWP
- +69 FOR ZX=0:0
- SET ZX=$ORDER(^UTILITY($JOB,"W",1,ZX))
- if 'ZX
- QUIT
- WRITE ?2,^UTILITY($JOB,"W",1,ZX,0),!
- if (($Y+5)'>IOSL)
- DO HD^PSODDPR2()
- +70 KILL ^UTILITY($JOB,"W")
- +71 SET ^TMP("PSODAOC",$JOB,"CPRS",$PIECE(GOC,"^",2),0)=PSODRUG("IEN")_"^"_$PIECE(GOC,"^",4)
- +72 WRITE !
- End DoDot:1
- +73 if (($Y+5)'>IOSL)
- DO HD^PSODDPR2()
- +74 ;clinical reminder oc
- +75 if '$GET(PSONCROC)
- DO CK^PSOCROC
- KILL CROCPFLG
- IF $GET(PSORX("DFLG"))
- QUIT
- +76 KILL DIWF,DIWL,DIWR,ZX,DFN,CROCPFLG
- +77 ;stops if drug is supply
- IF $GET(PSODRUG("DEA"))["S"!($EXTRACT($GET(PSODRUG("VA CLASS")),1,2)="XA")
- IF '$GET(PSODGCK)
- Begin DoDot:1
- +78 WRITE !,"Now Processing Enhanced Order Checks! Please wait...",!
- HANG 1
- End DoDot:1
- GOTO POSTX
- +79 ;enhanced OC
- +80 if (($Y+5)'>IOSL)
- DO HD^PSODDPR2()
- +81 ; Set PSORX("DFLG")=1 if process to stop new enhanced order checks
- WRITE !
- DO @$SELECT($GET(COPY):"OBX^PSOCPPRE",1:"OBX^PSODDPRE")
- POSTX ;
- +1 KILL IT,^TMP($JOB,"DI"),PSORX("INTERVENE"),DA,^TMP($JOB,"PSODRDI"),ZDGDG,ZTHER,^TMP($JOB,"DI"_PSODFN),PSZZQUIT
- +2 IF '$GET(PSORXED)
- IF '$GET(PSOREINS)
- KILL PSOQUIT
- +3 QUIT
- +4 ;
- EOJ ;
- +1 KILL PSODRG
- +2 QUIT
- WAIT ;
- +1 KILL DIR
- SET DIR(0)="E"
- SET DIR("?")="Press Return to continue"
- SET DIR("A")="Press Return to continue..."
- WRITE !
- +2 DO ^DIR
- KILL DIRUT,DUOUT,DIR,X,Y
- +3 QUIT
- +4 ;
- CLOZ ;
- +1 SET ANQRTN=$$GET1^DIQ(50,+$GET(PSODRUG("IEN")),17.5)
- SET ANQX=0
- +2 SET P(5)=PSODRUG("IEN")
- SET DFN=PSODFN
- SET X=ANQRTN
- +3 XECUTE ^%ZOSF("TEST")
- IF $TEST
- DO ^PSOCLO1
- if $GET(ANQX)
- SET PSORX("DFLG")=1
- +4 KILL P(5),ANQRTN,ANQX,X,DFN
- +5 QUIT
- +6 ;
- EN(DRG) ;returns lab test identified for clozapine order checking
- +1 KILL LAB
- IF $$GET1^DIQ(50,+$GET(DRG),17.5)'="PSOCLO1"
- SET LAB("NOT")=0
- QUIT
- +2 NEW LABARR
- DO LIST^DIC(50.02,","_DRG_",","2;3","I",,,,,,,"LABARR")
- +3 IF +LABARR("DILIST",0)'=2
- SET LAB("BAD TEST")=0
- KILL CNT
- QUIT
- +4 KILL CNT
- FOR I=1:1
- if '$DATA(LABARR("DILIST",2,I))
- QUIT
- Begin DoDot:1
- +5 SET LABT=$SELECT(LABARR("DILIST","ID",I,3)=1:"WBC",1:"ANC")
- +6 SET LAB(LABT)=LABARR("DILIST",1,I)_"^"_LABARR("DILIST","ID",I,2)_"^"_LABARR("DILIST","ID",I,3)
- End DoDot:1
- +7 KILL LABT,I
- +8 QUIT
- NOALRGY ;
- +1 if (($Y+5)'>IOSL)
- DO HD^PSODDPR2()
- +2 NEW DIR
- SET DIR(0)="SA^1:YES;0:NO"
- +3 IF $DATA(^TMP($JOB,"PSOINTERVENE",+PSODFN))
- Begin DoDot:1
- +4 SET DIR("A")="No Allergy Assessment - Do you want to duplicate Intervention?: "
- SET DIR("B")="Yes"
- +5 DO ^DIR
- +6 IF 'Y
- Begin DoDot:2
- +7 IF Y=0
- DO ^PSORXI
- QUIT
- +8 SET PSORX("DFLG")=1
- End DoDot:2
- QUIT
- +9 DO DUPINV^PSORXI
- End DoDot:1
- QUIT
- +10 WRITE $CHAR(7),!,"There is no allergy assessment on file for this patient."
- +11 WRITE !,"You will be prompted to intervene if you continue with this prescription"
- +12 IF $DATA(PSODGCK)
- WRITE !
- KILL DIR
- SET DIR(0)="E"
- SET DIR("A")="Press Return to Continue..."
- DO ^DIR
- KILL DIR
- +13 if $DATA(PSODGCK)
- QUIT
- +14 ;*398
- NEW DUOUT,DTOUT,RXIEN,RXSTA
- +15 SET DIR("A")="Do you want to Continue?: "
- SET DIR("B")="N"
- DO ^DIR
- +16 ;*398 - Exit/Timeout
- IF 'Y!($DATA(DUOUT))!($DATA(DTOUT))
- Begin DoDot:1
- +17 IF $DATA(PSONV)
- SET PSZZQUIT=1
- QUIT
- +18 SET PSORX("DFLG")=1
- +19 ;*398 - Array has Rx IEN
- IF '$ORDER(PSCAN(0))
- QUIT
- +20 ;*398 - Reinstate only
- IF $GET(REA)'="R"
- QUIT
- +21 ;*398 - Get Rx IEN
- SET RXIEN=+$GET(PSCAN(RX))
- IF 'RXIEN
- QUIT
- +22 ;*398 - Get status
- SET RXSTA=$$GET1^DIQ(52,RXIEN,100,"I")
- +23 ;*398 - Correct status
- IF RXSTA=12
- QUIT
- +24 ;*398 - Discontinued
- SET DIE="^PSRX("
- SET DA=RXIEN
- SET DR="100///12"
- +25 ;*398 - Update Rx file
- DO ^DIE
- End DoDot:1
- QUIT
- +26 IF $DATA(PSONV)
- SET PSORX("INTERVENE")=0
- DO EN1^PSORXI(PSONV)
- QUIT
- +27 DO ^PSORXI
- +28 QUIT
- +29 ;
- WRAPTEXT(TEXT,LIMIT,CSPACES) ;Wrap text util copied in from a PSO routine originally *524
- +1 ;;FUNCTION TO DISPLAY (WRITE) TEXT WRAPPED TO A CERTAIN COLUMN LENGTH
- +2 ;;DEFAULT=74 CHARACTERS WITH NO SPACES IN FRONT
- +3 NEW WORDS,COUNT,LINE,NEXTWORD
- +4 if $GET(TEXT)']""
- QUIT ""
- +5 SET LIMIT=$GET(LIMIT,74)
- +6 SET CSPACES=$SELECT($GET(CSPACES):CSPACES,1:0)
- +7 SET WORDS=$LENGTH(TEXT," ")
- +8 WRITE !,$$REPEAT^XLFSTR(" ",CSPACES)
- +9 FOR COUNT=1:1:WORDS
- Begin DoDot:1
- +10 SET NEXTWORD=$PIECE(TEXT," ",COUNT)
- +11 ;TO REMOVE LEADING OR DOUBLE SPACES
- if NEXTWORD=""
- QUIT
- +12 SET LINE=$GET(LINE)_NEXTWORD_" "
- +13 IF $LENGTH($GET(LINE))>LIMIT
- WRITE !,$$REPEAT^XLFSTR(" ",CSPACES)
- KILL LINE
- +14 WRITE NEXTWORD_" "
- End DoDot:1
- +15 QUIT