- PSBML3 ;BIRMINGHAM/TEJ-BCMA UTILITY TO EDIT THE PSB MED LOG ;Mar 2004
- ;;3.0;BAR CODE MED ADMIN;**3,13,39,41**;Mar 2004;Build 1
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ; Reference/IA
- ; $$GET1^DIQ/2056
- ;
- 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
- I PSBREC(2)'=$$GET1^DIQ(53.79,PSBEDIEN,.16,"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 PSBDATAX=PSBREC(PSBRECNX) K PSBORDMD(PSBRECNX),PSBREC2(PSBRECNX) S (PSBFIND(PSBRECNX,PSBXX),PSBFOUN(PSBDDX,PSBXX))=1 Q
- ....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)
- .....I PSBDATAX=PSBREC(PSBREC2X) 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
- ;
- PSBML3 ;BIRMINGHAM/TEJ-BCMA UTILITY TO EDIT THE PSB MED LOG ;Mar 2004
- +1 ;;3.0;BAR CODE MED ADMIN;**3,13,39,41**;Mar 2004;Build 1
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ; Reference/IA
- +5 ; $$GET1^DIQ/2056
- +6 ;
- 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 IF PSBREC(2)'=$$GET1^DIQ(53.79,PSBEDIEN,.16,"I")
- SET PSBREC(2,0)=1
- SET PSBCHNG=1
- +5 IF PSBREC(4)'=$$GET1^DIQ(53.79,PSBEDIEN,.06,"I")
- SET PSBREC(4,0)=$$GET1^DIQ(53.79,PSBEDIEN,.06,"I")
- SET PSBCHNG=1
- +6 IF PSBREC(5)'=$$GET1^DIQ(53.79,PSBEDIEN,.21)
- SET PSBREC(5,0)=1
- SET PSBCHNG=1
- +7 IF PSBREC(6)'=$$GET1^DIQ(53.79,PSBEDIEN,.22)
- SET PSBREC(6,0)=1
- SET PSBCHNG=1
- +8 KILL PSBFIND,PSBFOUN,PSBREC2
- +9 FOR PSBRECNX=8:1
- IF '$DATA(PSBREC(PSBRECNX))
- QUIT
- SET PSBDPTR=$PIECE(PSBREC(PSBRECNX),U,2)
- SET PSBORDMD(PSBRECNX,PSBDPTR,0)="ADDED"
- +10 FOR PSBDDX=.5,.6,.7
- IF $DATA(^PSB(53.79,+PSBEDIEN,PSBDDX,"B"))
- Begin DoDot:1
- +11 SET PSBDPTR=""
- FOR
- SET PSBDPTR=$ORDER(^PSB(53.79,+PSBEDIEN,PSBDDX,"B",PSBDPTR))
- IF +PSBDPTR'>0
- QUIT
- Begin DoDot:2
- +12 SET PSBXX=0
- FOR
- SET PSBXX=$ORDER(^PSB(53.79,+PSBEDIEN,PSBDDX,"B",PSBDPTR,PSBXX))
- IF +PSBXX'>0
- QUIT
- Begin DoDot:3
- +13 IF '$DATA(PSBFOUN(PSBDDX,PSBXX))
- FOR PSBRECNX=8:1
- IF '$DATA(PSBREC(PSBRECNX))
- QUIT
- IF $DATA(PSBORDMD(PSBRECNX))
- Begin DoDot:4
- +14 SET PSBDFDA=$PIECE(PSBREC(PSBRECNX),U)
- IF $SELECT(PSBDFDA="DD"
- QUIT
- +15 SET PSBDATAX=PSBDFDA_"^"_$GET(^PSB(53.79,+PSBEDIEN,PSBDDX,PSBXX,0))_$SELECT(PSBDDX'=.5:"^",1:"")
- +16 IF $PIECE(PSBDATAX,U,3)?1"."1.N
- SET $PIECE(PSBDATAX,U,3)=0_+$PIECE(PSBDATAX,U,3)
- +17 IF $PIECE(PSBDATAX,U,4)?1"."1.N
- SET $PIECE(PSBDATAX,U,4)=0_+$PIECE(PSBDATAX,U,4)
- +18 IF PSBDATAX=PSBREC(PSBRECNX)
- KILL PSBORDMD(PSBRECNX),PSBREC2(PSBRECNX)
- SET (PSBFIND(PSBRECNX,PSBXX),PSBFOUN(PSBDDX,PSBXX))=1
- QUIT
- +19 SET PSBUNTOR=$PIECE(PSBDATAX,U,3)
- SET PSBUNTGN=$PIECE(PSBDATAX,U,4)
- SET PSBUNTAD=$PIECE(PSBDATAX,U,5)
- +20 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
- +21 IF $DATA(PSBREC2)
- Begin DoDot:1
- +22 FOR PSBDDX=.5,.6,.7
- IF $DATA(^PSB(53.79,+PSBEDIEN,PSBDDX,"B"))
- Begin DoDot:2
- +23 SET PSBDPTR=""
- FOR
- SET PSBDPTR=$ORDER(^PSB(53.79,+PSBEDIEN,PSBDDX,"B",PSBDPTR))
- IF +PSBDPTR'>0
- QUIT
- Begin DoDot:3
- +24 SET PSBXX=0
- FOR
- SET PSBXX=$ORDER(^PSB(53.79,+PSBEDIEN,PSBDDX,"B",PSBDPTR,PSBXX))
- IF +PSBXX'>0
- QUIT
- Begin DoDot:4
- +25 SET PSBREC2X=0
- FOR
- SET PSBREC2X=$ORDER(PSBREC2(PSBREC2X))
- IF PSBREC2X=""
- QUIT
- Begin DoDot:5
- +26 SET PSBDFDA=$PIECE(PSBREC(PSBREC2X),U)
- IF $SELECT(PSBDFDA="DD"
- QUIT
- +27 SET PSBDATAX=PSBDFDA_"^"_$GET(^PSB(53.79,+PSBEDIEN,PSBDDX,PSBXX,0))
- +28 IF $PIECE(PSBDATAX,U,3)?1"."1.N
- SET $PIECE(PSBDATAX,U,3)=0_+$PIECE(PSBDATAX,U,3)
- +29 IF $PIECE(PSBDATAX,U,4)?1"."1.N
- SET $PIECE(PSBDATAX,U,4)=0_+$PIECE(PSBDATAX,U,4)
- +30 IF PSBDATAX=PSBREC(PSBREC2X)
- KILL PSBREC2(PSBREC2X),PSBORDMD(PSBREC2X)
- SET (PSBFIND(PSBREC2X,PSBXX),PSBFOUN(PSBDDX,PSBXX))=1
- QUIT
- +31 SET PSBUNTOR=$PIECE(PSBDATAX,U,3)
- SET PSBUNTGN=$PIECE(PSBDATAX,U,4)
- SET PSBUNTAD=$PIECE(PSBDATAX,U,5)
- +32 IF PSBREC2(PSBREC2X)[(PSBDFDA_"^"_PSBDPTR_"^"_PSBUNTOR_"^")
- IF '$DATA(PSBFOUN(PSBDDX,PSBXX))
- SET (PSBCHNG,PSBFIND(PSBREC2X,PSBXX),PSBFOUN(PSBDDX,PSBXX))=1
- Begin DoDot:6
- +33 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
- +34 ; Modify FDA per Deleted DDs
- +35 ;
- +36 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
- +37 SET PSBDDX=$SELECT(PSBX=.5:53.795,PSBX=.6:53.796,1:53.797)
- +38 SET PSBIENX="^PSB(53.79,"_($GET(PSBEDIEN))_($GET(PSBX))_",""B"","_PSBXX_")"
- +39 SET PSBIENX=$QUERY(@PSBIENX)
- SET PSBIENX=$QSUBSCRIPT(PSBIENX,6)_","_(+PSBEDIEN)
- +40 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
- +41 ;
- +42 IF $DATA(PSBORDMD)
- SET PSBCHNG=1
- KILL PSBREC2
- +43 QUIT PSBCHNG
- +44 ;
- 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 ;
