PSBML3 ;BIRMINGHAM/TEJ-BCMA UTILITY TO EDIT THE PSB MED LOG ;03/06/16 3:06pm
;;3.0;BAR CODE MED ADMIN;**3,13,39,41,70,83**;Mar 2004;Build 89
;Per VHA Directive 2004-038, this routine should not be modified.
;
; Reference/IA
; $$GET1^DIQ/2056
;
;*70 - fix Tag CHANGE to compare the DD, Add, & Sol multiples for
; only the first 5 pieces and ignore the HR flag new 6th piece.
; example of pieces 1-5: "DD^363^1^3^TAB"
; Edit Medlog function in BCMA uses this compare to control
; Audit entries for the DD, Add, & Sol multiples & Edit Medlog
; updates.
;*83 - check if body site is Inj or Derm & compare to correct field
;
APATCH ; Maintain "APATCH" index...
I $G(PSBTRAN)["MEDPASS" D:$P(PSBREC(9),U)="UDTAB" Q
.S PSBX1=9,PSBQUT=0 F S PSBX1=$O(PSBREC(PSBX1)) Q:PSBQUT Q:'(+PSBX1) D:$P(PSBREC(PSBX1),U)="DD"&($P(PSBREC(PSBX1),U,5)="PATCH") Q:PSBQUT
..I $G(PSBOLSTS)="",PSBREC(3)="G" S PSB1="I $D(PSBIEN(1)) S ^PSB(53.79,""APATCH"","_$G(PSBREC(0))_","_$G(PSBNOW)_",+PSBIEN(1))="""""
..S PSBQUT=1
S PSBX1=0 F S PSBX1=$O(^PSB(53.79,+PSBIEN,.5,PSBX1)) Q:'(+PSBX1) Q
I $G(PSBTRAN)["UPDATE",(+PSBX1)'=0 D
.S PSBX3=0 F S PSBX3=$O(^PSB(53.79,+PSBIEN,.5,PSBX3)) Q:+PSBX3=0 I $P(^PSB(53.79,+PSBIEN,.5,PSBX3,0),U,4)="PATCH" D
..I PSBOLSTS="G",PSBREC(0)="N" S PSB1="K ^PSB(53.79,""APATCH"","_$P(^PSB(53.79,+PSBIEN,0),U)_","_$P(^PSB(53.79,+PSBIEN,0),U,6)_","_+PSBIEN_")"
..I PSBFDA(53.79,+PSBIEN_",",.09)="G" S PSB1="S ^PSB(53.79,""APATCH"","_$P(^PSB(53.79,+PSBIEN,0),U)_","_$G(PSBFDA(53.79,+PSBIEN_",",.06))_","_+PSBIEN_")"_"="""""
I $G(PSBTRAN)["EDIT",(+PSBX1)'=0 D
.S PSBX3=0 F S PSBX3=$O(^PSB(53.79,+PSBIEN,.5,PSBX3)) Q:+PSBX3=0 I $P(^PSB(53.79,+PSBIEN,.5,PSBX3,0),U,4)="PATCH",((PSBREC(0)="G")!(PSBREC(0)="RM")) D
..S PSB1="S ^PSB(53.79,""APATCH"","_$P(^PSB(53.79,+PSBIEN,0),U)_","_$G(PSBFDA(53.79,+PSBIEN_",",.06))_","_+PSBIEN_")"_"="""""
..I $D(PSBREC(4,0)) S PSB2="K ^PSB(53.79,""APATCH"","_$P(^PSB(53.79,+PSBIEN,0),U)_","_$G(PSBREC(4,0))_","_+PSBIEN_")"
Q
;
CHANGE(PSBREC,PSBEDIEN) ;Determine an order edit
S PSBCHNG=0
K PSBORDMD,PSBDDX
I PSBREC(0)'=$$GET1^DIQ(53.79,PSBEDIEN,.09,"I") S PSBREC(0,0)=1,PSBCHNG=1
D:PSBREC(2)'["|D" ;*83
.I $P(PSBREC(2),"|")'=$$GET1^DIQ(53.79,PSBEDIEN,.16,"I") S PSBREC(2,0)=1,PSBCHNG=1
D:PSBREC(2)["|D" ;*83
.I $P(PSBREC(2),"|")'=$$GET1^DIQ(53.79,PSBEDIEN,.18,"I") S PSBREC(2,0)=1,PSBCHNG=1
I PSBREC(4)'=$$GET1^DIQ(53.79,PSBEDIEN,.06,"I") S PSBREC(4,0)=$$GET1^DIQ(53.79,PSBEDIEN,.06,"I"),PSBCHNG=1
I PSBREC(5)'=$$GET1^DIQ(53.79,PSBEDIEN,.21) S PSBREC(5,0)=1,PSBCHNG=1
I PSBREC(6)'=$$GET1^DIQ(53.79,PSBEDIEN,.22) S PSBREC(6,0)=1,PSBCHNG=1
K PSBFIND,PSBFOUN,PSBREC2
F PSBRECNX=8:1 Q:'$D(PSBREC(PSBRECNX)) S PSBDPTR=$P(PSBREC(PSBRECNX),U,2),PSBORDMD(PSBRECNX,PSBDPTR,0)="ADDED"
F PSBDDX=.5,.6,.7 D:$D(^PSB(53.79,+PSBEDIEN,PSBDDX,"B"))
.S PSBDPTR="" F S PSBDPTR=$O(^PSB(53.79,+PSBEDIEN,PSBDDX,"B",PSBDPTR)) Q:+PSBDPTR'>0 D
..S PSBXX=0 F S PSBXX=$O(^PSB(53.79,+PSBEDIEN,PSBDDX,"B",PSBDPTR,PSBXX)) Q:+PSBXX'>0 D Q:'$$FINDDD^PSBML3(PSBDDX,PSBDPTR)
...I '$D(PSBFOUN(PSBDDX,PSBXX)) F PSBRECNX=8:1 Q:'$D(PSBREC(PSBRECNX)) D:$D(PSBORDMD(PSBRECNX)) Q:$D(PSBFOUN(PSBDDX,PSBXX))
....S PSBDFDA=$P(PSBREC(PSBRECNX),U) Q:$S(PSBDFDA="DD":.5,PSBDFDA="ADD":.6,PSBDFDA="SOL":.7)'=PSBDDX
....S PSBDATAX=PSBDFDA_"^"_$G(^PSB(53.79,+PSBEDIEN,PSBDDX,PSBXX,0))_$S(PSBDDX'=.5:"^",1:"")
....S:$P(PSBDATAX,U,3)?1"."1.N $P(PSBDATAX,U,3)=0_+$P(PSBDATAX,U,3)
....S:$P(PSBDATAX,U,4)?1"."1.N $P(PSBDATAX,U,4)=0_+$P(PSBDATAX,U,4)
....I $P(PSBDATAX,U,1,5)=$P(PSBREC(PSBRECNX),U,1,5) K PSBORDMD(PSBRECNX),PSBREC2(PSBRECNX) S (PSBFIND(PSBRECNX,PSBXX),PSBFOUN(PSBDDX,PSBXX))=1 Q ;only compare 1-5 pieces for a change *83
....S PSBUNTOR=$P(PSBDATAX,U,3),PSBUNTGN=$P(PSBDATAX,U,4),PSBUNTAD=$P(PSBDATAX,U,5)
....I PSBREC(PSBRECNX)[(PSBDFDA_"^"_PSBDPTR_"^"_PSBUNTOR_"^") S PSBREC2(PSBRECNX)=PSBREC(PSBRECNX)
D:$D(PSBREC2)
.F PSBDDX=.5,.6,.7 D:$D(^PSB(53.79,+PSBEDIEN,PSBDDX,"B"))
..S PSBDPTR="" F S PSBDPTR=$O(^PSB(53.79,+PSBEDIEN,PSBDDX,"B",PSBDPTR)) Q:+PSBDPTR'>0 D
...S PSBXX=0 F S PSBXX=$O(^PSB(53.79,+PSBEDIEN,PSBDDX,"B",PSBDPTR,PSBXX)) Q:+PSBXX'>0 D
....S PSBREC2X=0 F S PSBREC2X=$O(PSBREC2(PSBREC2X)) Q:PSBREC2X="" D Q:$G(PSBFOUN(PSBDDX,PSBXX))
.....S PSBDFDA=$P(PSBREC(PSBREC2X),U) Q:$S(PSBDFDA="DD":.5,PSBDFDA="ADD":.6,PSBDFDA="SOL":.7)'=PSBDDX
.....S PSBDATAX=PSBDFDA_"^"_$G(^PSB(53.79,+PSBEDIEN,PSBDDX,PSBXX,0))
.....S:$P(PSBDATAX,U,3)?1"."1.N $P(PSBDATAX,U,3)=0_+$P(PSBDATAX,U,3)
.....S:$P(PSBDATAX,U,4)?1"."1.N $P(PSBDATAX,U,4)=0_+$P(PSBDATAX,U,4)
.....; *70 compare only first 5 pieces ignoring the new HR piece
.....I $P(PSBDATAX,U,1,5)=$P(PSBREC(PSBREC2X),U,1,5) K PSBREC2(PSBREC2X),PSBORDMD(PSBREC2X) S (PSBFIND(PSBREC2X,PSBXX),PSBFOUN(PSBDDX,PSBXX))=1 Q
.....S PSBUNTOR=$P(PSBDATAX,U,3),PSBUNTGN=$P(PSBDATAX,U,4),PSBUNTAD=$P(PSBDATAX,U,5)
.....I PSBREC2(PSBREC2X)[(PSBDFDA_"^"_PSBDPTR_"^"_PSBUNTOR_"^") I '$D(PSBFOUN(PSBDDX,PSBXX)) S (PSBCHNG,PSBFIND(PSBREC2X,PSBXX),PSBFOUN(PSBDDX,PSBXX))=1 D Q
......N PSBY,Y F Y=4,5 S PSBY=$P(PSBREC2(PSBREC2X),U,Y) S:PSBY'=$S(Y=4:PSBUNTGN,Y=5:PSBUNTAD) PSBORDMD(PSBREC2X,PSBDPTR,0)=""
; Modify FDA per Deleted DDs
;
F PSBX=.5,.6,.7 S PSBXX="" F Q:'$D(PSBORDMD(PSBX)) S PSBXX=$O(PSBORDMD(PSBX,PSBXX)) Q:$G(PSBXX)="" D:PSBORDMD(PSBX,PSBXX,0)["DELETE"
.S PSBDDX=$S(PSBX=.5:53.795,PSBX=.6:53.796,1:53.797)
.S PSBIENX="^PSB(53.79,"_($G(PSBEDIEN))_($G(PSBX))_",""B"","_PSBXX_")"
.S PSBIENX=$Q(@PSBIENX),PSBIENX=$QS(PSBIENX,6)_","_(+PSBEDIEN)
.D:'$D(PSBFOUN(PSBDDX,+PSBIENX)) VAL^PSBML(PSBDDX,PSBIENX,.01,""),VAL^PSBML(PSBDDX,PSBIENX,.02,""),VAL^PSBML(PSBDDX,PSBIENX,.03,""),VAL^PSBML(PSBDDX,PSBIENX,.04,"")
;
S:$D(PSBORDMD) PSBCHNG=1 K PSBREC2
Q PSBCHNG
;
NGRESET(PSBREC,PSBREIEN) ;
;
; Acknowledged "UNDO" - reinstate previous status and state...
;
I (PSBREC(0)="N")&($$GET1^DIQ(53.79,PSBREIEN,.09,"I")="N") D I '$D(PSBQUITX) S PSBREINT=$$GET1^DIQ(53.79,PSBREIEN,.05,"I")
.S PSBRESET="NOT GIVEN",PSBX="B" K PSBQUITX,PSBREXDT,PSBREINT F S PSBX=$O(^PSB(53.79,+PSBREIEN,.9,PSBX),-1) Q:PSBX'>0 D Q:($G(PSBQUITX))!(PSBX'>0)
..I (^PSB(53.79,+PSBREIEN,.9,PSBX,0)'["ACTION STATUS Set to") Q
..I $P(^PSB(53.79,+PSBREIEN,.9,PSBX,0),U,4)=PSBRESET D Q:$G(PSBQUITX) Q:PSBX'>0
...S PSBREXDT=$P(^PSB(53.79,+PSBREIEN,.9,PSBX,0),U)
...F S PSBX=$O(^PSB(53.79,+PSBREIEN,.9,PSBX),-1) Q:PSBX'>0 D Q:$G(PSBQUITX)
....I (^PSB(53.79,+PSBREIEN,.9,PSBX,0)'["ACTION STATUS")!(^PSB(53.79,+PSBREIEN,.9,PSBX,0)'["deleted") Q
....I $P(^PSB(53.79,+PSBREIEN,.9,PSBX,0),"'",2)'="GIVEN" Q
....F S PSBX=$O(^PSB(53.79,+PSBREIEN,.9,PSBX),-1) Q:(PSBX'>0)!($G(PSBQUITX)) D Q:$G(PSBQUIT)
.....I (^PSB(53.79,+PSBREIEN,.9,PSBX,0)'["ACTION STATUS ")!(^PSB(53.79,+PSBREIEN,.9,PSBX,0)'["deleted") Q
.....S PSBRESET=$P(^PSB(53.79,+PSBREIEN,.9,PSBX,0),"'",2) I (PSBRESET="GIVEN")!(PSBRESET="REMOVED") Q
.....S PSBREXDT=$$GET1^DIQ(53.79,PSBREIEN,.04,"I"),PSBX=PSBX-2 I '$D(^PSB(53.79,+PSBREIEN,.9,PSBX,0)) S PSBQUIT=1 Q
.....I (^PSB(53.79,+PSBREIEN,.9,PSBX,0)'["ACTION DATE/TIME")!(^PSB(53.79,+PSBREIEN,.9,PSBX,0)'["deleted") S PSBQUIT=1 Q
.....S PSBREXDT=$P(^PSB(53.79,+PSBREIEN,.9,PSBX,0),"'",2),X=$P(PSBREXDT,"@"),%DT="" D ^%DT S PSBREXDT=Y_"."_$TR($P(PSBREXDT,"@",2),":"),PSBQUIT=1
I $D(PSBREINT),$D(PSBREXDT),($D(PSBRESET)&($G(PSBRESET)'="GIVEN")) D
.D VAL^PSBML(53.79,PSBREIEN,.06,PSBREXDT)
.D VAL^PSBML(53.79,PSBREIEN,.09,PSBRESET)
.D:$D(PSBREINT) VAL^PSBML(53.79,PSBREIEN,.07,"`"_PSBREINT)
.D:'$G(PSBERR) FILEIT^PSBML
K PSBXXX,PSBRESET,PSBREXDT,PSBREINT,PSBQUITX
Q
;
FINDDD(PSBDDXX,PSBDDPTR) ;
;
; Determine if edit - 'change' is deleted DDrug
;
S FINDDD=0
I $D(PSBREC(8)) D
.F PSBINDX=8:1 Q:'$D(PSBREC(PSBINDX)) S PSBCOMPX=$G(PSBREC(PSBINDX)) D Q:FINDDD
..I ($S(PSBDDXX=.5:"DD",PSBDDXX=.6:"ADD",PSBDDXX=.7:"SOL",1:"")=$P(PSBCOMPX,U)),(PSBDDPTR=$P(PSBCOMPX,U,2)) S FINDDD=1
I 'FINDDD S PSBORDMD(PSBDDXX,PSBDDPTR,0)="DELETED"
Q FINDDD
;
AMRR ; Maintain "AMRR" index...
I $G(PSBTRAN)["UPDATE",(+PSBX1)'=0 D
.S PSBX3=0 F S PSBX3=$O(^PSB(53.79,+PSBIEN,.5,PSBX3)) Q:+PSBX3=0 I $P(^PSB(53.79,+PSBIEN,.5,PSBX3,0),U,6)>0 D
..I PSBOLSTS="G",PSBREC(0)="N" S PSB1A="K ^PSB(53.79,""AMRR"","_$P(^PSB(53.79,+PSBIEN,0),U)_","_$P(^PSB(53.79,+PSBIEN,0),U,6)_","_+PSBIEN_")"
..I PSBFDA(53.79,+PSBIEN_",",.09)="G" S PSB1A="S ^PSB(53.79,""AMRR"","_$P(^PSB(53.79,+PSBIEN,0),U)_","_$G(PSBFDA(53.79,+PSBIEN_",",.06))_","_+PSBIEN_")"_"="""""
;
I $G(PSBTRAN)["EDIT",(+PSBX1)'=0 D
.S PSBX3=0 F S PSBX3=$O(^PSB(53.79,+PSBIEN,.5,PSBX3)) Q:+PSBX3=0 I $P(^PSB(53.79,+PSBIEN,.5,PSBX3,0),U,6)>0,((PSBREC(0)="G")!(PSBREC(0)="RM")) D
..S PSB1A="S ^PSB(53.79,""AMRR"","_$P(^PSB(53.79,+PSBIEN,0),U)_","_$G(PSBFDA(53.79,+PSBIEN_",",.06))_","_+PSBIEN_")"_"="""""
..I $D(PSBREC(4,0)) S PSB2A="K ^PSB(53.79,""AMRR"","_$P(^PSB(53.79,+PSBIEN,0),U)_","_$G(PSBREC(4,0))_","_+PSBIEN_")"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBML3 9060 printed Dec 13, 2024@01:40:08 Page 2
PSBML3 ;BIRMINGHAM/TEJ-BCMA UTILITY TO EDIT THE PSB MED LOG ;03/06/16 3:06pm
+1 ;;3.0;BAR CODE MED ADMIN;**3,13,39,41,70,83**;Mar 2004;Build 89
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; $$GET1^DIQ/2056
+6 ;
+7 ;*70 - fix Tag CHANGE to compare the DD, Add, & Sol multiples for
+8 ; only the first 5 pieces and ignore the HR flag new 6th piece.
+9 ; example of pieces 1-5: "DD^363^1^3^TAB"
+10 ; Edit Medlog function in BCMA uses this compare to control
+11 ; Audit entries for the DD, Add, & Sol multiples & Edit Medlog
+12 ; updates.
+13 ;*83 - check if body site is Inj or Derm & compare to correct field
+14 ;
APATCH ; Maintain "APATCH" index...
+1 IF $GET(PSBTRAN)["MEDPASS"
if $PIECE(PSBREC(9),U)="UDTAB"
Begin DoDot:1
+2 SET PSBX1=9
SET PSBQUT=0
FOR
SET PSBX1=$ORDER(PSBREC(PSBX1))
if PSBQUT
QUIT
if '(+PSBX1)
QUIT
if $PIECE(PSBREC(PSBX1),U)="DD"&($PIECE(PSBREC(PSBX1),U,5)="PATCH")
Begin DoDot:2
+3 IF $GET(PSBOLSTS)=""
IF PSBREC(3)="G"
SET PSB1="I $D(PSBIEN(1)) S ^PSB(53.79,""APATCH"","_$GET(PSBREC(0))_","_$GET(PSBNOW)_",+PSBIEN(1))="""""
+4 SET PSBQUT=1
End DoDot:2
if PSBQUT
QUIT
End DoDot:1
QUIT
+5 SET PSBX1=0
FOR
SET PSBX1=$ORDER(^PSB(53.79,+PSBIEN,.5,PSBX1))
if '(+PSBX1)
QUIT
QUIT
+6 IF $GET(PSBTRAN)["UPDATE"
IF (+PSBX1)'=0
Begin DoDot:1
+7 SET PSBX3=0
FOR
SET PSBX3=$ORDER(^PSB(53.79,+PSBIEN,.5,PSBX3))
if +PSBX3=0
QUIT
IF $PIECE(^PSB(53.79,+PSBIEN,.5,PSBX3,0),U,4)="PATCH"
Begin DoDot:2
+8 IF PSBOLSTS="G"
IF PSBREC(0)="N"
SET PSB1="K ^PSB(53.79,""APATCH"","_$PIECE(^PSB(53.79,+PSBIEN,0),U)_","_$PIECE(^PSB(53.79,+PSBIEN,0),U,6)_","_+PSBIEN_")"
+9 IF PSBFDA(53.79,+PSBIEN_",",.09)="G"
SET PSB1="S ^PSB(53.79,""APATCH"","_$PIECE(^PSB(53.79,+PSBIEN,0),U)_","_$GET(PSBFDA(53.79,+PSBIEN_",",.06))_","_+PSBIEN_")"_"="""""
End DoDot:2
End DoDot:1
+10 IF $GET(PSBTRAN)["EDIT"
IF (+PSBX1)'=0
Begin DoDot:1
+11 SET PSBX3=0
FOR
SET PSBX3=$ORDER(^PSB(53.79,+PSBIEN,.5,PSBX3))
if +PSBX3=0
QUIT
IF $PIECE(^PSB(53.79,+PSBIEN,.5,PSBX3,0),U,4)="PATCH"
IF ((PSBREC(0)="G")!(PSBREC(0)="RM"))
Begin DoDot:2
+12 SET PSB1="S ^PSB(53.79,""APATCH"","_$PIECE(^PSB(53.79,+PSBIEN,0),U)_","_$GET(PSBFDA(53.79,+PSBIEN_",",.06))_","_+PSBIEN_")"_"="""""
+13 IF $DATA(PSBREC(4,0))
SET PSB2="K ^PSB(53.79,""APATCH"","_$PIECE(^PSB(53.79,+PSBIEN,0),U)_","_$GET(PSBREC(4,0))_","_+PSBIEN_")"
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
CHANGE(PSBREC,PSBEDIEN) ;Determine an order edit
+1 SET PSBCHNG=0
+2 KILL PSBORDMD,PSBDDX
+3 IF PSBREC(0)'=$$GET1^DIQ(53.79,PSBEDIEN,.09,"I")
SET PSBREC(0,0)=1
SET PSBCHNG=1
+4 ;*83
if PSBREC(2)'["|D"
Begin DoDot:1
+5 IF $PIECE(PSBREC(2),"|")'=$$GET1^DIQ(53.79,PSBEDIEN,.16,"I")
SET PSBREC(2,0)=1
SET PSBCHNG=1
End DoDot:1
+6 ;*83
if PSBREC(2)["|D"
Begin DoDot:1
+7 IF $PIECE(PSBREC(2),"|")'=$$GET1^DIQ(53.79,PSBEDIEN,.18,"I")
SET PSBREC(2,0)=1
SET PSBCHNG=1
End DoDot:1
+8 IF PSBREC(4)'=$$GET1^DIQ(53.79,PSBEDIEN,.06,"I")
SET PSBREC(4,0)=$$GET1^DIQ(53.79,PSBEDIEN,.06,"I")
SET PSBCHNG=1
+9 IF PSBREC(5)'=$$GET1^DIQ(53.79,PSBEDIEN,.21)
SET PSBREC(5,0)=1
SET PSBCHNG=1
+10 IF PSBREC(6)'=$$GET1^DIQ(53.79,PSBEDIEN,.22)
SET PSBREC(6,0)=1
SET PSBCHNG=1
+11 KILL PSBFIND,PSBFOUN,PSBREC2
+12 FOR PSBRECNX=8:1
if '$DATA(PSBREC(PSBRECNX))
QUIT
SET PSBDPTR=$PIECE(PSBREC(PSBRECNX),U,2)
SET PSBORDMD(PSBRECNX,PSBDPTR,0)="ADDED"
+13 FOR PSBDDX=.5,.6,.7
if $DATA(^PSB(53.79,+PSBEDIEN,PSBDDX,"B"))
Begin DoDot:1
+14 SET PSBDPTR=""
FOR
SET PSBDPTR=$ORDER(^PSB(53.79,+PSBEDIEN,PSBDDX,"B",PSBDPTR))
if +PSBDPTR'>0
QUIT
Begin DoDot:2
+15 SET PSBXX=0
FOR
SET PSBXX=$ORDER(^PSB(53.79,+PSBEDIEN,PSBDDX,"B",PSBDPTR,PSBXX))
if +PSBXX'>0
QUIT
Begin DoDot:3
+16 IF '$DATA(PSBFOUN(PSBDDX,PSBXX))
FOR PSBRECNX=8:1
if '$DATA(PSBREC(PSBRECNX))
QUIT
if $DATA(PSBORDMD(PSBRECNX))
Begin DoDot:4
+17 SET PSBDFDA=$PIECE(PSBREC(PSBRECNX),U)
if $SELECT(PSBDFDA="DD"
QUIT
+18 SET PSBDATAX=PSBDFDA_"^"_$GET(^PSB(53.79,+PSBEDIEN,PSBDDX,PSBXX,0))_$SELECT(PSBDDX'=.5:"^",1:"")
+19 if $PIECE(PSBDATAX,U,3)?1"."1.N
SET $PIECE(PSBDATAX,U,3)=0_+$PIECE(PSBDATAX,U,3)
+20 if $PIECE(PSBDATAX,U,4)?1"."1.N
SET $PIECE(PSBDATAX,U,4)=0_+$PIECE(PSBDATAX,U,4)
+21 ;only compare 1-5 pieces for a change *83
IF $PIECE(PSBDATAX,U,1,5)=$PIECE(PSBREC(PSBRECNX),U,1,5)
KILL PSBORDMD(PSBRECNX),PSBREC2(PSBRECNX)
SET (PSBFIND(PSBRECNX,PSBXX),PSBFOUN(PSBDDX,PSBXX))=1
QUIT
+22 SET PSBUNTOR=$PIECE(PSBDATAX,U,3)
SET PSBUNTGN=$PIECE(PSBDATAX,U,4)
SET PSBUNTAD=$PIECE(PSBDATAX,U,5)
+23 IF PSBREC(PSBRECNX)[(PSBDFDA_"^"_PSBDPTR_"^"_PSBUNTOR_"^")
SET PSBREC2(PSBRECNX)=PSBREC(PSBRECNX)
End DoDot:4
if $DATA(PSBFOUN(PSBDDX,PSBXX))
QUIT
End DoDot:3
if '$$FINDDD^PSBML3(PSBDDX,PSBDPTR)
QUIT
End DoDot:2
End DoDot:1
+24 if $DATA(PSBREC2)
Begin DoDot:1
+25 FOR PSBDDX=.5,.6,.7
if $DATA(^PSB(53.79,+PSBEDIEN,PSBDDX,"B"))
Begin DoDot:2
+26 SET PSBDPTR=""
FOR
SET PSBDPTR=$ORDER(^PSB(53.79,+PSBEDIEN,PSBDDX,"B",PSBDPTR))
if +PSBDPTR'>0
QUIT
Begin DoDot:3
+27 SET PSBXX=0
FOR
SET PSBXX=$ORDER(^PSB(53.79,+PSBEDIEN,PSBDDX,"B",PSBDPTR,PSBXX))
if +PSBXX'>0
QUIT
Begin DoDot:4
+28 SET PSBREC2X=0
FOR
SET PSBREC2X=$ORDER(PSBREC2(PSBREC2X))
if PSBREC2X=""
QUIT
Begin DoDot:5
+29 SET PSBDFDA=$PIECE(PSBREC(PSBREC2X),U)
if $SELECT(PSBDFDA="DD"
QUIT
+30 SET PSBDATAX=PSBDFDA_"^"_$GET(^PSB(53.79,+PSBEDIEN,PSBDDX,PSBXX,0))
+31 if $PIECE(PSBDATAX,U,3)?1"."1.N
SET $PIECE(PSBDATAX,U,3)=0_+$PIECE(PSBDATAX,U,3)
+32 if $PIECE(PSBDATAX,U,4)?1"."1.N
SET $PIECE(PSBDATAX,U,4)=0_+$PIECE(PSBDATAX,U,4)
+33 ; *70 compare only first 5 pieces ignoring the new HR piece
+34 IF $PIECE(PSBDATAX,U,1,5)=$PIECE(PSBREC(PSBREC2X),U,1,5)
KILL PSBREC2(PSBREC2X),PSBORDMD(PSBREC2X)
SET (PSBFIND(PSBREC2X,PSBXX),PSBFOUN(PSBDDX,PSBXX))=1
QUIT
+35 SET PSBUNTOR=$PIECE(PSBDATAX,U,3)
SET PSBUNTGN=$PIECE(PSBDATAX,U,4)
SET PSBUNTAD=$PIECE(PSBDATAX,U,5)
+36 IF PSBREC2(PSBREC2X)[(PSBDFDA_"^"_PSBDPTR_"^"_PSBUNTOR_"^")
IF '$DATA(PSBFOUN(PSBDDX,PSBXX))
SET (PSBCHNG,PSBFIND(PSBREC2X,PSBXX),PSBFOUN(PSBDDX,PSBXX))=1
Begin DoDot:6
+37 NEW PSBY,Y
FOR Y=4,5
SET PSBY=$PIECE(PSBREC2(PSBREC2X),U,Y)
if PSBY'=$SELECT(Y=4
SET PSBORDMD(PSBREC2X,PSBDPTR,0)=""
End DoDot:6
QUIT
End DoDot:5
if $GET(PSBFOUN(PSBDDX,PSBXX))
QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+38 ; Modify FDA per Deleted DDs
+39 ;
+40 FOR PSBX=.5,.6,.7
SET PSBXX=""
FOR
if '$DATA(PSBORDMD(PSBX))
QUIT
SET PSBXX=$ORDER(PSBORDMD(PSBX,PSBXX))
if $GET(PSBXX)=""
QUIT
if PSBORDMD(PSBX,PSBXX,0)["DELETE"
Begin DoDot:1
+41 SET PSBDDX=$SELECT(PSBX=.5:53.795,PSBX=.6:53.796,1:53.797)
+42 SET PSBIENX="^PSB(53.79,"_($GET(PSBEDIEN))_($GET(PSBX))_",""B"","_PSBXX_")"
+43 SET PSBIENX=$QUERY(@PSBIENX)
SET PSBIENX=$QSUBSCRIPT(PSBIENX,6)_","_(+PSBEDIEN)
+44 if '$DATA(PSBFOUN(PSBDDX,+PSBIENX))
DO VAL^PSBML(PSBDDX,PSBIENX,.01,"")
DO VAL^PSBML(PSBDDX,PSBIENX,.02,"")
DO VAL^PSBML(PSBDDX,PSBIENX,.03,"")
DO VAL^PSBML(PSBDDX,PSBIENX,.04,"")
End DoDot:1
+45 ;
+46 if $DATA(PSBORDMD)
SET PSBCHNG=1
KILL PSBREC2
+47 QUIT PSBCHNG
+48 ;
NGRESET(PSBREC,PSBREIEN) ;
+1 ;
+2 ; Acknowledged "UNDO" - reinstate previous status and state...
+3 ;
+4 IF (PSBREC(0)="N")&($$GET1^DIQ(53.79,PSBREIEN,.09,"I")="N")
Begin DoDot:1
+5 SET PSBRESET="NOT GIVEN"
SET PSBX="B"
KILL PSBQUITX,PSBREXDT,PSBREINT
FOR
SET PSBX=$ORDER(^PSB(53.79,+PSBREIEN,.9,PSBX),-1)
if PSBX'>0
QUIT
Begin DoDot:2
+6 IF (^PSB(53.79,+PSBREIEN,.9,PSBX,0)'["ACTION STATUS Set to")
QUIT
+7 IF $PIECE(^PSB(53.79,+PSBREIEN,.9,PSBX,0),U,4)=PSBRESET
Begin DoDot:3
+8 SET PSBREXDT=$PIECE(^PSB(53.79,+PSBREIEN,.9,PSBX,0),U)
+9 FOR
SET PSBX=$ORDER(^PSB(53.79,+PSBREIEN,.9,PSBX),-1)
if PSBX'>0
QUIT
Begin DoDot:4
+10 IF (^PSB(53.79,+PSBREIEN,.9,PSBX,0)'["ACTION STATUS")!(^PSB(53.79,+PSBREIEN,.9,PSBX,0)'["deleted")
QUIT
+11 IF $PIECE(^PSB(53.79,+PSBREIEN,.9,PSBX,0),"'",2)'="GIVEN"
QUIT
+12 FOR
SET PSBX=$ORDER(^PSB(53.79,+PSBREIEN,.9,PSBX),-1)
if (PSBX'>0)!($GET(PSBQUITX))
QUIT
Begin DoDot:5
+13 IF (^PSB(53.79,+PSBREIEN,.9,PSBX,0)'["ACTION STATUS ")!(^PSB(53.79,+PSBREIEN,.9,PSBX,0)'["deleted")
QUIT
+14 SET PSBRESET=$PIECE(^PSB(53.79,+PSBREIEN,.9,PSBX,0),"'",2)
IF (PSBRESET="GIVEN")!(PSBRESET="REMOVED")
QUIT
+15 SET PSBREXDT=$$GET1^DIQ(53.79,PSBREIEN,.04,"I")
SET PSBX=PSBX-2
IF '$DATA(^PSB(53.79,+PSBREIEN,.9,PSBX,0))
SET PSBQUIT=1
QUIT
+16 IF (^PSB(53.79,+PSBREIEN,.9,PSBX,0)'["ACTION DATE/TIME")!(^PSB(53.79,+PSBREIEN,.9,PSBX,0)'["deleted")
SET PSBQUIT=1
QUIT
+17 SET PSBREXDT=$PIECE(^PSB(53.79,+PSBREIEN,.9,PSBX,0),"'",2)
SET X=$PIECE(PSBREXDT,"@")
SET %DT=""
DO ^%DT
SET PSBREXDT=Y_"."_$TRANSLATE($PIECE(PSBREXDT,"@",2),":")
SET PSBQUIT=1
End DoDot:5
if $GET(PSBQUIT)
QUIT
End DoDot:4
if $GET(PSBQUITX)
QUIT
End DoDot:3
if $GET(PSBQUITX)
QUIT
if PSBX'>0
QUIT
End DoDot:2
if ($GET(PSBQUITX))!(PSBX'>0)
QUIT
End DoDot:1
IF '$DATA(PSBQUITX)
SET PSBREINT=$$GET1^DIQ(53.79,PSBREIEN,.05,"I")
+18 IF $DATA(PSBREINT)
IF $DATA(PSBREXDT)
IF ($DATA(PSBRESET)&($GET(PSBRESET)'="GIVEN"))
Begin DoDot:1
+19 DO VAL^PSBML(53.79,PSBREIEN,.06,PSBREXDT)
+20 DO VAL^PSBML(53.79,PSBREIEN,.09,PSBRESET)
+21 if $DATA(PSBREINT)
DO VAL^PSBML(53.79,PSBREIEN,.07,"`"_PSBREINT)
+22 if '$GET(PSBERR)
DO FILEIT^PSBML
End DoDot:1
+23 KILL PSBXXX,PSBRESET,PSBREXDT,PSBREINT,PSBQUITX
+24 QUIT
+25 ;
FINDDD(PSBDDXX,PSBDDPTR) ;
+1 ;
+2 ; Determine if edit - 'change' is deleted DDrug
+3 ;
+4 SET FINDDD=0
+5 IF $DATA(PSBREC(8))
Begin DoDot:1
+6 FOR PSBINDX=8:1
if '$DATA(PSBREC(PSBINDX))
QUIT
SET PSBCOMPX=$GET(PSBREC(PSBINDX))
Begin DoDot:2
+7 IF ($SELECT(PSBDDXX=.5:"DD",PSBDDXX=.6:"ADD",PSBDDXX=.7:"SOL",1:"")=$PIECE(PSBCOMPX,U))
IF (PSBDDPTR=$PIECE(PSBCOMPX,U,2))
SET FINDDD=1
End DoDot:2
if FINDDD
QUIT
End DoDot:1
+8 IF 'FINDDD
SET PSBORDMD(PSBDDXX,PSBDDPTR,0)="DELETED"
+9 QUIT FINDDD
+10 ;
AMRR ; Maintain "AMRR" index...
+1 IF $GET(PSBTRAN)["UPDATE"
IF (+PSBX1)'=0
Begin DoDot:1
+2 SET PSBX3=0
FOR
SET PSBX3=$ORDER(^PSB(53.79,+PSBIEN,.5,PSBX3))
if +PSBX3=0
QUIT
IF $PIECE(^PSB(53.79,+PSBIEN,.5,PSBX3,0),U,6)>0
Begin DoDot:2
+3 IF PSBOLSTS="G"
IF PSBREC(0)="N"
SET PSB1A="K ^PSB(53.79,""AMRR"","_$PIECE(^PSB(53.79,+PSBIEN,0),U)_","_$PIECE(^PSB(53.79,+PSBIEN,0),U,6)_","_+PSBIEN_")"
+4 IF PSBFDA(53.79,+PSBIEN_",",.09)="G"
SET PSB1A="S ^PSB(53.79,""AMRR"","_$PIECE(^PSB(53.79,+PSBIEN,0),U)_","_$GET(PSBFDA(53.79,+PSBIEN_",",.06))_","_+PSBIEN_")"_"="""""
End DoDot:2
End DoDot:1
+5 ;
+6 IF $GET(PSBTRAN)["EDIT"
IF (+PSBX1)'=0
Begin DoDot:1
+7 SET PSBX3=0
FOR
SET PSBX3=$ORDER(^PSB(53.79,+PSBIEN,.5,PSBX3))
if +PSBX3=0
QUIT
IF $PIECE(^PSB(53.79,+PSBIEN,.5,PSBX3,0),U,6)>0
IF ((PSBREC(0)="G")!(PSBREC(0)="RM"))
Begin DoDot:2
+8 SET PSB1A="S ^PSB(53.79,""AMRR"","_$PIECE(^PSB(53.79,+PSBIEN,0),U)_","_$GET(PSBFDA(53.79,+PSBIEN_",",.06))_","_+PSBIEN_")"_"="""""
+9 IF $DATA(PSBREC(4,0))
SET PSB2A="K ^PSB(53.79,""AMRR"","_$PIECE(^PSB(53.79,+PSBIEN,0),U)_","_$GET(PSBREC(4,0))_","_+PSBIEN_")"
End DoDot:2
End DoDot:1
+10 QUIT
