- 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 Jan 18, 2025@02:41:32 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