- 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)