PSBO1 ;BIRMINGHAM/EFC-BCMA OUTPUTS ;2/26/21 12:27
;;3.0;BAR CODE MED ADMIN;**4,13,32,2,43,28,70,83,103,114,106**;Mar 2004;Build 43
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
; Reference/IA
; EN^PSJBCMA/2828
;
;*70 - add ablility to update List multiple for Clinic names
;*83 - add Function GETREMOV to find removes for associated MRR Gives
;*106- add Hazardous Handle & Dispose flags
;
NEW(RESULTS,PSBRTYP) ; Create a new report request
; Called interactively and via RPCBroker
K RESULTS
; Check Type
; PSB*3*103 - added 'RT' code for Respiratory Therapy report, called from EN1+3^PSBMMRB
I '$F("DL^MD^MH^ML^MM^MV^MT^PE^PM^WA^BL^PI^AL^DO^VT^PF^XA^ST^SF^IV^CM^CP^CE^CI^BZ^RT^",PSBRTYP) S RESULTS(0)="-1^Invalid Report Type" Q
I '+$G(DUZ) S RESULTS(0)="-1^Undefined User" Q
I '$G(DUZ(2)) S RESULTS(0)="-1^Undefined Division" Q
; Lock Log
L +(^PSB(53.69,0)):$S($G(DILOCKTM)>30:DILOCKTM,1:30)
E S RESULTS(0)="-1^Request Log Locked" Q
; Generate Unique Entry and Create
F D NOW^%DTC S X=$E(%_"000000",1,14) S X=(1700+$E(X,1,3))_$E(X,4,14),X=PSBRTYP_"-"_$TR(X,".","-") Q:'$D(^PSB(53.69,"B",X))
S DIC="^PSB(53.69,",DIC(0)="L"
S DIC("DR")=".02///N;.03////^S X=DUZ;.04////^S X=DUZ(2);.05///^S X=PSBRTYP"
K DD,DO D FILE^DICN
L -(^PSB(53.69,0))
; Okay, setup return and Boogie
I +Y<1 S RESULTS(0)="-1^Error Creating Request"
E S RESULTS(0)=Y
K DO
Q
;
PRINT ;
N ZTDTH,ZTRTN,ZTSK,ZTDESC,ZTSAVE,DA
S DA=+PSBRPT(0)
S IOP=$$GET1^DIQ(53.69,DA_",",.06,"I"),PSBSIO=0 I IOP]"" D
.S IOP="`"_IOP,%ZIS="N"
.D ^%ZIS
.I IO=IO(0) S PSBSIO=1
.D HOME^%ZIS K IOP
I $$GET1^DIQ(53.69,DA_",",.06)["BROWSER"!(PSBSIO=1) S IOP=$$GET1^DIQ(53.69,DA_",",.06)_";132" D ^%ZIS U IO D DQ^PSBO(DA) D ^%ZISC K IOP Q
W @IOF,"Submitting Your Report Request to TaskMan..."
S ZTIO=$$GET1^DIQ(53.69,DA_",",.06)_";132"
S ZTDTH=$S($$GET1^DIQ(53.69,DA_",",.07,"I")]"":$$GET1^DIQ(53.69,DA_",",.07,"I"),1:$H)
S ZTDESC="BCMA - "_$$GET1^DIQ(53.69,DA_",",.05)
S ZTRTN="DQ^PSBO("_DA_")"
F I="PSBDFN","PSBTYPE" S ZTSAVE(I)=""
I $G(PSBORDNM)]"" S ZTSAVE("PSBORDNM")=""
D ^%ZTLOAD
I $D(ZTSK) S ^TMP("PSBO",$J,1)="0^Report queued. (Task #"_ZTSK_")"
E S ^TMP("PSBO",$J,1)="-1^Task Rejected."
Q
;
LIST(XLIST) ; Place List Criteria into subfile #53.692 (multiple)
F XL1=$O(XLIST("")):1:$O(XLIST("B"),-1) Q:+XL1="" D
.;*70 add"MM", "WA" rpts to accept array list of selected clinics
.; build reports that use Clinic search list array
.N PSBCLN
.F CLN="WA","DL","MM","CM","CP","CI","CE" S PSBCLN(CLN)=""
.I ($P(XLIST(XL1),U)=PSBTYPE)!($D(PSBCLN(PSBTYPE))) D
..K PSBFDA,PSBRET,PSBIENX D CLEAN^DILF
..S PSBIENX="+"_(XL1+1)_","_PSBIENS
..D VAL^DIE(53.692,"+"_(XL1+1)_","_PSBIENS,.01,"F",$TR(XLIST(XL1),"^","~"),"PSBRET","PSBFDA")
..D UPDATE^DIE("","PSBFDA","PSBIENX","PSBRET")
Q
;
CHECK ;Beginning of PSB*1*10
K ^TMP("PSJ",$J),PSBCL ;[*70-1459]
N PSBDFN,PSBBAR,PSBDRUG,PSBFLAG,PSBPNM,PSBNDX,PSBX
S PSBFLAG="",PSBBAR=$P($P($G(^PSB(53.69,DA,.3)),U,1),"~",2)
S PSBDRUG=$$GET1^DIQ(53.69,DA_",",.31)
S PSBDFN=$$GET1^DIQ(53.69,DA_",",.12,"I") S:$G(PSBDFN) PSBFLAG=1
D EN^PSJBCMA(PSBDFN)
;
F PSBX=0:0 S PSBX=$O(^TMP("PSJ",$J,PSBX)) Q:'PSBX D
.K Y,PSBORD,PSBPNM,PSBNDX
.S PSBCL=$P(^TMP("PSJ",$J,PSBX,0),U,11) ;[*70-1459]
.M PSBORD=^TMP("PSJ",$J,PSBX)
.F PSBNDX=700,850,950 D
..F Y=0:0 S Y=$O(PSBORD(PSBNDX,Y)) Q:'Y D
...I $P($G(PSBORD(1)),U,7)'="A" Q
...S PSBPNM=$P(PSBORD(PSBNDX,Y,0),U,1)
...I PSBNDX=700,PSBPNM=PSBBAR D Q ;[*70-1459]
....S PSBFLAG=0 ;[*70-1459]
....I PSBCL]"" S PSBCL(PSBCL)="" ;[*70-1459]
....E S PSBCL($$GET1^DIQ(2,$P(PSBORD(0),U),.1)_" (Ward)")="" ;[*70-1459]
...I PSBNDX=850,$D(^PSDRUG("A526",PSBBAR,PSBPNM)) D Q ;[*70-1459]
....S PSBFLAG=0 ;[*70-1459]
....I PSBCL]"" S PSBCL(PSBCL)="" ;[*70-1459]
....E S PSBCL($$GET1^DIQ(2,$P(PSBORD(0),U),.1)_" (Ward)")="" ;[*70-1459]
...I PSBNDX=950,$D(^PSDRUG("A527",PSBBAR,PSBPNM)) D Q ;[*70-1459]
....S PSBFLAG=0 ;[*70-1459]
....I PSBCL]"" S PSBCL(PSBCL)="" ;[*70-1459]
....E S PSBCL($$GET1^DIQ(2,$P(PSBORD(0),U),.1)_" (Ward)")="" ;[*70-1459]
I PSBFLAG=1 D
.W !,"Patient is not currently on medication: ",PSBDRUG
.K DIRUT,DIR
.S DIR("A")="Do you want to continue"
.S DIR(0)="Y"
.D ^DIR
.S PSBANS=+Y W !
Q
;
GETREMOV(DFN) ;Process removal type XREFS and return any RM's found with key info
N PSBGNODE,PSBIEN,DSPDRG
K ^TMP("PSB",$J,"RM")
;
;Xref APATCH search
S PSBGNODE="^PSB(53.79,"_"""APATCH"""_","_DFN_")"
F S PSBGNODE=$Q(@PSBGNODE) Q:PSBGNODE']"" Q:($QS(PSBGNODE,2)'="APATCH")!($QS(PSBGNODE,3)'=DFN) D
.S PSBIEN=$QS(PSBGNODE,5),DSPDRG=$O(^PSB(53.79,PSBIEN,.5,0)) I 'DSPDRG Q
.Q:'$D(^PSB(53.79,PSBIEN,.5,DSPDRG))
.Q:$P(^PSB(53.79,PSBIEN,.5,DSPDRG,0),U,4)'="PATCH"
.Q:$P(^PSB(53.79,PSBIEN,0),U,9)'="G"
.D SETTMP ;get remove info and save to Tmp
;
;Xref AMRR search
S PSBGNODE="^PSB(53.79,"_"""AMRR"""_","_DFN_")"
F S PSBGNODE=$Q(@PSBGNODE) Q:PSBGNODE']"" Q:($QS(PSBGNODE,2)'="AMRR")!($QS(PSBGNODE,3)'=DFN) D
.S PSBIEN=$QS(PSBGNODE,5)
.Q:'$D(^PSB(53.79,PSBIEN,.5,1))
.Q:'$P(^PSB(53.79,PSBIEN,.5,1,0),U,6)
.Q:$P(^PSB(53.79,PSBIEN,0),U,9)'="G"
.D SETTMP ;get remove info and save to Tmp
Q
;
SETTMP(IEN) ;get and set MRR info for printing
N RMDT,ONX
S RMDT=$$GET1^DIQ(53.79,PSBIEN,"SCHEDULED REMOVAL TIME","I")
S ONX=$$GET1^DIQ(53.79,PSBIEN,"ORDER REFERENCE NUMBER")
K ^TMP("PSJ1",$J) D EN^PSJBCMA1(DFN,ONX,1)
Q:$G(^TMP("PSJ1",$J,0))=-1
S $P(^TMP("PSB",$J,"RM",PSBIEN),U,1)=RMDT ;RMDT
S $P(^TMP("PSB",$J,"RM",PSBIEN),U,2)=ONX ;ONX
S $P(^TMP("PSB",$J,"RM",PSBIEN),U,3)=$P(^TMP("PSJ1",$J,2),U,2) ;OITX
S $P(^TMP("PSB",$J,"RM",PSBIEN),U,4)=$P(^TMP("PSJ1",$J,1),U,10) ;OSTS
S $P(^TMP("PSB",$J,"RM",PSBIEN),U,5)=$P(^TMP("PSJ1",$J,4),U,7) ;OSPO
S $P(^TMP("PSB",$J,"RM",PSBIEN),U,6)=$P(^TMP("PSJ1",$J,0),U,11) ;CLOR
S $P(^TMP("PSB",$J,"RM",PSBIEN),U,7)=$P(^TMP("PSJ1",$J,2),U,3) ;DOSE
S $P(^TMP("PSB",$J,"RM",PSBIEN),U,8)=$P(^TMP("PSJ1",$J,1),U,13) ;MRNM
S $P(^TMP("PSB",$J,"RM",PSBIEN),U,9)=$P(^TMP("PSJ1",$J,1),U,5) ;SM
;*106 Haz pieces
S $P(^TMP("PSB",$J,"RM",PSBIEN),U,10)=$P(^TMP("PSJ1",$J,700,1,0),U,8) ;HAZHAN
S $P(^TMP("PSB",$J,"RM",PSBIEN),U,11)=$P(^TMP("PSJ1",$J,700,1,0),U,9) ;HAZDIS
S ^TMP("PSB",$J,"RM","B",ONX,PSBIEN)="" ;ORDER NUM XREF
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBO1 6825 printed Dec 13, 2024@01:40:18 Page 2
PSBO1 ;BIRMINGHAM/EFC-BCMA OUTPUTS ;2/26/21 12:27
+1 ;;3.0;BAR CODE MED ADMIN;**4,13,32,2,43,28,70,83,103,114,106**;Mar 2004;Build 43
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; EN^PSJBCMA/2828
+6 ;
+7 ;*70 - add ablility to update List multiple for Clinic names
+8 ;*83 - add Function GETREMOV to find removes for associated MRR Gives
+9 ;*106- add Hazardous Handle & Dispose flags
+10 ;
NEW(RESULTS,PSBRTYP) ; Create a new report request
+1 ; Called interactively and via RPCBroker
+2 KILL RESULTS
+3 ; Check Type
+4 ; PSB*3*103 - added 'RT' code for Respiratory Therapy report, called from EN1+3^PSBMMRB
+5 IF '$FIND("DL^MD^MH^ML^MM^MV^MT^PE^PM^WA^BL^PI^AL^DO^VT^PF^XA^ST^SF^IV^CM^CP^CE^CI^BZ^RT^",PSBRTYP)
SET RESULTS(0)="-1^Invalid Report Type"
QUIT
+6 IF '+$GET(DUZ)
SET RESULTS(0)="-1^Undefined User"
QUIT
+7 IF '$GET(DUZ(2))
SET RESULTS(0)="-1^Undefined Division"
QUIT
+8 ; Lock Log
+9 LOCK +(^PSB(53.69,0)):$SELECT($GET(DILOCKTM)>30:DILOCKTM,1:30)
+10 IF '$TEST
SET RESULTS(0)="-1^Request Log Locked"
QUIT
+11 ; Generate Unique Entry and Create
+12 FOR
DO NOW^%DTC
SET X=$EXTRACT(%_"000000",1,14)
SET X=(1700+$EXTRACT(X,1,3))_$EXTRACT(X,4,14)
SET X=PSBRTYP_"-"_$TRANSLATE(X,".","-")
if '$DATA(^PSB(53.69,"B",X))
QUIT
+13 SET DIC="^PSB(53.69,"
SET DIC(0)="L"
+14 SET DIC("DR")=".02///N;.03////^S X=DUZ;.04////^S X=DUZ(2);.05///^S X=PSBRTYP"
+15 KILL DD,DO
DO FILE^DICN
+16 LOCK -(^PSB(53.69,0))
+17 ; Okay, setup return and Boogie
+18 IF +Y<1
SET RESULTS(0)="-1^Error Creating Request"
+19 IF '$TEST
SET RESULTS(0)=Y
+20 KILL DO
+21 QUIT
+22 ;
PRINT ;
+1 NEW ZTDTH,ZTRTN,ZTSK,ZTDESC,ZTSAVE,DA
+2 SET DA=+PSBRPT(0)
+3 SET IOP=$$GET1^DIQ(53.69,DA_",",.06,"I")
SET PSBSIO=0
IF IOP]""
Begin DoDot:1
+4 SET IOP="`"_IOP
SET %ZIS="N"
+5 DO ^%ZIS
+6 IF IO=IO(0)
SET PSBSIO=1
+7 DO HOME^%ZIS
KILL IOP
End DoDot:1
+8 IF $$GET1^DIQ(53.69,DA_",",.06)["BROWSER"!(PSBSIO=1)
SET IOP=$$GET1^DIQ(53.69,DA_",",.06)_";132"
DO ^%ZIS
USE IO
DO DQ^PSBO(DA)
DO ^%ZISC
KILL IOP
QUIT
+9 WRITE @IOF,"Submitting Your Report Request to TaskMan..."
+10 SET ZTIO=$$GET1^DIQ(53.69,DA_",",.06)_";132"
+11 SET ZTDTH=$SELECT($$GET1^DIQ(53.69,DA_",",.07,"I")]"":$$GET1^DIQ(53.69,DA_",",.07,"I"),1:$HOROLOG)
+12 SET ZTDESC="BCMA - "_$$GET1^DIQ(53.69,DA_",",.05)
+13 SET ZTRTN="DQ^PSBO("_DA_")"
+14 FOR I="PSBDFN","PSBTYPE"
SET ZTSAVE(I)=""
+15 IF $GET(PSBORDNM)]""
SET ZTSAVE("PSBORDNM")=""
+16 DO ^%ZTLOAD
+17 IF $DATA(ZTSK)
SET ^TMP("PSBO",$JOB,1)="0^Report queued. (Task #"_ZTSK_")"
+18 IF '$TEST
SET ^TMP("PSBO",$JOB,1)="-1^Task Rejected."
+19 QUIT
+20 ;
LIST(XLIST) ; Place List Criteria into subfile #53.692 (multiple)
+1 FOR XL1=$ORDER(XLIST("")):1:$ORDER(XLIST("B"),-1)
if +XL1=""
QUIT
Begin DoDot:1
+2 ;*70 add"MM", "WA" rpts to accept array list of selected clinics
+3 ; build reports that use Clinic search list array
+4 NEW PSBCLN
+5 FOR CLN="WA","DL","MM","CM","CP","CI","CE"
SET PSBCLN(CLN)=""
+6 IF ($PIECE(XLIST(XL1),U)=PSBTYPE)!($DATA(PSBCLN(PSBTYPE)))
Begin DoDot:2
+7 KILL PSBFDA,PSBRET,PSBIENX
DO CLEAN^DILF
+8 SET PSBIENX="+"_(XL1+1)_","_PSBIENS
+9 DO VAL^DIE(53.692,"+"_(XL1+1)_","_PSBIENS,.01,"F",$TRANSLATE(XLIST(XL1),"^","~"),"PSBRET","PSBFDA")
+10 DO UPDATE^DIE("","PSBFDA","PSBIENX","PSBRET")
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
CHECK ;Beginning of PSB*1*10
+1 ;[*70-1459]
KILL ^TMP("PSJ",$JOB),PSBCL
+2 NEW PSBDFN,PSBBAR,PSBDRUG,PSBFLAG,PSBPNM,PSBNDX,PSBX
+3 SET PSBFLAG=""
SET PSBBAR=$PIECE($PIECE($GET(^PSB(53.69,DA,.3)),U,1),"~",2)
+4 SET PSBDRUG=$$GET1^DIQ(53.69,DA_",",.31)
+5 SET PSBDFN=$$GET1^DIQ(53.69,DA_",",.12,"I")
if $GET(PSBDFN)
SET PSBFLAG=1
+6 DO EN^PSJBCMA(PSBDFN)
+7 ;
+8 FOR PSBX=0:0
SET PSBX=$ORDER(^TMP("PSJ",$JOB,PSBX))
if 'PSBX
QUIT
Begin DoDot:1
+9 KILL Y,PSBORD,PSBPNM,PSBNDX
+10 ;[*70-1459]
SET PSBCL=$PIECE(^TMP("PSJ",$JOB,PSBX,0),U,11)
+11 MERGE PSBORD=^TMP("PSJ",$JOB,PSBX)
+12 FOR PSBNDX=700,850,950
Begin DoDot:2
+13 FOR Y=0:0
SET Y=$ORDER(PSBORD(PSBNDX,Y))
if 'Y
QUIT
Begin DoDot:3
+14 IF $PIECE($GET(PSBORD(1)),U,7)'="A"
QUIT
+15 SET PSBPNM=$PIECE(PSBORD(PSBNDX,Y,0),U,1)
+16 ;[*70-1459]
IF PSBNDX=700
IF PSBPNM=PSBBAR
Begin DoDot:4
+17 ;[*70-1459]
SET PSBFLAG=0
+18 ;[*70-1459]
IF PSBCL]""
SET PSBCL(PSBCL)=""
+19 ;[*70-1459]
IF '$TEST
SET PSBCL($$GET1^DIQ(2,$PIECE(PSBORD(0),U),.1)_" (Ward)")=""
End DoDot:4
QUIT
+20 ;[*70-1459]
IF PSBNDX=850
IF $DATA(^PSDRUG("A526",PSBBAR,PSBPNM))
Begin DoDot:4
+21 ;[*70-1459]
SET PSBFLAG=0
+22 ;[*70-1459]
IF PSBCL]""
SET PSBCL(PSBCL)=""
+23 ;[*70-1459]
IF '$TEST
SET PSBCL($$GET1^DIQ(2,$PIECE(PSBORD(0),U),.1)_" (Ward)")=""
End DoDot:4
QUIT
+24 ;[*70-1459]
IF PSBNDX=950
IF $DATA(^PSDRUG("A527",PSBBAR,PSBPNM))
Begin DoDot:4
+25 ;[*70-1459]
SET PSBFLAG=0
+26 ;[*70-1459]
IF PSBCL]""
SET PSBCL(PSBCL)=""
+27 ;[*70-1459]
IF '$TEST
SET PSBCL($$GET1^DIQ(2,$PIECE(PSBORD(0),U),.1)_" (Ward)")=""
End DoDot:4
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+28 IF PSBFLAG=1
Begin DoDot:1
+29 WRITE !,"Patient is not currently on medication: ",PSBDRUG
+30 KILL DIRUT,DIR
+31 SET DIR("A")="Do you want to continue"
+32 SET DIR(0)="Y"
+33 DO ^DIR
+34 SET PSBANS=+Y
WRITE !
End DoDot:1
+35 QUIT
+36 ;
GETREMOV(DFN) ;Process removal type XREFS and return any RM's found with key info
+1 NEW PSBGNODE,PSBIEN,DSPDRG
+2 KILL ^TMP("PSB",$JOB,"RM")
+3 ;
+4 ;Xref APATCH search
+5 SET PSBGNODE="^PSB(53.79,"_"""APATCH"""_","_DFN_")"
+6 FOR
SET PSBGNODE=$QUERY(@PSBGNODE)
if PSBGNODE']""
QUIT
if ($QSUBSCRIPT(PSBGNODE,2)'="APATCH")!($QSUBSCRIPT(PSBGNODE,3)'=DFN)
QUIT
Begin DoDot:1
+7 SET PSBIEN=$QSUBSCRIPT(PSBGNODE,5)
SET DSPDRG=$ORDER(^PSB(53.79,PSBIEN,.5,0))
IF 'DSPDRG
QUIT
+8 if '$DATA(^PSB(53.79,PSBIEN,.5,DSPDRG))
QUIT
+9 if $PIECE(^PSB(53.79,PSBIEN,.5,DSPDRG,0),U,4)'="PATCH"
QUIT
+10 if $PIECE(^PSB(53.79,PSBIEN,0),U,9)'="G"
QUIT
+11 ;get remove info and save to Tmp
DO SETTMP
End DoDot:1
+12 ;
+13 ;Xref AMRR search
+14 SET PSBGNODE="^PSB(53.79,"_"""AMRR"""_","_DFN_")"
+15 FOR
SET PSBGNODE=$QUERY(@PSBGNODE)
if PSBGNODE']""
QUIT
if ($QSUBSCRIPT(PSBGNODE,2)'="AMRR")!($QSUBSCRIPT(PSBGNODE,3)'=DFN)
QUIT
Begin DoDot:1
+16 SET PSBIEN=$QSUBSCRIPT(PSBGNODE,5)
+17 if '$DATA(^PSB(53.79,PSBIEN,.5,1))
QUIT
+18 if '$PIECE(^PSB(53.79,PSBIEN,.5,1,0),U,6)
QUIT
+19 if $PIECE(^PSB(53.79,PSBIEN,0),U,9)'="G"
QUIT
+20 ;get remove info and save to Tmp
DO SETTMP
End DoDot:1
+21 QUIT
+22 ;
SETTMP(IEN) ;get and set MRR info for printing
+1 NEW RMDT,ONX
+2 SET RMDT=$$GET1^DIQ(53.79,PSBIEN,"SCHEDULED REMOVAL TIME","I")
+3 SET ONX=$$GET1^DIQ(53.79,PSBIEN,"ORDER REFERENCE NUMBER")
+4 KILL ^TMP("PSJ1",$JOB)
DO EN^PSJBCMA1(DFN,ONX,1)
+5 if $GET(^TMP("PSJ1",$JOB,0))=-1
QUIT
+6 ;RMDT
SET $PIECE(^TMP("PSB",$JOB,"RM",PSBIEN),U,1)=RMDT
+7 ;ONX
SET $PIECE(^TMP("PSB",$JOB,"RM",PSBIEN),U,2)=ONX
+8 ;OITX
SET $PIECE(^TMP("PSB",$JOB,"RM",PSBIEN),U,3)=$PIECE(^TMP("PSJ1",$JOB,2),U,2)
+9 ;OSTS
SET $PIECE(^TMP("PSB",$JOB,"RM",PSBIEN),U,4)=$PIECE(^TMP("PSJ1",$JOB,1),U,10)
+10 ;OSPO
SET $PIECE(^TMP("PSB",$JOB,"RM",PSBIEN),U,5)=$PIECE(^TMP("PSJ1",$JOB,4),U,7)
+11 ;CLOR
SET $PIECE(^TMP("PSB",$JOB,"RM",PSBIEN),U,6)=$PIECE(^TMP("PSJ1",$JOB,0),U,11)
+12 ;DOSE
SET $PIECE(^TMP("PSB",$JOB,"RM",PSBIEN),U,7)=$PIECE(^TMP("PSJ1",$JOB,2),U,3)
+13 ;MRNM
SET $PIECE(^TMP("PSB",$JOB,"RM",PSBIEN),U,8)=$PIECE(^TMP("PSJ1",$JOB,1),U,13)
+14 ;SM
SET $PIECE(^TMP("PSB",$JOB,"RM",PSBIEN),U,9)=$PIECE(^TMP("PSJ1",$JOB,1),U,5)
+15 ;*106 Haz pieces
+16 ;HAZHAN
SET $PIECE(^TMP("PSB",$JOB,"RM",PSBIEN),U,10)=$PIECE(^TMP("PSJ1",$JOB,700,1,0),U,8)
+17 ;HAZDIS
SET $PIECE(^TMP("PSB",$JOB,"RM",PSBIEN),U,11)=$PIECE(^TMP("PSJ1",$JOB,700,1,0),U,9)
+18 ;ORDER NUM XREF
SET ^TMP("PSB",$JOB,"RM","B",ONX,PSBIEN)=""
+19 QUIT
