PSJBCMA5 ;BIR/JCH - RETRIEVE SPECIAL INSTRUCTIONS/OTHER PRINT INFO ; 1/9/12 11:12am
;;5.0;INPATIENT MEDICATIONS;**267,275,361,371,370,383,434**;16 DEC 97;Build 3
;
;Reference to ^DPT is supported by DBIA 10035
;Reference to ^PS(55 is supported by DBIA 2191
;Reference to ^%DTC is supported by DBIA 10000
;Reference to ^DIE is supported by DBIA 10018
;Reference to ^DIQ is supported by DBIA 2056
;
GETSIOPI(DFN,ON,BCMA) ; Get appropriate field depending on order type
; DFN - Patient IEN
; ON - Inpatient Order number
; BCMA - Flag indicating called from BCMA - return data in ^TMP("PSJBCMA",$J
;
I 'ON!'DFN Q 0
K ^TMP("PSJBCMA5",$J,DFN,ON)
I '$G(PSJSYSP),'$G(BCMA) N PSJSYSP S PSJSYSP=$J
I $G(BCMA) D Q +$G(^TMP("PSJBCMA5",$J,DFN,ON))
.N PSJSYSP S PSJSYSP=$J
.I ON["V"!((ON["P")&($D(^PS(53.1,+ON,"AD"))!$D(^PS(53.1,+ON,"SOL")))) D Q
..I $$GETOPI(DFN,ON,1) D MOVETMP(DFN,ON,"IV")
.I $$GETSI(DFN,ON,1) D MOVETMP(DFN,ON,"UD")
I ON["V"!((ON["P")&($D(^PS(53.1,+ON,"AD"))!$D(^PS(53.1,+ON,"SOL")))) Q $$GETOPI(DFN,ON)
Q $$GETSI(DFN,ON)
;
MOVETMP(DFN,ON,OTYP) ; Move text from PS(53.45 to ^TMP for BCMA
N LN,ND S ND=$S(OTYP="IV":6,1:5)
I $O(^PS(53.45,PSJSYSP,ND," "),-1)=1,$TR(^PS(53.45,PSJSYSP,ND,1,0)," ")="" K ^TMP("PSJBCMA5",$J) Q
S ^TMP("PSJBCMA5",$J,DFN,ON)=+$P(^PS(53.45,PSJSYSP,ND,0),"^",3) S LN=0 F S LN=$O(^PS(53.45,PSJSYSP,ND,LN)) Q:'LN D
.S ^TMP("PSJBCMA5",$J,DFN,ON,LN)=^PS(53.45,PSJSYSP,ND,LN,0)
K ^PS(53.45,PSJSYSP,ND)
Q
;
GETSI(DFN,ON,BC) ; Get Special Instructions for Unit Dose orders
N PSJTXT,TXTLN
I $G(DFN)=""!($G(ON)="") Q 0
I '$G(PSJSYSP) N PSJSYSP S PSJSYSP=$J
I ON["P" D Q +$P($G(^PS(53.45,+PSJSYSP,5,0)),"^",3)
.Q:($G(^PS(53.45,+PSJSYSP,5,0))="^^0^0")
.I $G(PSGOEENO)&($G(PSGOORD)=$G(PSJORD)) Q
.I $P($G(^PS(53.1,+ON,15,0)),"^",3) D Q
..S ^PS(53.45,+PSJSYSP,5,0)=^PS(53.1,+ON,15,0)
..S LN=0 F S LN=$O(^PS(53.1,+ON,15,LN)) Q:'LN S ^PS(53.45,+PSJSYSP,5,LN,0)=^PS(53.1,+ON,15,LN,0)
.N OLDSI,MARX,TXTCNT S OLDSI=$P($G(^PS(53.1,+ON,6)),"^") I $L(OLDSI)>0 D Q
..I $G(BC),$L(OLDSI)>74 D TXT^PSGMUTL(OLDSI,74) S TXTCNT=$O(MARX(" "),-1) S ^PS(53.45,+PSJSYSP,5,0)="^^"_TXTCNT_"^"_TXTCNT D Q
...S TXTLN=0 F S TXTLN=$O(MARX(TXTLN)) Q:'TXTLN S ^PS(53.45,+PSJSYSP,5,TXTLN,0)=MARX(TXTLN)
..S ^PS(53.45,+PSJSYSP,5,1,0)=$P(^PS(53.1,+ON,6),"^"),^PS(53.45,+PSJSYSP,5,0)="^^1^1"
I ON["U" D Q $P($G(^PS(53.45,+PSJSYSP,5,0)),"^",3)
.Q:($G(^PS(53.45,+PSJSYSP,5,0))="^^0^0")
.N PSJVERI S PSJVERI=($P($G(PSJSYSP0),"^",9))
.Q:($G(PSGOEENO)=1)&((PSJVERI)'=1)
.I $P($G(^PS(55,+DFN,5,+ON,15,0)),"^",3) D Q
..S ^PS(53.45,+PSJSYSP,5,0)=$G(^PS(55,DFN,5,+ON,15,0))
..S LN=0 F S LN=$O(^PS(55,DFN,5,+ON,15,LN)) Q:'LN S ^PS(53.45,+PSJSYSP,5,LN,0)=^PS(55,DFN,5,+ON,15,LN,0)
.N OLDSI,MARX,TXTCNT S OLDSI=$P($G(^PS(55,DFN,5,+ON,6)),"^") I $L(OLDSI)>0 D Q
..I $G(BC),$L(OLDSI)>74 D TXT^PSGMUTL(OLDSI,74) S TXTCNT=$O(MARX(" "),-1) S ^PS(53.45,+PSJSYSP,5,0)="^^"_TXTCNT_"^"_TXTCNT D Q
...S TXTLN=0 F S TXTLN=$O(MARX(TXTLN)) Q:'TXTLN S ^PS(53.45,+PSJSYSP,5,TXTLN,0)=MARX(TXTLN)
..S ^PS(53.45,+PSJSYSP,5,1,0)=$P(^PS(55,DFN,5,+ON,6),"^"),^PS(53.45,+PSJSYSP,5,0)="^^1^1"
Q 0
;
GETOPI(DFN,ON,BC) ; Get Other Print Info for IV orders
N PSJTXT,LN
I $G(DFN)=""!($G(ON)="") Q 0
I '$G(PSJSYSP) N PSJSYSP S PSJSYSP=$J
I ON["P" D Q +$P($G(^PS(53.45,+PSJSYSP,6,0)),"^",3)
.Q:$P($G(^PS(53.45,+PSJSYSP,6,0)),"^",3)
.I $P($G(^PS(53.1,+ON,16,0)),"^",3) D Q
..S ^PS(53.45,+PSJSYSP,6,0)=^PS(53.1,+ON,16,0)
..S LN=0 F S LN=$O(^PS(53.1,+ON,16,LN)) Q:'LN S ^PS(53.45,+PSJSYSP,6,LN,0)=^PS(53.1,+ON,16,LN,0)
.N OLDOPI,MARX,TXTCNT S OLDOPI=$P($G(^PS(53.1,+ON,9)),"^",2) I $L(OLDOPI)>0 D Q
..I $G(BC),$L(OLDOPI)>74 D TXT^PSGMUTL(OLDOPI,74) S TXTCNT=$O(MARX(" "),-1) S ^PS(53.45,+PSJSYSP,6,0)="^^"_TXTCNT_"^"_TXTCNT D Q
...S TXTLN=0 F S TXTLN=$O(MARX(TXTLN)) Q:'TXTLN S ^PS(53.45,+PSJSYSP,6,TXTLN,0)=MARX(TXTLN)
..S ^PS(53.45,+PSJSYSP,6,1,0)=$P(^PS(53.1,+ON,9),"^",2),^PS(53.45,+PSJSYSP,6,0)="^^1^1"
I ON["V" D
.Q:$P($G(^PS(53.45,+PSJSYSP,6,0)),"^",3)
.I $P($G(^PS(55,+DFN,"IV",+ON,10,0)),"^",3) D Q
..S ^PS(53.45,+PSJSYSP,6,0)=$G(^PS(55,DFN,"IV",+ON,10,0))
..S LN=0 F S LN=$O(^PS(55,DFN,"IV",+ON,10,LN)) Q:'LN S ^PS(53.45,+PSJSYSP,6,LN,0)=^PS(55,DFN,"IV",+ON,10,LN,0)
.N OLDOPI,MARX,TXTCNT S OLDOPI=$P($G(^PS(55,DFN,"IV",+ON,3)),"^") I $L(OLDOPI)>0 D Q
..I $G(BC),$L(OLDOPI)>74 D TXT^PSGMUTL(OLDOPI,74) S TXTCNT=$O(MARX(" "),-1) S ^PS(53.45,+PSJSYSP,6,0)="^^"_TXTCNT_"^"_TXTCNT D Q
...S TXTLN=0 F S TXTLN=$O(MARX(TXTLN)) Q:'TXTLN S ^PS(53.45,+PSJSYSP,6,TXTLN,0)=MARX(TXTLN)
..S ^PS(53.45,+PSJSYSP,6,1,0)=$P(^PS(55,DFN,"IV",+ON,3),"^"),^PS(53.45,+PSJSYSP,6,0)="^^1^1"
I $O(^PS(53.45,+PSJSYSP,6," "),-1)=1,($TR($G(^PS(53.45,+PSJSYSP,6,1,0))," ")="") K ^PS(53.45,+PSJSYSP,6)
Q +$P($G(^PS(53.45,+PSJSYSP,6,0)),"^",3)
;
EDITSI(DFN,PSJORD) ; Edit Special Instructions in ^PS(53.45 via Word Processing
N PSJII,DIC,I,PSJVALID,DIWESUB,PSJTXTLN S PSJVALID=0,DIC="^PS(53.45,"_+$G(PSJSYSP)_",5,",DIWESUB="SPECIAL INSTRUCTIONS"
I $G(PSJORD) I '$P($G(^PS(53.45,+$G(PSJSYSP),5,0)),"^",5) S L=$$GETSI(DFN,PSJORD)
K ^TMP("PSJTMPSI",$J) M ^TMP("PSJTMPSI",$J)=^PS(53.45,+$G(PSJSYSP),5)
F PSJII=1:1 Q:$G(PSJVALID) D
.N II,L,DIR,DIE,DA,TMPLN,DR S PSJTXTLN="",PSJVALID=1,DIWESUB="SPECIAL INSTRUCTIONS"
.I PSJII=1 S DA=PSJSYSP,DR=5,DIE="^PS(53.45," D ^DIE
.I PSJII>1 S DA=PSJSYSP,DR=5,DIC="^PS(53.45,"_+$G(PSJSYSP)_",5," D EN^DIWE
.S PSJTXTLN=+$P($G(^PS(53.45,+PSJSYSP,5,0)),"^",3)
.S II=0 F S II=$O(^PS(53.45,+PSJSYSP,5,II)) Q:'II!'$G(PSJVALID) S TMPLN=$G(^(II,0)) I (TMPLN["^") S PSJVALID=0
.I 'PSJVALID W !!!,$C(7),"SPECIAL INSTRUCTIONS must not contain embedded uparrow ""^"". " I PSJII=1 D PAUSE("SPECIAL INSTRUCTIONS")
.I 'PSJVALID I PSJII>1 W ! I $$DONE("SPECIAL INSTRUCTIONS") K ^PS(53.45,+PSJSYSP,5) M ^PS(53.45,+$G(PSJSYSP),5)=^TMP("PSJTMPSI",$J) S PSJVALID=1 Q
.I PSJVALID I 'PSJTXTLN K ^PS(53.45,+PSJSYSP,5,0) S ^PS(53.45,+PSJSYSP,5,0)="-1^^0^0",^PS(53.45,+PSJSYSP,5,1,0)=""
I $P($G(^PS(53.45,+$G(PSJSYSP),5,0)),"^",3) D ENSI^PSJUTL("^PS(53.45,+$G(PSJSYSP),5,") S PSJTXTLN=$O(^PS(53.45,+$G(PSJSYSP),5,""),-1)
K ^TMP("PSJTMPSI",$J)
Q PSJTXTLN
;
EDITOPI(PSJDPT,PSJORD) ; Edit Other Print Info in ^PS(53.45 via Word Processing
N DIC,I,PSJVALID,DIWESUB,PSJTXTLN S PSJVALID=0,DIC="^PS(53.45,"_+$G(PSJSYSP)_",6,",DIWESUB="OTHER PRINT INFO"
K ^TMP("PSJTMPSI",$J) M ^TMP("PSJTMPSI",$J)=^PS(53.45,+$G(PSJSYSP),6)
F PSJII=1:1 Q:$G(PSJVALID) D
.N II,L,DIR,DA,DIE,TMPLN S DIR="",PSJTXTLN="",PSJVALID=1,DIWESUB="OTHER PRINT INFO"
.I PSJII=1 D OPIWARN(0) I X="^" S DONE=1 Q ;P434 added quit
.S PSJTXTLN=""
.I PSJII=1 S DA=PSJSYSP,DR=6,DIE="^PS(53.45," D ^DIE I X="^" S DONE=1 Q ;P434 added quit
.I PSJII>1 S DA=PSJSYSP,DR=6,DIC="^PS(53.45,"_+$G(PSJSYSP)_",6," D EN^DIWE
.S PSJTXTLN=$O(^PS(53.45,+PSJSYSP,6,""),-1)
.I PSJTXTLN="" K ^PS(53.45,+PSJSYSP,6) S ^PS(53.45,+PSJSYSP,6,0)="-1^^1^1",^PS(53.45,+PSJSYSP,6,1,0)=""
.S II=0 F S II=$O(^PS(53.45,+PSJSYSP,6,II)) Q:'II!'$G(PSJVALID) S TMPLN=$G(^(II,0)) I (TMPLN["^") S PSJVALID=0
.I 'PSJVALID W !!!,$C(7),"OTHER PRINT INFO must not contain embedded uparrow ""^""." I PSJII=1 D PAUSE("OTHER PRINT INFO")
.I 'PSJVALID I PSJII>1 W ! I $$DONE("OTHER PRINT INFO") K ^PS(53.45,+PSJSYSP,6) M ^PS(53.45,+$G(PSJSYSP),6)=^TMP("PSJTMPSI",$J) S PSJVALID=1 Q
.I PSJVALID D
..I ($L($G(^PS(53.45,+PSJSYSP,6,1,0)))>60) D OPIWARN(1) S P("OPI")="Instructions too long. See Order View or BCMA for full text^"_$P(P("OPI"),"^",2) Q
..I PSJTXTLN=1,($L($G(^PS(53.45,+PSJSYSP,6,1,0)))<61) S P("OPI")=^PS(53.45,+PSJSYSP,6,1,0)_"^"_$P(P("OPI"),"^",2) Q
..N TXT,OPIMSG,PSJTMPTX,PSJOVRMX S OPIMSG="Instructions too long. See Order View or BCMA for full text."
..S PSJTMPTX="",PSJOVRMX=0 S TMPLIN=0 F S TMPLIN=$O(^PS(53.45,+PSJSYSP,6,TMPLIN)) Q:'TMPLIN!(PSJOVRMX) D
...S:($L(PSJTMPTX)+$L($G(^PS(53.45,+PSJSYSP,6,TMPLIN,0))))>60 PSJOVRMX=1 Q:$G(PSJOVRMX) S PSJTMPTX=$G(PSJTMPTX)_$S($G(PSJTMPTX)]"":" ",1:"")_$G(^PS(53.45,+PSJSYSP,6,TMPLIN,0))
..I '$G(PSJOVRMX),(PSJTMPTX]"") S P("OPI")=PSJTMPTX_"^"_$P(P("OPI"),"^",2)
K ^TMP("PSJTMPSI",$J)
Q PSJTXTLN
;
OPIWARN(AFTER) ; Warn user about OPI not printing on IV labels
D OPIWARN^PSJBCMA1(AFTER)
Q
;
FILESI(DFN,PSJORD) ; File Special instructions from ^PS(53.45 to UD order
N LN,LNCNT,DA,DIE,X,Y,PSJTMPTX,TMPLIN,PSJOVRMX
D FILESI^PSJBCMA2(DFN,PSJORD)
;K ^PS(53.45,+$G(PSJSYSP),5)
Q
;
FILEOPI(DFN,ORDER) ; File Other Print Info from ^PS(53.45 to IV order
N LN,LNCNT,PSJORD S PSJORD=ORDER
D FILEOPI^PSJBCMA2(DFN,ORDER)
K ^PS(53.45,+PSJSYSP,6)
Q
;
DIFFSI(DFN,PSJORD) ; Compare Special Instructions, pre and post edit
N LN,DIFF S DIFF=0
S LN=0 F S LN=$O(^PS(53.45,PSJSYSP,5,LN)) Q:'LN!DIFF D
.I PSJORD["U" D
..I LN=1 N OTOT,NTOT S OTOT=+$O(^PS(55,DFN,5,+PSJORD,15,""),-1),NTOT=+$O(^PS(53.45,PSJSYSP,5,""),-1) I NTOT'=OTOT S DIFF=1 Q
..I $G(^PS(53.45,PSJSYSP,5,LN,0))'=$G(^PS(55,DFN,5,+PSJORD,15,LN,0)) S DIFF=1
.I PSJORD["P" D
..I LN=1 N OTOT,NTNT S OTOT=+$O(^PS(53.1,+PSJORD,15,""),-1),NTOT=+$O(^PS(53.45,PSJSYSP,5,""),-1) I NTOT'=OTOT S DIFF=1 Q
..I $G(^PS(53.45,PSJSYSP,5,LN,0))'=$G(^PS(53.1,+PSJORD,15,LN,0)) S DIFF=1
Q $S(DIFF:1,1:0)
;
DIFFOPI(DFN,PSJORD) ; Compare Other Print Info, pre and post edit
N LN,DIFF S DIFF=0
S LN=0 F S LN=$O(^PS(53.45,PSJSYSP,6,LN)) Q:'LN!DIFF D
.I PSJORD["V" D
..I LN=1 N OTOT,NTOT S OTOT=+$O(^PS(55,DFN,"IV",+PSJORD,10,""),-1),NTOT=+$O(^PS(53.45,PSJSYSP,6,""),-1) I NTOT'=OTOT S DIFF=1 Q
..I $G(^PS(53.45,PSJSYSP,6,LN,0))'=$G(^PS(55,DFN,"IV",+PSJORD,10,LN,0)) S DIFF=1
.I PSJORD["P" D
..I LN=1 N OTOT,NTOT S OTOT=+$O(^PS(53.1,+PSJORD,16,""),-1),NTOT=+$O(^PS(53.45,PSJSYSP,6,""),-1) I NTOT'=OTOT S DIFF=1 Q
..I $G(^PS(53.45,PSJSYSP,6,LN,0))'=$G(^PS(53.1,+PSJORD,16,LN,0)) S DIFF=1
Q $S(DIFF:1,1:0)
;
DIFFAR(ARRAY1,ARRAY2) ; Compare two text arrays
N LN,DIFF,OTOT,NTOT S DIFF=0,OTOT=0,NTOT=0
S LN=0 F S LN=$O(ARRAY1(LN)) Q:'LN!DIFF I ARRAY1(LN,0)'=$G(ARRAY2(LN,0)) S DIFF=1
Q $S(DIFF:1,1:0)
;
MVOPI(DFN,PSJI1,PSJI2) ; Move OPI from Non-Verified order to Active order during Verify
Q:'$G(DFN)!'$G(PSJI1)!'$G(PSJI2)
I PSJI1["P",PSJI2["V" D GETOPI(DFN,PSJI1),FILEOPI(DFN,PSJI2)
Q
;
MVOPIAL(DFN,PSJI1,PSJI2) ; Move Other Print Info Activity log entries from NV order to Active order, during Verification
D MVOPIAL^PSJBCMA1(DFN,PSJI1,PSJI2)
Q
;
KILL(USR) ; Clean up ^PS(53.45
K ^PS(53.45,+$G(USR),5),^PS(53.45,+$G(USR),6)
Q
;
PAUSE(DEF) ;
K DIR W ! S DIR(0)="EA",DIR("A")="Press Return to continue editing "_$G(DEF)_"...",DIR("?")="Press Return to continue..." D ^DIR W !
Q
;
DONE(DEF) ; -- Done editing?
N DIR,X,Y
S DIR(0)="YA",DIR("A")="Do you want to quit and discard changes"_$S(($G(DEF)]""):" to "_DEF,1:"")_"? ",DIR("B")="NO"
S DIR("?",1)=" Enter YES to exit without saving changes, or ",DIR("?")=" enter NO to continue editing "_$S(($G(DEF)]""):DEF,1:"")_"."
D ^DIR
Q $S($E(Y)="^":1,1:+Y)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJBCMA5 11042 printed Jan 18, 2025@03:07:32 Page 2
PSJBCMA5 ;BIR/JCH - RETRIEVE SPECIAL INSTRUCTIONS/OTHER PRINT INFO ; 1/9/12 11:12am
+1 ;;5.0;INPATIENT MEDICATIONS;**267,275,361,371,370,383,434**;16 DEC 97;Build 3
+2 ;
+3 ;Reference to ^DPT is supported by DBIA 10035
+4 ;Reference to ^PS(55 is supported by DBIA 2191
+5 ;Reference to ^%DTC is supported by DBIA 10000
+6 ;Reference to ^DIE is supported by DBIA 10018
+7 ;Reference to ^DIQ is supported by DBIA 2056
+8 ;
GETSIOPI(DFN,ON,BCMA) ; Get appropriate field depending on order type
+1 ; DFN - Patient IEN
+2 ; ON - Inpatient Order number
+3 ; BCMA - Flag indicating called from BCMA - return data in ^TMP("PSJBCMA",$J
+4 ;
+5 IF 'ON!'DFN
QUIT 0
+6 KILL ^TMP("PSJBCMA5",$JOB,DFN,ON)
+7 IF '$GET(PSJSYSP)
IF '$GET(BCMA)
NEW PSJSYSP
SET PSJSYSP=$JOB
+8 IF $GET(BCMA)
Begin DoDot:1
+9 NEW PSJSYSP
SET PSJSYSP=$JOB
+10 IF ON["V"!((ON["P")&($DATA(^PS(53.1,+ON,"AD"))!$DATA(^PS(53.1,+ON,"SOL"))))
Begin DoDot:2
+11 IF $$GETOPI(DFN,ON,1)
DO MOVETMP(DFN,ON,"IV")
End DoDot:2
QUIT
+12 IF $$GETSI(DFN,ON,1)
DO MOVETMP(DFN,ON,"UD")
End DoDot:1
QUIT +$GET(^TMP("PSJBCMA5",$JOB,DFN,ON))
+13 IF ON["V"!((ON["P")&($DATA(^PS(53.1,+ON,"AD"))!$DATA(^PS(53.1,+ON,"SOL"))))
QUIT $$GETOPI(DFN,ON)
+14 QUIT $$GETSI(DFN,ON)
+15 ;
MOVETMP(DFN,ON,OTYP) ; Move text from PS(53.45 to ^TMP for BCMA
+1 NEW LN,ND
SET ND=$SELECT(OTYP="IV":6,1:5)
+2 IF $ORDER(^PS(53.45,PSJSYSP,ND," "),-1)=1
IF $TRANSLATE(^PS(53.45,PSJSYSP,ND,1,0)," ")=""
KILL ^TMP("PSJBCMA5",$JOB)
QUIT
+3 SET ^TMP("PSJBCMA5",$JOB,DFN,ON)=+$PIECE(^PS(53.45,PSJSYSP,ND,0),"^",3)
SET LN=0
FOR
SET LN=$ORDER(^PS(53.45,PSJSYSP,ND,LN))
if 'LN
QUIT
Begin DoDot:1
+4 SET ^TMP("PSJBCMA5",$JOB,DFN,ON,LN)=^PS(53.45,PSJSYSP,ND,LN,0)
End DoDot:1
+5 KILL ^PS(53.45,PSJSYSP,ND)
+6 QUIT
+7 ;
GETSI(DFN,ON,BC) ; Get Special Instructions for Unit Dose orders
+1 NEW PSJTXT,TXTLN
+2 IF $GET(DFN)=""!($GET(ON)="")
QUIT 0
+3 IF '$GET(PSJSYSP)
NEW PSJSYSP
SET PSJSYSP=$JOB
+4 IF ON["P"
Begin DoDot:1
+5 if ($GET(^PS(53.45,+PSJSYSP,5,0))="^^0^0")
QUIT
+6 IF $GET(PSGOEENO)&($GET(PSGOORD)=$GET(PSJORD))
QUIT
+7 IF $PIECE($GET(^PS(53.1,+ON,15,0)),"^",3)
Begin DoDot:2
+8 SET ^PS(53.45,+PSJSYSP,5,0)=^PS(53.1,+ON,15,0)
+9 SET LN=0
FOR
SET LN=$ORDER(^PS(53.1,+ON,15,LN))
if 'LN
QUIT
SET ^PS(53.45,+PSJSYSP,5,LN,0)=^PS(53.1,+ON,15,LN,0)
End DoDot:2
QUIT
+10 NEW OLDSI,MARX,TXTCNT
SET OLDSI=$PIECE($GET(^PS(53.1,+ON,6)),"^")
IF $LENGTH(OLDSI)>0
Begin DoDot:2
+11 IF $GET(BC)
IF $LENGTH(OLDSI)>74
DO TXT^PSGMUTL(OLDSI,74)
SET TXTCNT=$ORDER(MARX(" "),-1)
SET ^PS(53.45,+PSJSYSP,5,0)="^^"_TXTCNT_"^"_TXTCNT
Begin DoDot:3
+12 SET TXTLN=0
FOR
SET TXTLN=$ORDER(MARX(TXTLN))
if 'TXTLN
QUIT
SET ^PS(53.45,+PSJSYSP,5,TXTLN,0)=MARX(TXTLN)
End DoDot:3
QUIT
+13 SET ^PS(53.45,+PSJSYSP,5,1,0)=$PIECE(^PS(53.1,+ON,6),"^")
SET ^PS(53.45,+PSJSYSP,5,0)="^^1^1"
End DoDot:2
QUIT
End DoDot:1
QUIT +$PIECE($GET(^PS(53.45,+PSJSYSP,5,0)),"^",3)
+14 IF ON["U"
Begin DoDot:1
+15 if ($GET(^PS(53.45,+PSJSYSP,5,0))="^^0^0")
QUIT
+16 NEW PSJVERI
SET PSJVERI=($PIECE($GET(PSJSYSP0),"^",9))
+17 if ($GET(PSGOEENO)=1)&((PSJVERI)'=1)
QUIT
+18 IF $PIECE($GET(^PS(55,+DFN,5,+ON,15,0)),"^",3)
Begin DoDot:2
+19 SET ^PS(53.45,+PSJSYSP,5,0)=$GET(^PS(55,DFN,5,+ON,15,0))
+20 SET LN=0
FOR
SET LN=$ORDER(^PS(55,DFN,5,+ON,15,LN))
if 'LN
QUIT
SET ^PS(53.45,+PSJSYSP,5,LN,0)=^PS(55,DFN,5,+ON,15,LN,0)
End DoDot:2
QUIT
+21 NEW OLDSI,MARX,TXTCNT
SET OLDSI=$PIECE($GET(^PS(55,DFN,5,+ON,6)),"^")
IF $LENGTH(OLDSI)>0
Begin DoDot:2
+22 IF $GET(BC)
IF $LENGTH(OLDSI)>74
DO TXT^PSGMUTL(OLDSI,74)
SET TXTCNT=$ORDER(MARX(" "),-1)
SET ^PS(53.45,+PSJSYSP,5,0)="^^"_TXTCNT_"^"_TXTCNT
Begin DoDot:3
+23 SET TXTLN=0
FOR
SET TXTLN=$ORDER(MARX(TXTLN))
if 'TXTLN
QUIT
SET ^PS(53.45,+PSJSYSP,5,TXTLN,0)=MARX(TXTLN)
End DoDot:3
QUIT
+24 SET ^PS(53.45,+PSJSYSP,5,1,0)=$PIECE(^PS(55,DFN,5,+ON,6),"^")
SET ^PS(53.45,+PSJSYSP,5,0)="^^1^1"
End DoDot:2
QUIT
End DoDot:1
QUIT $PIECE($GET(^PS(53.45,+PSJSYSP,5,0)),"^",3)
+25 QUIT 0
+26 ;
GETOPI(DFN,ON,BC) ; Get Other Print Info for IV orders
+1 NEW PSJTXT,LN
+2 IF $GET(DFN)=""!($GET(ON)="")
QUIT 0
+3 IF '$GET(PSJSYSP)
NEW PSJSYSP
SET PSJSYSP=$JOB
+4 IF ON["P"
Begin DoDot:1
+5 if $PIECE($GET(^PS(53.45,+PSJSYSP,6,0)),"^",3)
QUIT
+6 IF $PIECE($GET(^PS(53.1,+ON,16,0)),"^",3)
Begin DoDot:2
+7 SET ^PS(53.45,+PSJSYSP,6,0)=^PS(53.1,+ON,16,0)
+8 SET LN=0
FOR
SET LN=$ORDER(^PS(53.1,+ON,16,LN))
if 'LN
QUIT
SET ^PS(53.45,+PSJSYSP,6,LN,0)=^PS(53.1,+ON,16,LN,0)
End DoDot:2
QUIT
+9 NEW OLDOPI,MARX,TXTCNT
SET OLDOPI=$PIECE($GET(^PS(53.1,+ON,9)),"^",2)
IF $LENGTH(OLDOPI)>0
Begin DoDot:2
+10 IF $GET(BC)
IF $LENGTH(OLDOPI)>74
DO TXT^PSGMUTL(OLDOPI,74)
SET TXTCNT=$ORDER(MARX(" "),-1)
SET ^PS(53.45,+PSJSYSP,6,0)="^^"_TXTCNT_"^"_TXTCNT
Begin DoDot:3
+11 SET TXTLN=0
FOR
SET TXTLN=$ORDER(MARX(TXTLN))
if 'TXTLN
QUIT
SET ^PS(53.45,+PSJSYSP,6,TXTLN,0)=MARX(TXTLN)
End DoDot:3
QUIT
+12 SET ^PS(53.45,+PSJSYSP,6,1,0)=$PIECE(^PS(53.1,+ON,9),"^",2)
SET ^PS(53.45,+PSJSYSP,6,0)="^^1^1"
End DoDot:2
QUIT
End DoDot:1
QUIT +$PIECE($GET(^PS(53.45,+PSJSYSP,6,0)),"^",3)
+13 IF ON["V"
Begin DoDot:1
+14 if $PIECE($GET(^PS(53.45,+PSJSYSP,6,0)),"^",3)
QUIT
+15 IF $PIECE($GET(^PS(55,+DFN,"IV",+ON,10,0)),"^",3)
Begin DoDot:2
+16 SET ^PS(53.45,+PSJSYSP,6,0)=$GET(^PS(55,DFN,"IV",+ON,10,0))
+17 SET LN=0
FOR
SET LN=$ORDER(^PS(55,DFN,"IV",+ON,10,LN))
if 'LN
QUIT
SET ^PS(53.45,+PSJSYSP,6,LN,0)=^PS(55,DFN,"IV",+ON,10,LN,0)
End DoDot:2
QUIT
+18 NEW OLDOPI,MARX,TXTCNT
SET OLDOPI=$PIECE($GET(^PS(55,DFN,"IV",+ON,3)),"^")
IF $LENGTH(OLDOPI)>0
Begin DoDot:2
+19 IF $GET(BC)
IF $LENGTH(OLDOPI)>74
DO TXT^PSGMUTL(OLDOPI,74)
SET TXTCNT=$ORDER(MARX(" "),-1)
SET ^PS(53.45,+PSJSYSP,6,0)="^^"_TXTCNT_"^"_TXTCNT
Begin DoDot:3
+20 SET TXTLN=0
FOR
SET TXTLN=$ORDER(MARX(TXTLN))
if 'TXTLN
QUIT
SET ^PS(53.45,+PSJSYSP,6,TXTLN,0)=MARX(TXTLN)
End DoDot:3
QUIT
+21 SET ^PS(53.45,+PSJSYSP,6,1,0)=$PIECE(^PS(55,DFN,"IV",+ON,3),"^")
SET ^PS(53.45,+PSJSYSP,6,0)="^^1^1"
End DoDot:2
QUIT
End DoDot:1
+22 IF $ORDER(^PS(53.45,+PSJSYSP,6," "),-1)=1
IF ($TRANSLATE($GET(^PS(53.45,+PSJSYSP,6,1,0))," ")="")
KILL ^PS(53.45,+PSJSYSP,6)
+23 QUIT +$PIECE($GET(^PS(53.45,+PSJSYSP,6,0)),"^",3)
+24 ;
EDITSI(DFN,PSJORD) ; Edit Special Instructions in ^PS(53.45 via Word Processing
+1 NEW PSJII,DIC,I,PSJVALID,DIWESUB,PSJTXTLN
SET PSJVALID=0
SET DIC="^PS(53.45,"_+$GET(PSJSYSP)_",5,"
SET DIWESUB="SPECIAL INSTRUCTIONS"
+2 IF $GET(PSJORD)
IF '$PIECE($GET(^PS(53.45,+$GET(PSJSYSP),5,0)),"^",5)
SET L=$$GETSI(DFN,PSJORD)
+3 KILL ^TMP("PSJTMPSI",$JOB)
MERGE ^TMP("PSJTMPSI",$JOB)=^PS(53.45,+$GET(PSJSYSP),5)
+4 FOR PSJII=1:1
if $GET(PSJVALID)
QUIT
Begin DoDot:1
+5 NEW II,L,DIR,DIE,DA,TMPLN,DR
SET PSJTXTLN=""
SET PSJVALID=1
SET DIWESUB="SPECIAL INSTRUCTIONS"
+6 IF PSJII=1
SET DA=PSJSYSP
SET DR=5
SET DIE="^PS(53.45,"
DO ^DIE
+7 IF PSJII>1
SET DA=PSJSYSP
SET DR=5
SET DIC="^PS(53.45,"_+$GET(PSJSYSP)_",5,"
DO EN^DIWE
+8 SET PSJTXTLN=+$PIECE($GET(^PS(53.45,+PSJSYSP,5,0)),"^",3)
+9 SET II=0
FOR
SET II=$ORDER(^PS(53.45,+PSJSYSP,5,II))
if 'II!'$GET(PSJVALID)
QUIT
SET TMPLN=$GET(^(II,0))
IF (TMPLN["^")
SET PSJVALID=0
+10 IF 'PSJVALID
WRITE !!!,$CHAR(7),"SPECIAL INSTRUCTIONS must not contain embedded uparrow ""^"". "
IF PSJII=1
DO PAUSE("SPECIAL INSTRUCTIONS")
+11 IF 'PSJVALID
IF PSJII>1
WRITE !
IF $$DONE("SPECIAL INSTRUCTIONS")
KILL ^PS(53.45,+PSJSYSP,5)
MERGE ^PS(53.45,+$GET(PSJSYSP),5)=^TMP("PSJTMPSI",$JOB)
SET PSJVALID=1
QUIT
+12 IF PSJVALID
IF 'PSJTXTLN
KILL ^PS(53.45,+PSJSYSP,5,0)
SET ^PS(53.45,+PSJSYSP,5,0)="-1^^0^0"
SET ^PS(53.45,+PSJSYSP,5,1,0)=""
End DoDot:1
+13 IF $PIECE($GET(^PS(53.45,+$GET(PSJSYSP),5,0)),"^",3)
DO ENSI^PSJUTL("^PS(53.45,+$G(PSJSYSP),5,")
SET PSJTXTLN=$ORDER(^PS(53.45,+$GET(PSJSYSP),5,""),-1)
+14 KILL ^TMP("PSJTMPSI",$JOB)
+15 QUIT PSJTXTLN
+16 ;
EDITOPI(PSJDPT,PSJORD) ; Edit Other Print Info in ^PS(53.45 via Word Processing
+1 NEW DIC,I,PSJVALID,DIWESUB,PSJTXTLN
SET PSJVALID=0
SET DIC="^PS(53.45,"_+$GET(PSJSYSP)_",6,"
SET DIWESUB="OTHER PRINT INFO"
+2 KILL ^TMP("PSJTMPSI",$JOB)
MERGE ^TMP("PSJTMPSI",$JOB)=^PS(53.45,+$GET(PSJSYSP),6)
+3 FOR PSJII=1:1
if $GET(PSJVALID)
QUIT
Begin DoDot:1
+4 NEW II,L,DIR,DA,DIE,TMPLN
SET DIR=""
SET PSJTXTLN=""
SET PSJVALID=1
SET DIWESUB="OTHER PRINT INFO"
+5 ;P434 added quit
IF PSJII=1
DO OPIWARN(0)
IF X="^"
SET DONE=1
QUIT
+6 SET PSJTXTLN=""
+7 ;P434 added quit
IF PSJII=1
SET DA=PSJSYSP
SET DR=6
SET DIE="^PS(53.45,"
DO ^DIE
IF X="^"
SET DONE=1
QUIT
+8 IF PSJII>1
SET DA=PSJSYSP
SET DR=6
SET DIC="^PS(53.45,"_+$GET(PSJSYSP)_",6,"
DO EN^DIWE
+9 SET PSJTXTLN=$ORDER(^PS(53.45,+PSJSYSP,6,""),-1)
+10 IF PSJTXTLN=""
KILL ^PS(53.45,+PSJSYSP,6)
SET ^PS(53.45,+PSJSYSP,6,0)="-1^^1^1"
SET ^PS(53.45,+PSJSYSP,6,1,0)=""
+11 SET II=0
FOR
SET II=$ORDER(^PS(53.45,+PSJSYSP,6,II))
if 'II!'$GET(PSJVALID)
QUIT
SET TMPLN=$GET(^(II,0))
IF (TMPLN["^")
SET PSJVALID=0
+12 IF 'PSJVALID
WRITE !!!,$CHAR(7),"OTHER PRINT INFO must not contain embedded uparrow ""^""."
IF PSJII=1
DO PAUSE("OTHER PRINT INFO")
+13 IF 'PSJVALID
IF PSJII>1
WRITE !
IF $$DONE("OTHER PRINT INFO")
KILL ^PS(53.45,+PSJSYSP,6)
MERGE ^PS(53.45,+$GET(PSJSYSP),6)=^TMP("PSJTMPSI",$JOB)
SET PSJVALID=1
QUIT
+14 IF PSJVALID
Begin DoDot:2
+15 IF ($LENGTH($GET(^PS(53.45,+PSJSYSP,6,1,0)))>60)
DO OPIWARN(1)
SET P("OPI")="Instructions too long. See Order View or BCMA for full text^"_$PIECE(P("OPI"),"^",2)
QUIT
+16 IF PSJTXTLN=1
IF ($LENGTH($GET(^PS(53.45,+PSJSYSP,6,1,0)))<61)
SET P("OPI")=^PS(53.45,+PSJSYSP,6,1,0)_"^"_$PIECE(P("OPI"),"^",2)
QUIT
+17 NEW TXT,OPIMSG,PSJTMPTX,PSJOVRMX
SET OPIMSG="Instructions too long. See Order View or BCMA for full text."
+18 SET PSJTMPTX=""
SET PSJOVRMX=0
SET TMPLIN=0
FOR
SET TMPLIN=$ORDER(^PS(53.45,+PSJSYSP,6,TMPLIN))
if 'TMPLIN!(PSJOVRMX)
QUIT
Begin DoDot:3
+19 if ($LENGTH(PSJTMPTX)+$LENGTH($GET(^PS(53.45,+PSJSYSP,6,TMPLIN,0))))>60
SET PSJOVRMX=1
if $GET(PSJOVRMX)
QUIT
SET PSJTMPTX=$GET(PSJTMPTX)_$SELECT($GET(PSJTMPTX)]"":" ",1:"")_$GET(^PS(53.45,+PSJSYSP,6,TMPLIN,0))
End DoDot:3
+20 IF '$GET(PSJOVRMX)
IF (PSJTMPTX]"")
SET P("OPI")=PSJTMPTX_"^"_$PIECE(P("OPI"),"^",2)
End DoDot:2
End DoDot:1
+21 KILL ^TMP("PSJTMPSI",$JOB)
+22 QUIT PSJTXTLN
+23 ;
OPIWARN(AFTER) ; Warn user about OPI not printing on IV labels
+1 DO OPIWARN^PSJBCMA1(AFTER)
+2 QUIT
+3 ;
FILESI(DFN,PSJORD) ; File Special instructions from ^PS(53.45 to UD order
+1 NEW LN,LNCNT,DA,DIE,X,Y,PSJTMPTX,TMPLIN,PSJOVRMX
+2 DO FILESI^PSJBCMA2(DFN,PSJORD)
+3 ;K ^PS(53.45,+$G(PSJSYSP),5)
+4 QUIT
+5 ;
FILEOPI(DFN,ORDER) ; File Other Print Info from ^PS(53.45 to IV order
+1 NEW LN,LNCNT,PSJORD
SET PSJORD=ORDER
+2 DO FILEOPI^PSJBCMA2(DFN,ORDER)
+3 KILL ^PS(53.45,+PSJSYSP,6)
+4 QUIT
+5 ;
DIFFSI(DFN,PSJORD) ; Compare Special Instructions, pre and post edit
+1 NEW LN,DIFF
SET DIFF=0
+2 SET LN=0
FOR
SET LN=$ORDER(^PS(53.45,PSJSYSP,5,LN))
if 'LN!DIFF
QUIT
Begin DoDot:1
+3 IF PSJORD["U"
Begin DoDot:2
+4 IF LN=1
NEW OTOT,NTOT
SET OTOT=+$ORDER(^PS(55,DFN,5,+PSJORD,15,""),-1)
SET NTOT=+$ORDER(^PS(53.45,PSJSYSP,5,""),-1)
IF NTOT'=OTOT
SET DIFF=1
QUIT
+5 IF $GET(^PS(53.45,PSJSYSP,5,LN,0))'=$GET(^PS(55,DFN,5,+PSJORD,15,LN,0))
SET DIFF=1
End DoDot:2
+6 IF PSJORD["P"
Begin DoDot:2
+7 IF LN=1
NEW OTOT,NTNT
SET OTOT=+$ORDER(^PS(53.1,+PSJORD,15,""),-1)
SET NTOT=+$ORDER(^PS(53.45,PSJSYSP,5,""),-1)
IF NTOT'=OTOT
SET DIFF=1
QUIT
+8 IF $GET(^PS(53.45,PSJSYSP,5,LN,0))'=$GET(^PS(53.1,+PSJORD,15,LN,0))
SET DIFF=1
End DoDot:2
End DoDot:1
+9 QUIT $SELECT(DIFF:1,1:0)
+10 ;
DIFFOPI(DFN,PSJORD) ; Compare Other Print Info, pre and post edit
+1 NEW LN,DIFF
SET DIFF=0
+2 SET LN=0
FOR
SET LN=$ORDER(^PS(53.45,PSJSYSP,6,LN))
if 'LN!DIFF
QUIT
Begin DoDot:1
+3 IF PSJORD["V"
Begin DoDot:2
+4 IF LN=1
NEW OTOT,NTOT
SET OTOT=+$ORDER(^PS(55,DFN,"IV",+PSJORD,10,""),-1)
SET NTOT=+$ORDER(^PS(53.45,PSJSYSP,6,""),-1)
IF NTOT'=OTOT
SET DIFF=1
QUIT
+5 IF $GET(^PS(53.45,PSJSYSP,6,LN,0))'=$GET(^PS(55,DFN,"IV",+PSJORD,10,LN,0))
SET DIFF=1
End DoDot:2
+6 IF PSJORD["P"
Begin DoDot:2
+7 IF LN=1
NEW OTOT,NTOT
SET OTOT=+$ORDER(^PS(53.1,+PSJORD,16,""),-1)
SET NTOT=+$ORDER(^PS(53.45,PSJSYSP,6,""),-1)
IF NTOT'=OTOT
SET DIFF=1
QUIT
+8 IF $GET(^PS(53.45,PSJSYSP,6,LN,0))'=$GET(^PS(53.1,+PSJORD,16,LN,0))
SET DIFF=1
End DoDot:2
End DoDot:1
+9 QUIT $SELECT(DIFF:1,1:0)
+10 ;
DIFFAR(ARRAY1,ARRAY2) ; Compare two text arrays
+1 NEW LN,DIFF,OTOT,NTOT
SET DIFF=0
SET OTOT=0
SET NTOT=0
+2 SET LN=0
FOR
SET LN=$ORDER(ARRAY1(LN))
if 'LN!DIFF
QUIT
IF ARRAY1(LN,0)'=$GET(ARRAY2(LN,0))
SET DIFF=1
+3 QUIT $SELECT(DIFF:1,1:0)
+4 ;
MVOPI(DFN,PSJI1,PSJI2) ; Move OPI from Non-Verified order to Active order during Verify
+1 if '$GET(DFN)!'$GET(PSJI1)!'$GET(PSJI2)
QUIT
+2 IF PSJI1["P"
IF PSJI2["V"
DO GETOPI(DFN,PSJI1)
DO FILEOPI(DFN,PSJI2)
+3 QUIT
+4 ;
MVOPIAL(DFN,PSJI1,PSJI2) ; Move Other Print Info Activity log entries from NV order to Active order, during Verification
+1 DO MVOPIAL^PSJBCMA1(DFN,PSJI1,PSJI2)
+2 QUIT
+3 ;
KILL(USR) ; Clean up ^PS(53.45
+1 KILL ^PS(53.45,+$GET(USR),5),^PS(53.45,+$GET(USR),6)
+2 QUIT
+3 ;
PAUSE(DEF) ;
+1 KILL DIR
WRITE !
SET DIR(0)="EA"
SET DIR("A")="Press Return to continue editing "_$GET(DEF)_"..."
SET DIR("?")="Press Return to continue..."
DO ^DIR
WRITE !
+2 QUIT
+3 ;
DONE(DEF) ; -- Done editing?
+1 NEW DIR,X,Y
+2 SET DIR(0)="YA"
SET DIR("A")="Do you want to quit and discard changes"_$SELECT(($GET(DEF)]""):" to "_DEF,1:"")_"? "
SET DIR("B")="NO"
+3 SET DIR("?",1)=" Enter YES to exit without saving changes, or "
SET DIR("?")=" enter NO to continue editing "_$SELECT(($GET(DEF)]""):DEF,1:"")_"."
+4 DO ^DIR
+5 QUIT $SELECT($EXTRACT(Y)="^":1,1:+Y)
