PSBODO ;BIRMINGHAM/EFC - BCMA UNIT DOSE VIRTUAL DUE LIST FUNCTIONS ;Dec 22, 2021@07:55:46
;;3.0;BAR CODE MED ADMIN;**5,21,24,38,58,68,70,83,98,106,93**;Mar 2004;Build 111
;Per VA Directive 6402, this routine should not be modified.
;
; Reference/IA
; EN^PSJBCMA2/2830
; GETPROVL^PSGSICH1/5653
; INTRDIC^PSGSICH1/5654
; GETSIOPI^PSJBCMA5/5763
; VA(200)/10060 - NEW PERSON FILE
;
;*68 - add ability to print new WP Special Instructions/OPI fields
;*58 - add sections to display Prv Override comments and Rph
; Interventions to this report for (critical drug/drug and all
; adverse reactions/allergies)
;*70 - print clinic name at top of detail section if exists.
;*83 - add Removal times
;*106- add Hazardous Handle & Dispose flags ;
;*93 - add order check to Display Order form, add Indication to order detail
;
EN ;
;
; Description:
; Returns a display for a selected order when double clicked on the VDL
;
N PSBGBL,DFN
S PSBGBL=$NAME(^TMP("PSBO",$J,"B"))
F S PSBGBL=$Q(@PSBGBL) Q:PSBGBL="" Q:$QS(PSBGBL,2)'=$J Q:$QS(PSBGBL,1)'["PSBO" D
.S DFN=$QS(PSBGBL,5)
.D DISPORD
.D CLEAN^PSBVT ;*83 cleanup all PSB* variables
Q
;
DISPORD ;
N PSBGBL,PSBOI,PSBHDR,PSJGLO,LINE,PSBPRV,PSBPV,PSBRPH,PSBRH,PSBOVR,I,X,Y
N CNT,DIWF,DIWL,DIWR
S PSBOI=$$GET1^DIQ(53.69,PSBRPT_",",.09)
D EN^PSJBCMA2(DFN,PSBOI)
S PSJGLO="^TMP(""PSJ"""_","_$J
D CLEAN^PSBVT
D PSJ1^PSBVT(DFN,PSBOI)
S PSBHDR(1)="BCMA - Display Order" D PT^PSBOHDR(DFN,.PSBHDR) W !
I '$G(PSBONX) W !,"Invalid Order"
D:$G(PSBONX)
.W:$G(PSBCLORD)]"" "Clinic: "_PSBCLORD,! ;*70
.W !,"Orderable Item: ",PSBOITX
.W !?17,$S(PSBHAZHN:"<<HAZ Handle>> ",1:""),$S(PSBHAZDS:"<<HAZ Dispose>>",1:"") ;*106
.I PSBONX["V" W !,"Infusion Rate: ",PSBIFR
.I PSBONX'["V" W !,"Dosage Ordered: ",PSBDOSE
.W ?40,"Start: ",PSBOSTX W:$G(^XTMP("PSB DEBUG",0)) " ("_PSBONX_")"
.W !?40,"Stop: ",PSBOSPX,?70,PSBOSTSX ;*70
.W !,"Med Route: ",PSBMR
.W !,"Schedule Type: ",PSBSCHTX
.I PSBONX'["V" W ?40,"Self Med: ",PSBSMX
.W:PSBSM !?40,"Hosp Sup: ",PSBSMX
.W:PSBSCH'="" !,"Schedule: ",PSBSCH
.I PSBONX'["V" W !,"Admin Times: ",PSBADST
.I PSBONX'["V",PSBMRRFL W !,"Removal Times: ",$$REMSTR^PSBUTL(PSBADST,PSBDOA,PSBSCHT,PSBOSP,PSBOPRSP)
.I PSBONX["V",((PSBIVT="P")!(PSBISYR=1)) W !,"Admin Times: ",PSBADST
.W !,"Provider: ",PSBMDX
.;*68 change
.W !,"Special Instructions/Other Print Info:"
.K ^TMP("PSJBCMA5",$J)
.D GETSIOPI^PSJBCMA5(DFN,PSBONX,1)
.F QQ=0:0 S QQ=$O(^TMP("PSJBCMA5",$J,DFN,PSBONX,QQ)) Q:'QQ D
..W !,^TMP("PSJBCMA5",$J,DFN,PSBONX,QQ)
.K ^TMP("PSJBCMA5",$J)
.W !,"Indication: "_$P($G(^PS(55,+$G(DFN),$S(PSBONX["V":"IV",1:5),+PSBONX,18)),U)
.;*68 end
.;*58 override/intervention section * * *
.S PSBOVR=0
.D GETPROVL^PSGSICH1(DFN,PSBONX,.PSBPRV)
.D INTRDIC^PSGSICH1(DFN,PSBONX,.PSBRPH,2)
.S PSBPV=$S($D(PSBPRV)>1:1,1:0)
.S PSBRH=$S($D(PSBRPH)>1:1,1:0)
.I 'PSBPV,PSBRH D DSPPRV(.PSBPRV,132,2,26,1) S PSBOVR=1
.I PSBPV D DSPPRV(.PSBPRV,132,2,26) S PSBOVR=1
.I PSBPV,'PSBRH D DSPRPH(.PSBRPH,132,2,26,1) S PSBOVR=1
.I PSBRH D DSPRPH(.PSBRPH,132,2,26) S PSBOVR=1
.I PSBOVR W !,$TR($J("",75)," ","-")
.;*58 end override/intervention section * * *
.;
.W !
.I $D(PSBDDA(1)) D
..W !,"Dispense Drugs",!,"Drug Name",?40,"Units",?50,"Inactive Date"
..W !,$TR($J("",75)," ","-")
..F Y=0:0 S Y=$O(PSBDDA(Y)) Q:'Y D
...S X=$P(PSBDDA(Y),U,4)
...W !,$P(PSBDDA(Y),U,3),?40,$S(X]"":X,1:1)
...S X=$P(PSBDDA(Y),U,5) Q:'X
...W ?50,$E(X,4,5),"/",$E(X,6,7),"/",(1700+$E(X,1,3))
.I $D(PSBADA(1)) D
..W !!,"Additives",!,"Name",?40,"Strength"
..W !,$TR($J("",75)," ","-")
..F Y=0:0 S Y=$O(PSBADA(Y)) Q:'Y D
...W !,$P(PSBADA(Y),U,3),?40,$P(PSBADA(Y),U,4)
.I $D(PSBSOLA(1)) D
..W !!,"Solution",!,"Name",?40,"Volume"
..W !,$TR($J("",75)," ","-")
..F Y=0:0 S Y=$O(PSBSOLA(Y)) Q:'Y D
...W !,$P(PSBSOLA(Y),U,3),?40,$P(PSBSOLA(Y),U,4)
.I $P(@(PSJGLO_","_0_")"),U,1)'=-1 D
..W !,$TR($J("",75)," ","-")
..W !,"Pharmacy Activity Log: "
..F I=1:1:$P(@(PSJGLO_","_0_")"),U,4) D
...W !?9,"Date: ",$$FMTE^XLFDT($P(@(PSJGLO_","_I_","_1_")"),U,1)),?35,"User: ",$P(@(PSJGLO_","_I_","_1_")"),U,2)
...W !?5,"Activity: ",$P(@(PSJGLO_","_I_","_1_")"),U,4)
...I $D(@(PSJGLO_","_I_","_2_")")) D ;*83
....I $P(@(PSJGLO_","_I_","_1_")"),U,3)["DURATION" S @(PSJGLO_","_I_","_2_")")=@(PSJGLO_","_I_","_2_")")/60 ;DOA convert min to hr *83
....W !?8,"Field: ",$P(@(PSJGLO_","_I_","_1_")"),U,3),!?5,"Old Data: ",$S($P(@(PSJGLO_","_I_","_1_")"),U,3)["DATE":$$FMTE^XLFDT(@(PSJGLO_","_I_","_2_")")),1:@(PSJGLO_","_I_","_2_")")) ;correct date, PSB*3*98
...I $D(@(PSJGLO_","_I_","_3_")")) W !?7,"Reason: ",@(PSJGLO_","_I_","_3_")")
...W !
.;*93 begin
.S CNT=0
.N ORCPRS,ORIFN,LST,ORY ;remove LST
.K ^TMP("PSBORTXT",$J)
.S ORCPRS=0
.I PSBONX["U" D PSS431^PSS55(DFN,+PSBONX,,,"PSB") S ORCPRS=$G(^TMP($J,"PSB",+PSBONX,66))
.I PSBONX["V" D PSS436^PSS55(DFN,+PSBONX,"PBS") S ORCPRS=$G(^TMP($J,"PBS",+PSBONX,110))
.S ORIFN=ORCPRS,ORY=$NA(^TMP("PSBORTXT",$J)),@ORY=""
.D ORCHECK ;create the CPRS order check
.K ^TMP("PSBORTXT",$J)
.;*93 end
W !!
D CLEAN^PSBVT K @(PSJGLO_")")
Q
;
DSPPRV(ARR,LN,IND,ALGN,NONE) ; Display Provider (CPRS) override reasons
; ARR = array with provider override text.
; LN = total width of report writable area. (opt, 132 default)
; IND = indent for both left and right margins. (opt,0 default)
; ALGN = align colon on this column. (opt, 25 default)
; NONE = display empty Provider override msg. (opt, 0 default)
;
N CAT,QQ,OC,HDG,CTRTAB,TMPONX,LINE,L1,L2,XX
S LN=+$G(LN,132),IND=+$G(IND),ALGN=$G(ALGN,25),NONE=$G(NONE,0)
S LN=LN-(IND*2) ;adj writeable area by both L & R margins
;provider heading
W !!?IND,$TR($J("",LN)," ","=")
S HDG="** Current Provider Overrides for this order **"
S CTRTAB=(LN-$L(HDG))/2
W !?CTRTAB,HDG
W !?IND,$TR($J("",LN)," ","="),!
;
;special scenario when NO Prv overrides, but Rph Interventions do
I NONE W !?IND,"No Provider Overrides to display.",! Q
;
;provider body text
S TMPONX=$O(ARR("PROV",DFN,"")) I TMPONX D
.S QQ="" F S QQ=$O(ARR("PROV",DFN,+TMPONX,QQ)) Q:QQ="" D
..S LINE=ARR("PROV",DFN,+TMPONX,QQ),XX=$F(LINE,":")
..S L1=$J($E(LINE,1,XX),ALGN),L2=$E(LINE,XX+1,$L(LINE))
..W !?IND,L1,L2
.W !
S CAT=0 F S CAT=$O(ARR("PROVR",DFN,+TMPONX,CAT)) Q:'CAT D
.S OC=0 F S OC=$O(ARR("PROVR",DFN,+TMPONX,CAT,OC)) Q:'OC D
..S LINE=ARR("PROVR",DFN,+TMPONX,CAT,OC,0),XX=$F(LINE,":")
..S L1=$J($E(LINE,1,XX),ALGN),L2=$E(LINE,XX+1,$L(LINE))
..W !,?IND,$$WRAP^PSBO(IND,LN,LINE),!
Q
;
DSPRPH(ARR,LN,IND,ALGN,NONE) ; Display Pharmacist Interventions
; ARR = array with Pharmacist intervention text. (opt)
; LN = total width of report writable area. (opt,132 default)
; IND = indent for both left and right margins. (opt, 0 default)
; ALGN = align colon on this column. (opt. 25 default)
; NONE = display empty Pharmacist intervention msg. (opt, 0 default)
;
N FLD,WP,WPTAG,WPLIN,HDG,INT,CTRTAB,LINE,L1,L2,XX
S LN=+$G(LN,132),IND=+$G(IND),ALGN=$G(ALGN,25),NONE=$G(NONE,0)
S LN=LN-(IND*2) ;adj writeable area by both L & R margins
;
;pharmacist heading
W !?IND,$TR($J("",LN)," ","=")
S HDG="** Current Pharmacist Interventions for this order **"
S CTRTAB=(LN-$L(HDG))/2
W !?CTRTAB,HDG
W !?IND,$TR($J("",LN)," ","="),!
;
;special scenario when NO Rph interventions, but Prv overrides do
I NONE W !?IND,"No Pharmacist Interventions to display.",! Q
;
;pharmacist body text
F INT=0:0 S INT=$O(ARR(DFN,PSBONX,INT)) Q:'INT D
.F FLD=0:0 S FLD=$O(ARR(DFN,PSBONX,INT,FLD)) Q:'FLD D
..I FLD<1000 D
...S LINE=ARR(DFN,PSBONX,INT,FLD),XX=$F(LINE,":")
...S L1=$J($E(LINE,1,XX),ALGN),L2=$E(LINE,XX+1,$L(LINE))
...W !?IND,L1,L2
..I FLD>1000 D
...S (WP,WPLIN,WPTAG)="",LIN1=1
...F S WP=$O(ARR(DFN,PSBONX,INT,FLD,WP)) Q:WP="" D
....S LINE=ARR(DFN,PSBONX,INT,FLD,WP)
....I WP<1 D ;field Hdg line
.....S LINE=$J(LINE,ALGN) W !?IND,LINE
....E D ;detail WP lines
.....I 'LIN1 W !
.....W ?IND+ALGN,LINE
.....S LIN1=0
.W !
W !
Q
DSPORCK(LN,IND,ALGN,NONE) ; Display Order Check(CPRS) #93 NEW TAG
; LN = total width of report writable area. (opt, 132 default)
; IND = indent for both left and right margins. (opt,0 default)
; ALGN = align colon on this column. (opt, 25 default)
; NONE = display empty order check msg. (opt, 0 default)
;
N CAT,QQ,OC,HDG,CTRTAB
S LN=+$G(LN,132),IND=+$G(IND),ALGN=$G(ALGN,25),NONE=$G(NONE,0)
S LN=LN-(IND*2) ;adj writeable area by both L & R margins
;order check heading
W !!?IND,$TR($J("",LN)," ","=")
S HDG="** Current Order Check **"
S CTRTAB=(LN-$L(HDG))/2
W !?CTRTAB,HDG
W !?IND,$TR($J("",LN)," ","="),!
;
; if there isn't order check information to display
I NONE W !?IND,"No Order Check to display.",! Q
;
;write out order check text
S QQ=0 F S QQ=$O(^TMP("PSBORTXT",$J,QQ)) Q:QQ'>0 W ?IND,$G(^TMP("PSBORTXT",$J,QQ)),!
Q
ORCHECK ; recreate CPRS Order Check - copied from ORQ2 #93
K ^TMP($J,"PSBOCDATA")
I '$$OCAPI^ORCHECK(+ORIFN,"PSBOCDATA") D DSPORCK(132,2,26,1) Q
E D
. N CK,OK,X0,X,CDL,I,ACK,ALLGYDRG,HDR S HDR=0
. S ACK=0
. D ALLERGY
. S:$D(OK) OK=""
. S CK=0 F S CK=$O(^TMP($J,"PSBOCDATA",CK)) Q:CK'>0 D
.. Q:$D(ALLGYDRG(CK)) ;skip allergy entries
.. S:HDR=0 CNT=CNT+1,@ORY@(CNT)=" ",CNT=CNT+1,@ORY@(CNT)="Order Checks:",CNT=CNT+1,@ORY@(CNT)=" ",HDR=1
.. S X0=^TMP($J,"PSBOCDATA",CK,"OC NUMBER")_U_^TMP($J,"PSBOCDATA",CK,"OC LEVEL")_U_U_^TMP($J,"PSBOCDATA",CK,"OR REASON")_U_^TMP($J,"PSBOCDATA",CK,"OR PROVIDER")_U_^TMP($J,"PSBOCDATA",CK,"OR DT")
.. S X=^TMP($J,"PSBOCDATA",CK,"OC TEXT",1,0)
.. S CDL=$$CDL($P(X0,U,2)) I $P(X0,U,6),'$D(OK) S OK=$P(X0,U,4,6)
.. I $L(X)'>100 S CNT=CNT+1,@ORY@(CNT)=CDL_X D XTRA Q
.. S DIWL=1,DIWR=100,DIWF="C100" K ^UTILITY($J,"W") D ^DIWP
.. S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=CDL_^(I,0),CDL=" "
.. D XTRA
. K ^TMP($J,"PSBOCDATA")
. Q:(HDR=0)
. Q:'$L($G(OK)) S CNT=CNT+1,@ORY@(CNT)="Override: "_$S($P(OK,U,2):$$USER($P(OK,U,2))_" on ",1:"")_$TR($$FMTE^XLFDT($P(OK,U,3),"6MZ"),"@"," ")
. I $L($P(OK,U))'>100 S CNT=CNT+1,@ORY@(CNT)=" "_$P(OK,U) Q
. S DIWL=1,DIWR=100,DIWF="C100",X=$P(OK,U) K ^UTILITY($J,"W") D ^DIWP
. S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=" "_^(I,0)
D DSPORCK(132,2,26) ;print order check
K ^UTILITY($J,"W"),ALLGYDRG
Q
;
ALLERGY ;separate the ALLERGY-DRUG INTERACTION Order Checks #93 NEW TAG
N RET,INSTANCE,INSTASAV
S RET=1,(ACK,CK,CNT)=0
F S CK=$O(^TMP($J,"PSBOCDATA",CK)) Q:CK'>0 D
. I $G(^TMP($J,"PSBOCDATA",CK,"OC NUMBER"))'=3 Q ;only select the allergy-drug interactions
. S ALLGYDRG(CK)=" "
. I ACK=0 S CNT=CNT+1,@ORY@(CNT)=" ",CNT=CNT+1,@ORY@(CNT)="Allergy Order Checks:",CNT=CNT+1,ACK=1
. S X0=^TMP($J,"PSBOCDATA",CK,"OC NUMBER")_U_^TMP($J,"PSBOCDATA",CK,"OC LEVEL")_U_U_^TMP($J,"PSBOCDATA",CK,"OR REASON")_U_^TMP($J,"PSBOCDATA",CK,"OR PROVIDER")_U_^TMP($J,"PSBOCDATA",CK,"OR DT")
. S X=^TMP($J,"PSBOCDATA",CK,"OC TEXT",1,0)
. S CDL=$$CDL($P(X0,U,2)) I $P(X0,U,6),'$D(OK) S OK=$P(X0,U,4,6)
. I $L(X)'>100 S CNT=CNT+1,@ORY@(CNT)=CDL_X D XTRA Q
. S DIWL=1,DIWR=100,DIWF="C100" K ^UTILITY($J,"W") D ^DIWP
. S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=CDL_^(I,0),CDL=" "
. S INSTANCE=$G(^TMP($J,"PSBOCDATA",CK,"OC INSTANCE"))
. I INSTANCE>0 D
.. I $$GET1^DIQ(100.517,RET_","_INSTANCE_",",11)'="" D
... S:'$D(INSTASAV) INSTASAV=INSTANCE
. D XTRA
I ACK=1 D ;if there are allergy-drug interaction check for override
. Q:'$L($G(OK)) S CNT=CNT+1,@ORY@(CNT)="Override: "_$S($P(OK,U,2):$$USER($P(OK,U,2))_" on ",1:"")_$TR($$FMTE^XLFDT($P(OK,U,3),"6MZ"),"@"," ")
. I $L($P(OK,U))'>100 S CNT=CNT+1,@ORY@(CNT)=" "_$P(OK,U),CNT=CNT+1 Q
. S DIWL=1,DIWR=100,DIWF="C100",X=$P(OK,U) K ^UTILITY($J,"W") D ^DIWP
. S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=" "_^(I,0)
I $D(INSTASAV) D
. S CNT=CNT+1,@ORY@(CNT)=" "
. S CNT=CNT+1,@ORY@(CNT)="Remote Comment: "_$$GET1^DIQ(100.517,RET_","_INSTASAV_",",11)
Q
CDL(X) ; -- Returns Clinical Danger Level X #93 NEW TAG
N Y S Y=$S(X=1:"HIGH:",X=2:"MODERATE:",X=3:"LOW:",1:"NONE:")
S Y=$E(Y_" ",1,12)
Q Y
;
XTRA ; #93 NEW TAG
I $O(^TMP($J,"PSBOCDATA",CK,"OC TEXT",1)) N ORXT S ORXT=1 F S ORXT=$O(^TMP($J,"PSBOCDATA",CK,"OC TEXT",ORXT)) Q:'ORXT D
. S X=^TMP($J,"PSBOCDATA",CK,"OC TEXT",ORXT,0),CDL=" "
. I $L(X)'>100 S CNT=CNT+1,@ORY@(CNT)=CDL_X Q
. S DIWL=1,DIWR=100,DIWF="C100" K ^UTILITY($J,"W") D ^DIWP
. S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=CDL_^(I,0),CDL=" "
I $O(^TMP($J,"PSBOCDATA",CK,"OC TEXT",1)) S X="",CNT=CNT+1,@ORY@(CNT)=" "
Q
;
USER(X) ; -- Returns NAME (TITLE) of New Person X #93 NEW TAG
N Y,Z
S Y=$$GET1^DIQ(200,+X,.01),Z=$$GET1^DIQ(200,+X,8)
S:(Z'="") Y=Y_" ("_Z_")" ;check if title exist
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBODO 13438 printed Dec 13, 2024@01:40:33 Page 2
PSBODO ;BIRMINGHAM/EFC - BCMA UNIT DOSE VIRTUAL DUE LIST FUNCTIONS ;Dec 22, 2021@07:55:46
+1 ;;3.0;BAR CODE MED ADMIN;**5,21,24,38,58,68,70,83,98,106,93**;Mar 2004;Build 111
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; EN^PSJBCMA2/2830
+6 ; GETPROVL^PSGSICH1/5653
+7 ; INTRDIC^PSGSICH1/5654
+8 ; GETSIOPI^PSJBCMA5/5763
+9 ; VA(200)/10060 - NEW PERSON FILE
+10 ;
+11 ;*68 - add ability to print new WP Special Instructions/OPI fields
+12 ;*58 - add sections to display Prv Override comments and Rph
+13 ; Interventions to this report for (critical drug/drug and all
+14 ; adverse reactions/allergies)
+15 ;*70 - print clinic name at top of detail section if exists.
+16 ;*83 - add Removal times
+17 ;*106- add Hazardous Handle & Dispose flags ;
+18 ;*93 - add order check to Display Order form, add Indication to order detail
+19 ;
EN ;
+1 ;
+2 ; Description:
+3 ; Returns a display for a selected order when double clicked on the VDL
+4 ;
+5 NEW PSBGBL,DFN
+6 SET PSBGBL=$NAME(^TMP("PSBO",$JOB,"B"))
+7 FOR
SET PSBGBL=$QUERY(@PSBGBL)
if PSBGBL=""
QUIT
if $QSUBSCRIPT(PSBGBL,2)'=$JOB
QUIT
if $QSUBSCRIPT(PSBGBL,1)'["PSBO"
QUIT
Begin DoDot:1
+8 SET DFN=$QSUBSCRIPT(PSBGBL,5)
+9 DO DISPORD
+10 ;*83 cleanup all PSB* variables
DO CLEAN^PSBVT
End DoDot:1
+11 QUIT
+12 ;
DISPORD ;
+1 NEW PSBGBL,PSBOI,PSBHDR,PSJGLO,LINE,PSBPRV,PSBPV,PSBRPH,PSBRH,PSBOVR,I,X,Y
+2 NEW CNT,DIWF,DIWL,DIWR
+3 SET PSBOI=$$GET1^DIQ(53.69,PSBRPT_",",.09)
+4 DO EN^PSJBCMA2(DFN,PSBOI)
+5 SET PSJGLO="^TMP(""PSJ"""_","_$JOB
+6 DO CLEAN^PSBVT
+7 DO PSJ1^PSBVT(DFN,PSBOI)
+8 SET PSBHDR(1)="BCMA - Display Order"
DO PT^PSBOHDR(DFN,.PSBHDR)
WRITE !
+9 IF '$GET(PSBONX)
WRITE !,"Invalid Order"
+10 if $GET(PSBONX)
Begin DoDot:1
+11 ;*70
if $GET(PSBCLORD)]""
WRITE "Clinic: "_PSBCLORD,!
+12 WRITE !,"Orderable Item: ",PSBOITX
+13 ;*106
WRITE !?17,$SELECT(PSBHAZHN:"<<HAZ Handle>> ",1:""),$SELECT(PSBHAZDS:"<<HAZ Dispose>>",1:"")
+14 IF PSBONX["V"
WRITE !,"Infusion Rate: ",PSBIFR
+15 IF PSBONX'["V"
WRITE !,"Dosage Ordered: ",PSBDOSE
+16 WRITE ?40,"Start: ",PSBOSTX
if $GET(^XTMP("PSB DEBUG",0))
WRITE " ("_PSBONX_")"
+17 ;*70
WRITE !?40,"Stop: ",PSBOSPX,?70,PSBOSTSX
+18 WRITE !,"Med Route: ",PSBMR
+19 WRITE !,"Schedule Type: ",PSBSCHTX
+20 IF PSBONX'["V"
WRITE ?40,"Self Med: ",PSBSMX
+21 if PSBSM
WRITE !?40,"Hosp Sup: ",PSBSMX
+22 if PSBSCH'=""
WRITE !,"Schedule: ",PSBSCH
+23 IF PSBONX'["V"
WRITE !,"Admin Times: ",PSBADST
+24 IF PSBONX'["V"
IF PSBMRRFL
WRITE !,"Removal Times: ",$$REMSTR^PSBUTL(PSBADST,PSBDOA,PSBSCHT,PSBOSP,PSBOPRSP)
+25 IF PSBONX["V"
IF ((PSBIVT="P")!(PSBISYR=1))
WRITE !,"Admin Times: ",PSBADST
+26 WRITE !,"Provider: ",PSBMDX
+27 ;*68 change
+28 WRITE !,"Special Instructions/Other Print Info:"
+29 KILL ^TMP("PSJBCMA5",$JOB)
+30 DO GETSIOPI^PSJBCMA5(DFN,PSBONX,1)
+31 FOR QQ=0:0
SET QQ=$ORDER(^TMP("PSJBCMA5",$JOB,DFN,PSBONX,QQ))
if 'QQ
QUIT
Begin DoDot:2
+32 WRITE !,^TMP("PSJBCMA5",$JOB,DFN,PSBONX,QQ)
End DoDot:2
+33 KILL ^TMP("PSJBCMA5",$JOB)
+34 WRITE !,"Indication: "_$PIECE($GET(^PS(55,+$GET(DFN),$SELECT(PSBONX["V":"IV",1:5),+PSBONX,18)),U)
+35 ;*68 end
+36 ;*58 override/intervention section * * *
+37 SET PSBOVR=0
+38 DO GETPROVL^PSGSICH1(DFN,PSBONX,.PSBPRV)
+39 DO INTRDIC^PSGSICH1(DFN,PSBONX,.PSBRPH,2)
+40 SET PSBPV=$SELECT($DATA(PSBPRV)>1:1,1:0)
+41 SET PSBRH=$SELECT($DATA(PSBRPH)>1:1,1:0)
+42 IF 'PSBPV
IF PSBRH
DO DSPPRV(.PSBPRV,132,2,26,1)
SET PSBOVR=1
+43 IF PSBPV
DO DSPPRV(.PSBPRV,132,2,26)
SET PSBOVR=1
+44 IF PSBPV
IF 'PSBRH
DO DSPRPH(.PSBRPH,132,2,26,1)
SET PSBOVR=1
+45 IF PSBRH
DO DSPRPH(.PSBRPH,132,2,26)
SET PSBOVR=1
+46 IF PSBOVR
WRITE !,$TRANSLATE($JUSTIFY("",75)," ","-")
+47 ;*58 end override/intervention section * * *
+48 ;
+49 WRITE !
+50 IF $DATA(PSBDDA(1))
Begin DoDot:2
+51 WRITE !,"Dispense Drugs",!,"Drug Name",?40,"Units",?50,"Inactive Date"
+52 WRITE !,$TRANSLATE($JUSTIFY("",75)," ","-")
+53 FOR Y=0:0
SET Y=$ORDER(PSBDDA(Y))
if 'Y
QUIT
Begin DoDot:3
+54 SET X=$PIECE(PSBDDA(Y),U,4)
+55 WRITE !,$PIECE(PSBDDA(Y),U,3),?40,$SELECT(X]"":X,1:1)
+56 SET X=$PIECE(PSBDDA(Y),U,5)
if 'X
QUIT
+57 WRITE ?50,$EXTRACT(X,4,5),"/",$EXTRACT(X,6,7),"/",(1700+$EXTRACT(X,1,3))
End DoDot:3
End DoDot:2
+58 IF $DATA(PSBADA(1))
Begin DoDot:2
+59 WRITE !!,"Additives",!,"Name",?40,"Strength"
+60 WRITE !,$TRANSLATE($JUSTIFY("",75)," ","-")
+61 FOR Y=0:0
SET Y=$ORDER(PSBADA(Y))
if 'Y
QUIT
Begin DoDot:3
+62 WRITE !,$PIECE(PSBADA(Y),U,3),?40,$PIECE(PSBADA(Y),U,4)
End DoDot:3
End DoDot:2
+63 IF $DATA(PSBSOLA(1))
Begin DoDot:2
+64 WRITE !!,"Solution",!,"Name",?40,"Volume"
+65 WRITE !,$TRANSLATE($JUSTIFY("",75)," ","-")
+66 FOR Y=0:0
SET Y=$ORDER(PSBSOLA(Y))
if 'Y
QUIT
Begin DoDot:3
+67 WRITE !,$PIECE(PSBSOLA(Y),U,3),?40,$PIECE(PSBSOLA(Y),U,4)
End DoDot:3
End DoDot:2
+68 IF $PIECE(@(PSJGLO_","_0_")"),U,1)'=-1
Begin DoDot:2
+69 WRITE !,$TRANSLATE($JUSTIFY("",75)," ","-")
+70 WRITE !,"Pharmacy Activity Log: "
+71 FOR I=1:1:$PIECE(@(PSJGLO_","_0_")"),U,4)
Begin DoDot:3
+72 WRITE !?9,"Date: ",$$FMTE^XLFDT($PIECE(@(PSJGLO_","_I_","_1_")"),U,1)),?35,"User: ",$PIECE(@(PSJGLO_","_I_","_1_")"),U,2)
+73 WRITE !?5,"Activity: ",$PIECE(@(PSJGLO_","_I_","_1_")"),U,4)
+74 ;*83
IF $DATA(@(PSJGLO_","_I_","_2_")"))
Begin DoDot:4
+75 ;DOA convert min to hr *83
IF $PIECE(@(PSJGLO_","_I_","_1_")"),U,3)["DURATION"
SET @(PSJGLO_","_I_","_2_")")=@(PSJGLO_","_I_","_2_")")/60
+76 ;correct date, PSB*3*98
WRITE !?8,"Field: ",$PIECE(@(PSJGLO_","_I_","_1_")"),U,3),!?5,"Old Data: ",$SELECT($PIECE(@(PSJGLO_","_I_","_1_")"),U,3)["DATE":$$FMTE^XLFDT(@(PSJGLO_","_I_","_2_")")),1:@(PSJGLO_","_I_","_2_")"))
End DoDot:4
+77 IF $DATA(@(PSJGLO_","_I_","_3_")"))
WRITE !?7,"Reason: ",@(PSJGLO_","_I_","_3_")")
+78 WRITE !
End DoDot:3
End DoDot:2
+79 ;*93 begin
+80 SET CNT=0
+81 ;remove LST
NEW ORCPRS,ORIFN,LST,ORY
+82 KILL ^TMP("PSBORTXT",$JOB)
+83 SET ORCPRS=0
+84 IF PSBONX["U"
DO PSS431^PSS55(DFN,+PSBONX,,,"PSB")
SET ORCPRS=$GET(^TMP($JOB,"PSB",+PSBONX,66))
+85 IF PSBONX["V"
DO PSS436^PSS55(DFN,+PSBONX,"PBS")
SET ORCPRS=$GET(^TMP($JOB,"PBS",+PSBONX,110))
+86 SET ORIFN=ORCPRS
SET ORY=$NAME(^TMP("PSBORTXT",$JOB))
SET @ORY=""
+87 ;create the CPRS order check
DO ORCHECK
+88 KILL ^TMP("PSBORTXT",$JOB)
+89 ;*93 end
End DoDot:1
+90 WRITE !!
+91 DO CLEAN^PSBVT
KILL @(PSJGLO_")")
+92 QUIT
+93 ;
DSPPRV(ARR,LN,IND,ALGN,NONE) ; Display Provider (CPRS) override reasons
+1 ; ARR = array with provider override text.
+2 ; LN = total width of report writable area. (opt, 132 default)
+3 ; IND = indent for both left and right margins. (opt,0 default)
+4 ; ALGN = align colon on this column. (opt, 25 default)
+5 ; NONE = display empty Provider override msg. (opt, 0 default)
+6 ;
+7 NEW CAT,QQ,OC,HDG,CTRTAB,TMPONX,LINE,L1,L2,XX
+8 SET LN=+$GET(LN,132)
SET IND=+$GET(IND)
SET ALGN=$GET(ALGN,25)
SET NONE=$GET(NONE,0)
+9 ;adj writeable area by both L & R margins
SET LN=LN-(IND*2)
+10 ;provider heading
+11 WRITE !!?IND,$TRANSLATE($JUSTIFY("",LN)," ","=")
+12 SET HDG="** Current Provider Overrides for this order **"
+13 SET CTRTAB=(LN-$LENGTH(HDG))/2
+14 WRITE !?CTRTAB,HDG
+15 WRITE !?IND,$TRANSLATE($JUSTIFY("",LN)," ","="),!
+16 ;
+17 ;special scenario when NO Prv overrides, but Rph Interventions do
+18 IF NONE
WRITE !?IND,"No Provider Overrides to display.",!
QUIT
+19 ;
+20 ;provider body text
+21 SET TMPONX=$ORDER(ARR("PROV",DFN,""))
IF TMPONX
Begin DoDot:1
+22 SET QQ=""
FOR
SET QQ=$ORDER(ARR("PROV",DFN,+TMPONX,QQ))
if QQ=""
QUIT
Begin DoDot:2
+23 SET LINE=ARR("PROV",DFN,+TMPONX,QQ)
SET XX=$FIND(LINE,":")
+24 SET L1=$JUSTIFY($EXTRACT(LINE,1,XX),ALGN)
SET L2=$EXTRACT(LINE,XX+1,$LENGTH(LINE))
+25 WRITE !?IND,L1,L2
End DoDot:2
+26 WRITE !
End DoDot:1
+27 SET CAT=0
FOR
SET CAT=$ORDER(ARR("PROVR",DFN,+TMPONX,CAT))
if 'CAT
QUIT
Begin DoDot:1
+28 SET OC=0
FOR
SET OC=$ORDER(ARR("PROVR",DFN,+TMPONX,CAT,OC))
if 'OC
QUIT
Begin DoDot:2
+29 SET LINE=ARR("PROVR",DFN,+TMPONX,CAT,OC,0)
SET XX=$FIND(LINE,":")
+30 SET L1=$JUSTIFY($EXTRACT(LINE,1,XX),ALGN)
SET L2=$EXTRACT(LINE,XX+1,$LENGTH(LINE))
+31 WRITE !,?IND,$$WRAP^PSBO(IND,LN,LINE),!
End DoDot:2
End DoDot:1
+32 QUIT
+33 ;
DSPRPH(ARR,LN,IND,ALGN,NONE) ; Display Pharmacist Interventions
+1 ; ARR = array with Pharmacist intervention text. (opt)
+2 ; LN = total width of report writable area. (opt,132 default)
+3 ; IND = indent for both left and right margins. (opt, 0 default)
+4 ; ALGN = align colon on this column. (opt. 25 default)
+5 ; NONE = display empty Pharmacist intervention msg. (opt, 0 default)
+6 ;
+7 NEW FLD,WP,WPTAG,WPLIN,HDG,INT,CTRTAB,LINE,L1,L2,XX
+8 SET LN=+$GET(LN,132)
SET IND=+$GET(IND)
SET ALGN=$GET(ALGN,25)
SET NONE=$GET(NONE,0)
+9 ;adj writeable area by both L & R margins
SET LN=LN-(IND*2)
+10 ;
+11 ;pharmacist heading
+12 WRITE !?IND,$TRANSLATE($JUSTIFY("",LN)," ","=")
+13 SET HDG="** Current Pharmacist Interventions for this order **"
+14 SET CTRTAB=(LN-$LENGTH(HDG))/2
+15 WRITE !?CTRTAB,HDG
+16 WRITE !?IND,$TRANSLATE($JUSTIFY("",LN)," ","="),!
+17 ;
+18 ;special scenario when NO Rph interventions, but Prv overrides do
+19 IF NONE
WRITE !?IND,"No Pharmacist Interventions to display.",!
QUIT
+20 ;
+21 ;pharmacist body text
+22 FOR INT=0:0
SET INT=$ORDER(ARR(DFN,PSBONX,INT))
if 'INT
QUIT
Begin DoDot:1
+23 FOR FLD=0:0
SET FLD=$ORDER(ARR(DFN,PSBONX,INT,FLD))
if 'FLD
QUIT
Begin DoDot:2
+24 IF FLD<1000
Begin DoDot:3
+25 SET LINE=ARR(DFN,PSBONX,INT,FLD)
SET XX=$FIND(LINE,":")
+26 SET L1=$JUSTIFY($EXTRACT(LINE,1,XX),ALGN)
SET L2=$EXTRACT(LINE,XX+1,$LENGTH(LINE))
+27 WRITE !?IND,L1,L2
End DoDot:3
+28 IF FLD>1000
Begin DoDot:3
+29 SET (WP,WPLIN,WPTAG)=""
SET LIN1=1
+30 FOR
SET WP=$ORDER(ARR(DFN,PSBONX,INT,FLD,WP))
if WP=""
QUIT
Begin DoDot:4
+31 SET LINE=ARR(DFN,PSBONX,INT,FLD,WP)
+32 ;field Hdg line
IF WP<1
Begin DoDot:5
+33 SET LINE=$JUSTIFY(LINE,ALGN)
WRITE !?IND,LINE
End DoDot:5
+34 ;detail WP lines
IF '$TEST
Begin DoDot:5
+35 IF 'LIN1
WRITE !
+36 WRITE ?IND+ALGN,LINE
+37 SET LIN1=0
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+38 WRITE !
End DoDot:1
+39 WRITE !
+40 QUIT
DSPORCK(LN,IND,ALGN,NONE) ; Display Order Check(CPRS) #93 NEW TAG
+1 ; LN = total width of report writable area. (opt, 132 default)
+2 ; IND = indent for both left and right margins. (opt,0 default)
+3 ; ALGN = align colon on this column. (opt, 25 default)
+4 ; NONE = display empty order check msg. (opt, 0 default)
+5 ;
+6 NEW CAT,QQ,OC,HDG,CTRTAB
+7 SET LN=+$GET(LN,132)
SET IND=+$GET(IND)
SET ALGN=$GET(ALGN,25)
SET NONE=$GET(NONE,0)
+8 ;adj writeable area by both L & R margins
SET LN=LN-(IND*2)
+9 ;order check heading
+10 WRITE !!?IND,$TRANSLATE($JUSTIFY("",LN)," ","=")
+11 SET HDG="** Current Order Check **"
+12 SET CTRTAB=(LN-$LENGTH(HDG))/2
+13 WRITE !?CTRTAB,HDG
+14 WRITE !?IND,$TRANSLATE($JUSTIFY("",LN)," ","="),!
+15 ;
+16 ; if there isn't order check information to display
+17 IF NONE
WRITE !?IND,"No Order Check to display.",!
QUIT
+18 ;
+19 ;write out order check text
+20 SET QQ=0
FOR
SET QQ=$ORDER(^TMP("PSBORTXT",$JOB,QQ))
if QQ'>0
QUIT
WRITE ?IND,$GET(^TMP("PSBORTXT",$JOB,QQ)),!
+21 QUIT
ORCHECK ; recreate CPRS Order Check - copied from ORQ2 #93
+1 KILL ^TMP($JOB,"PSBOCDATA")
+2 IF '$$OCAPI^ORCHECK(+ORIFN,"PSBOCDATA")
DO DSPORCK(132,2,26,1)
QUIT
+3 IF '$TEST
Begin DoDot:1
+4 NEW CK,OK,X0,X,CDL,I,ACK,ALLGYDRG,HDR
SET HDR=0
+5 SET ACK=0
+6 DO ALLERGY
+7 if $DATA(OK)
SET OK=""
+8 SET CK=0
FOR
SET CK=$ORDER(^TMP($JOB,"PSBOCDATA",CK))
if CK'>0
QUIT
Begin DoDot:2
+9 ;skip allergy entries
if $DATA(ALLGYDRG(CK))
QUIT
+10 if HDR=0
SET CNT=CNT+1
SET @ORY@(CNT)=" "
SET CNT=CNT+1
SET @ORY@(CNT)="Order Checks:"
SET CNT=CNT+1
SET @ORY@(CNT)=" "
SET HDR=1
+11 SET X0=^TMP($JOB,"PSBOCDATA",CK,"OC NUMBER")_U_^TMP($JOB,"PSBOCDATA",CK,"OC LEVEL")_U_U_^TMP($JOB,"PSBOCDATA",CK,"OR REASON")_U_^TMP($JOB,"PSBOCDATA",CK,"OR PROVIDER")_U_^TMP($JOB,"PSBOCDATA",CK,"OR DT")
+12 SET X=^TMP($JOB,"PSBOCDATA",CK,"OC TEXT",1,0)
+13 SET CDL=$$CDL($PIECE(X0,U,2))
IF $PIECE(X0,U,6)
IF '$DATA(OK)
SET OK=$PIECE(X0,U,4,6)
+14 IF $LENGTH(X)'>100
SET CNT=CNT+1
SET @ORY@(CNT)=CDL_X
DO XTRA
QUIT
+15 SET DIWL=1
SET DIWR=100
SET DIWF="C100"
KILL ^UTILITY($JOB,"W")
DO ^DIWP
+16 SET I=0
FOR
SET I=$ORDER(^UTILITY($JOB,"W",DIWL,I))
if I'>0
QUIT
SET CNT=CNT+1
SET @ORY@(CNT)=CDL_^(I,0)
SET CDL=" "
+17 DO XTRA
End DoDot:2
+18 KILL ^TMP($JOB,"PSBOCDATA")
+19 if (HDR=0)
QUIT
+20 if '$LENGTH($GET(OK))
QUIT
SET CNT=CNT+1
SET @ORY@(CNT)="Override: "_$SELECT($PIECE(OK,U,2):$$USER($PIECE(OK,U,2))_" on ",1:"")_$TRANSLATE($$FMTE^XLFDT($PIECE(OK,U,3),"6MZ"),"@"," ")
+21 IF $LENGTH($PIECE(OK,U))'>100
SET CNT=CNT+1
SET @ORY@(CNT)=" "_$PIECE(OK,U)
QUIT
+22 SET DIWL=1
SET DIWR=100
SET DIWF="C100"
SET X=$PIECE(OK,U)
KILL ^UTILITY($JOB,"W")
DO ^DIWP
+23 SET I=0
FOR
SET I=$ORDER(^UTILITY($JOB,"W",DIWL,I))
if I'>0
QUIT
SET CNT=CNT+1
SET @ORY@(CNT)=" "_^(I,0)
End DoDot:1
+24 ;print order check
DO DSPORCK(132,2,26)
+25 KILL ^UTILITY($JOB,"W"),ALLGYDRG
+26 QUIT
+27 ;
ALLERGY ;separate the ALLERGY-DRUG INTERACTION Order Checks #93 NEW TAG
+1 NEW RET,INSTANCE,INSTASAV
+2 SET RET=1
SET (ACK,CK,CNT)=0
+3 FOR
SET CK=$ORDER(^TMP($JOB,"PSBOCDATA",CK))
if CK'>0
QUIT
Begin DoDot:1
+4 ;only select the allergy-drug interactions
IF $GET(^TMP($JOB,"PSBOCDATA",CK,"OC NUMBER"))'=3
QUIT
+5 SET ALLGYDRG(CK)=" "
+6 IF ACK=0
SET CNT=CNT+1
SET @ORY@(CNT)=" "
SET CNT=CNT+1
SET @ORY@(CNT)="Allergy Order Checks:"
SET CNT=CNT+1
SET ACK=1
+7 SET X0=^TMP($JOB,"PSBOCDATA",CK,"OC NUMBER")_U_^TMP($JOB,"PSBOCDATA",CK,"OC LEVEL")_U_U_^TMP($JOB,"PSBOCDATA",CK,"OR REASON")_U_^TMP($JOB,"PSBOCDATA",CK,"OR PROVIDER")_U_^TMP($JOB,"PSBOCDATA",CK,"OR DT")
+8 SET X=^TMP($JOB,"PSBOCDATA",CK,"OC TEXT",1,0)
+9 SET CDL=$$CDL($PIECE(X0,U,2))
IF $PIECE(X0,U,6)
IF '$DATA(OK)
SET OK=$PIECE(X0,U,4,6)
+10 IF $LENGTH(X)'>100
SET CNT=CNT+1
SET @ORY@(CNT)=CDL_X
DO XTRA
QUIT
+11 SET DIWL=1
SET DIWR=100
SET DIWF="C100"
KILL ^UTILITY($JOB,"W")
DO ^DIWP
+12 SET I=0
FOR
SET I=$ORDER(^UTILITY($JOB,"W",DIWL,I))
if I'>0
QUIT
SET CNT=CNT+1
SET @ORY@(CNT)=CDL_^(I,0)
SET CDL=" "
+13 SET INSTANCE=$GET(^TMP($JOB,"PSBOCDATA",CK,"OC INSTANCE"))
+14 IF INSTANCE>0
Begin DoDot:2
+15 IF $$GET1^DIQ(100.517,RET_","_INSTANCE_",",11)'=""
Begin DoDot:3
+16 if '$DATA(INSTASAV)
SET INSTASAV=INSTANCE
End DoDot:3
End DoDot:2
+17 DO XTRA
End DoDot:1
+18 ;if there are allergy-drug interaction check for override
IF ACK=1
Begin DoDot:1
+19 if '$LENGTH($GET(OK))
QUIT
SET CNT=CNT+1
SET @ORY@(CNT)="Override: "_$SELECT($PIECE(OK,U,2):$$USER($PIECE(OK,U,2))_" on ",1:"")_$TRANSLATE($$FMTE^XLFDT($PIECE(OK,U,3),"6MZ"),"@"," ")
+20 IF $LENGTH($PIECE(OK,U))'>100
SET CNT=CNT+1
SET @ORY@(CNT)=" "_$PIECE(OK,U)
SET CNT=CNT+1
QUIT
+21 SET DIWL=1
SET DIWR=100
SET DIWF="C100"
SET X=$PIECE(OK,U)
KILL ^UTILITY($JOB,"W")
DO ^DIWP
+22 SET I=0
FOR
SET I=$ORDER(^UTILITY($JOB,"W",DIWL,I))
if I'>0
QUIT
SET CNT=CNT+1
SET @ORY@(CNT)=" "_^(I,0)
End DoDot:1
+23 IF $DATA(INSTASAV)
Begin DoDot:1
+24 SET CNT=CNT+1
SET @ORY@(CNT)=" "
+25 SET CNT=CNT+1
SET @ORY@(CNT)="Remote Comment: "_$$GET1^DIQ(100.517,RET_","_INSTASAV_",",11)
End DoDot:1
+26 QUIT
CDL(X) ; -- Returns Clinical Danger Level X #93 NEW TAG
+1 NEW Y
SET Y=$SELECT(X=1:"HIGH:",X=2:"MODERATE:",X=3:"LOW:",1:"NONE:")
+2 SET Y=$EXTRACT(Y_" ",1,12)
+3 QUIT Y
+4 ;
XTRA ; #93 NEW TAG
+1 IF $ORDER(^TMP($JOB,"PSBOCDATA",CK,"OC TEXT",1))
NEW ORXT
SET ORXT=1
FOR
SET ORXT=$ORDER(^TMP($JOB,"PSBOCDATA",CK,"OC TEXT",ORXT))
if 'ORXT
QUIT
Begin DoDot:1
+2 SET X=^TMP($JOB,"PSBOCDATA",CK,"OC TEXT",ORXT,0)
SET CDL=" "
+3 IF $LENGTH(X)'>100
SET CNT=CNT+1
SET @ORY@(CNT)=CDL_X
QUIT
+4 SET DIWL=1
SET DIWR=100
SET DIWF="C100"
KILL ^UTILITY($JOB,"W")
DO ^DIWP
+5 SET I=0
FOR
SET I=$ORDER(^UTILITY($JOB,"W",DIWL,I))
if I'>0
QUIT
SET CNT=CNT+1
SET @ORY@(CNT)=CDL_^(I,0)
SET CDL=" "
End DoDot:1
+6 IF $ORDER(^TMP($JOB,"PSBOCDATA",CK,"OC TEXT",1))
SET X=""
SET CNT=CNT+1
SET @ORY@(CNT)=" "
+7 QUIT
+8 ;
USER(X) ; -- Returns NAME (TITLE) of New Person X #93 NEW TAG
+1 NEW Y,Z
+2 SET Y=$$GET1^DIQ(200,+X,.01)
SET Z=$$GET1^DIQ(200,+X,8)
+3 ;check if title exist
if (Z'="")
SET Y=Y_" ("_Z_")"
+4 QUIT Y
