- PSBVDLPA ;BIRMINGHAM/EFC-BCMA UNIT DOSE VIRTUAL DUE LIST FUNCTIONS;03/06/16 3:06pm ;5/20/21 15:37
- ;;3.0;BAR CODE MED ADMIN;**5,16,13,38,32,58,70,83,114,106**;Mar 2004;Build 43
- ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
- ;
- ; called by PSBVDLUD to find patches not removed
- ;
- ; Reference/IA
- ; $$GET^XPAR/2263
- ; $$FMADD^XLFDT/10103
- ; GETPROVL^PSGSICH1/5653
- ; INTRDIC^PSGSICH1/5654
- ; PHARMACY OI file #(50.7)/2180
- ;
- ;*58 - add 29th piece to Results for Override/Intervention flag 1/0
- ;*70 - add 30th piece for consistency with psbvdlud routine.
- ; - add 32nd piece for clinic name for CO meds and a patch.
- ; - add 33rd piece to Results for Clinic ien ptr to file #44
- ;*83 - add 34th & 35th piece to Results. Remove flag & Remove time
- ;*106- add Hazardous to Handle & Dispose flags 36 & 37
- ;
- EN ;Search the Medlog file for patches that were Given and not Removed.
- ; Place these meds into the return Results array.
- ;
- N PSBGNODE,PSBIEN,PSBXDTI,PSBXXDTI,PSBZON,X,Y,PSBPBK,DSPDRG ;*83
- 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)
- .S DSPDRG=$O(^PSB(53.79,PSBIEN,.5,0)) I 'DSPDRG Q
- .I $P(^PSB(53.79,PSBIEN,.5,DSPDRG,0),U,4)'="PATCH" Q
- .I "G"'[$P(^PSB(53.79,PSBIEN,0),U,9)!($D(PSBONVDL(PSBIEN))) Q
- .S PSBZON=$P(^PSB(53.79,PSBIEN,.1),"^")
- .D CLEAN^PSBVT
- .D PSJ1^PSBVT(DFN,PSBZON) Q:$G(PSBSCRT)=-1
- .;
- .S PSBPBK=+($$GET^XPAR("DIV","PSB VDL PATCH DAYS"))
- .I PSBPBK D NOW^%DTC I ($$FMADD^XLFDT($P(PSBOSP,"."),(PSBPBK))<X) Q
- .S $P(PSBREC,U,1)=DFN ; dfn
- .S $P(PSBREC,U,2)=PSBONX ; order numer
- .S $P(PSBREC,U,3)=PSBON ; order ien
- .S $P(PSBREC,U,4)="U" ; order type U unit dose
- .S $P(PSBREC,U,5)=PSBSCHT
- .S $P(PSBREC,U,6)=PSBSCH
- .S $P(PSBREC,U,7)=$S(PSBHSM:"HSM",PSBSM:"SM",1:"")
- .S $P(PSBREC,U,8)=PSBOITX
- .S $P(PSBREC,U,9)=PSBDOSE
- .S $P(PSBREC,U,10)=PSBMR
- .S:$D(PSBHSTAX(PSBOIT)) $P(PSBREC,U,11)=$O(PSBHSTAX(PSBOIT,""),-1),$P(PSBREC,U,20)=$O(PSBHSTAX(PSBOIT,$P(PSBREC,U,11),""),-1)
- .D:'$D(PSBHSTAX(PSBOIT))
- ..N PSBX,PSBY,PSBDONE S PSBDONE=0,PSBX="" F S PSBX=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,PSBX),-1) Q:PSBX="" D:'PSBDONE
- ...S PSBY="" F S PSBY=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,PSBX,PSBY),-1) Q:PSBY="" D:'PSBDONE
- ....S:$P(^PSB(53.79,PSBY,0),U,9)'="N" $P(PSBREC,U,20)=$P(^PSB(53.79,PSBY,0),U,9) S:($P(PSBREC,U,20)'="N")&($P(PSBREC,U,20)]"") $P(PSBREC,U,11)=PSBX,PSBDONE=1
- .S $P(PSBREC,U,12)=PSBIEN
- .S $P(PSBREC,U,13)="G"
- .S $P(PSBREC,U,14)=$P(^PSB(53.79,PSBIEN,.1),U,3)
- .I $P(PSBREC,U,14)="" S $P(PSBREC,U,14)=PSBNOW\1
- .S $P(PSBREC,U,15)=PSBOIT
- .D:($G(PSBTAB)="CVRSHT")!($G(PSBTAB)="UDTAB")
- ..S $P(PSBREC,U,16)=PSBNJECT ;always send this flag *70
- ..I $P(PSBREC,U,9)?1.4N1"-"1.4N.E S $P(PSBREC,U,17)=1
- ..E S $P(PSBREC,U,17)=0
- ..S $P(PSBREC,U,19)=$S(PSBVNI]"":PSBVNI,PSBVNI']"":"***")
- ..S $P(PSBREC,U,23)=""
- ..S $P(PSBREC,U,26)=PSBOSP
- ..S $P(PSBREC,U,27)=$$LASTG^PSBCSUTL($P(PSBREC,U),$P(PSBREC,U,15))
- ..S $P(PSBREC,U,28)=0
- ..I ($G(PSBTAB)="CVRSHT") S $P(PSBREC,U,28)=1
- ..I ($G(PSBTAB)="UDTAB") I PSBSCHT'="O" S:(PSBOSTS="E")!(PSBOSTS["D") $P(PSBREC,U,28)=1
- ..;*58 determine if override or intervn exists, send 1/0 (true/false)
- ..N PSBARR D GETPROVL^PSGSICH1(DFN,PSBONX,.PSBARR)
- ..I $O(PSBARR(""))="" D INTRDIC^PSGSICH1(DFN,PSBONX,.PSBARR,2)
- ..S $P(PSBREC,U,29)=$S($O(PSBARR(""))]"":1,1:0)
- ..;add last site *70/*83
- ..S $P(PSBREC,U,30)=$$LASTSITE^PSBINJEC(DFN,PSBOIT) ;*83
- ..; piece 31 special IVPB use in vdl's not for coversheet
- ..I $G(PSBTAB)="CVRSHT" D ;If from coversheet use offset -1 *70
- ...S $P(PSBREC,U,31)=$G(PSBCLORD) ;clinic name
- ...S $P(PSBREC,U,32)=$G(PSBCLIEN) ;clinic ien ptr
- ..I $G(PSBTAB)="UDTAB" D ;Else must be Unit does VDL calling
- ...S $P(PSBREC,U,32)=$G(PSBCLORD) ;clinic name
- ...S $P(PSBREC,U,33)=$G(PSBCLIEN) ;clinic ien ptr
- ...S $P(PSBREC,U,35)=$P(^PSB(53.79,PSBIEN,.1),U,7) ;existing RM time
- ..; piece 34-35 reserved for Remove meds and set by PSBVDLU1
- ..S $P(PSBREC,U,36)=$G(PSBHAZHN) ;Hazardous to Handle *106
- ..S $P(PSBREC,U,37)=$G(PSBHAZDS) ;Hazardous to Dispose *106
- ..;
- ..; Place into Coversheet activity ARRAY
- ..S PSBDIDX="" I $D(^PSB(53.79,"AORD",DFN,PSBONX)) D
- ...S PSBXDTI="",PSBXDTI=$O(^PSB(53.79,"AORD",DFN,PSBONX,PSBXDTI),-1)
- ...Q:'$D(^PSB(53.79,"AORD",DFN,PSBONX,PSBXDTI,PSBIEN))
- ...S PSBADMX(PSBONX,PSBXDTI,PSBIEN)="",PSBDIDX=1
- ..I ('PSBDIDX)&$D(^PSB(53.79,"AORDX",DFN,PSBONX)) D
- ...S PSBXXDTI="",PSBXXDTI=$O(^PSB(53.79,"AORDX",DFN,PSBONX,PSBXXDTI),-1)
- ...Q:'$D(^PSB(53.79,"AORDX",DFN,PSBONX,PSBXXDTI,PSBIEN))
- ...S PSBADMX(PSBONX,PSBXXDTI,PSBIEN)=""
- .S $P(PSBREC,U,18)="PATCH"
- .S $P(PSBREC,U,21)=PSBOST
- .S $P(PSBREC,U,22)=PSBOSTS
- .S PSBDDS="" F Y=0:0 S Y=$O(PSBDDA(Y)) Q:'Y S:$P(PSBDDA(Y),U,4)="" $P(PSBDDA(Y),U,4)=1 S PSBDDS=PSBDDS_U_$P(PSBDDA(Y),U,1,4),$P(PSBDDS,U,1)=PSBDDS+1
- .S PSBQRR=1
- .; *83 Api below now calcs & adds MRR code & Remove time to (34,35)
- .D ADD^PSBVDLU1(PSBREC,PSBOTXT,$P(PSBREC,U,14),PSBDDS,"","",$S($G(PSBTAB)="CVRSHT":"CVRSHT",1:"UDTAB"))
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBVDLPA 5351 printed Feb 18, 2025@23:07:40 Page 2
- PSBVDLPA ;BIRMINGHAM/EFC-BCMA UNIT DOSE VIRTUAL DUE LIST FUNCTIONS;03/06/16 3:06pm ;5/20/21 15:37
- +1 ;;3.0;BAR CODE MED ADMIN;**5,16,13,38,32,58,70,83,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 ; called by PSBVDLUD to find patches not removed
- +5 ;
- +6 ; Reference/IA
- +7 ; $$GET^XPAR/2263
- +8 ; $$FMADD^XLFDT/10103
- +9 ; GETPROVL^PSGSICH1/5653
- +10 ; INTRDIC^PSGSICH1/5654
- +11 ; PHARMACY OI file #(50.7)/2180
- +12 ;
- +13 ;*58 - add 29th piece to Results for Override/Intervention flag 1/0
- +14 ;*70 - add 30th piece for consistency with psbvdlud routine.
- +15 ; - add 32nd piece for clinic name for CO meds and a patch.
- +16 ; - add 33rd piece to Results for Clinic ien ptr to file #44
- +17 ;*83 - add 34th & 35th piece to Results. Remove flag & Remove time
- +18 ;*106- add Hazardous to Handle & Dispose flags 36 & 37
- +19 ;
- EN ;Search the Medlog file for patches that were Given and not Removed.
- +1 ; Place these meds into the return Results array.
- +2 ;
- +3 ;*83
- NEW PSBGNODE,PSBIEN,PSBXDTI,PSBXXDTI,PSBZON,X,Y,PSBPBK,DSPDRG
- +4 SET PSBGNODE="^PSB(53.79,"_"""APATCH"""_","_DFN_")"
- +5 FOR
- SET PSBGNODE=$QUERY(@PSBGNODE)
- if PSBGNODE']""
- QUIT
- if ($QSUBSCRIPT(PSBGNODE,2)'="APATCH")!($QSUBSCRIPT(PSBGNODE,3)'=DFN)
- QUIT
- Begin DoDot:1
- +6 SET PSBIEN=$QSUBSCRIPT(PSBGNODE,5)
- +7 SET DSPDRG=$ORDER(^PSB(53.79,PSBIEN,.5,0))
- IF 'DSPDRG
- QUIT
- +8 IF $PIECE(^PSB(53.79,PSBIEN,.5,DSPDRG,0),U,4)'="PATCH"
- QUIT
- +9 IF "G"'[$PIECE(^PSB(53.79,PSBIEN,0),U,9)!($DATA(PSBONVDL(PSBIEN)))
- QUIT
- +10 SET PSBZON=$PIECE(^PSB(53.79,PSBIEN,.1),"^")
- +11 DO CLEAN^PSBVT
- +12 DO PSJ1^PSBVT(DFN,PSBZON)
- if $GET(PSBSCRT)=-1
- QUIT
- +13 ;
- +14 SET PSBPBK=+($$GET^XPAR("DIV","PSB VDL PATCH DAYS"))
- +15 IF PSBPBK
- DO NOW^%DTC
- IF ($$FMADD^XLFDT($PIECE(PSBOSP,"."),(PSBPBK))<X)
- QUIT
- +16 ; dfn
- SET $PIECE(PSBREC,U,1)=DFN
- +17 ; order numer
- SET $PIECE(PSBREC,U,2)=PSBONX
- +18 ; order ien
- SET $PIECE(PSBREC,U,3)=PSBON
- +19 ; order type U unit dose
- SET $PIECE(PSBREC,U,4)="U"
- +20 SET $PIECE(PSBREC,U,5)=PSBSCHT
- +21 SET $PIECE(PSBREC,U,6)=PSBSCH
- +22 SET $PIECE(PSBREC,U,7)=$SELECT(PSBHSM:"HSM",PSBSM:"SM",1:"")
- +23 SET $PIECE(PSBREC,U,8)=PSBOITX
- +24 SET $PIECE(PSBREC,U,9)=PSBDOSE
- +25 SET $PIECE(PSBREC,U,10)=PSBMR
- +26 if $DATA(PSBHSTAX(PSBOIT))
- SET $PIECE(PSBREC,U,11)=$ORDER(PSBHSTAX(PSBOIT,""),-1)
- SET $PIECE(PSBREC,U,20)=$ORDER(PSBHSTAX(PSBOIT,$PIECE(PSBREC,U,11),""),-1)
- +27 if '$DATA(PSBHSTAX(PSBOIT))
- Begin DoDot:2
- +28 NEW PSBX,PSBY,PSBDONE
- SET PSBDONE=0
- SET PSBX=""
- FOR
- SET PSBX=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,PSBX),-1)
- if PSBX=""
- QUIT
- if 'PSBDONE
- Begin DoDot:3
- +29 SET PSBY=""
- FOR
- SET PSBY=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,PSBX,PSBY),-1)
- if PSBY=""
- QUIT
- if 'PSBDONE
- Begin DoDot:4
- +30 if $PIECE(^PSB(53.79,PSBY,0),U,9)'="N"
- SET $PIECE(PSBREC,U,20)=$PIECE(^PSB(53.79,PSBY,0),U,9)
- if ($PIECE(PSBREC,U,20)'="N")&($PIECE(PSBREC,U,20)]"")
- SET $PIECE(PSBREC,U,11)=PSBX
- SET PSBDONE=1
- End DoDot:4
- End DoDot:3
- End DoDot:2
- +31 SET $PIECE(PSBREC,U,12)=PSBIEN
- +32 SET $PIECE(PSBREC,U,13)="G"
- +33 SET $PIECE(PSBREC,U,14)=$PIECE(^PSB(53.79,PSBIEN,.1),U,3)
- +34 IF $PIECE(PSBREC,U,14)=""
- SET $PIECE(PSBREC,U,14)=PSBNOW\1
- +35 SET $PIECE(PSBREC,U,15)=PSBOIT
- +36 if ($GET(PSBTAB)="CVRSHT")!($GET(PSBTAB)="UDTAB")
- Begin DoDot:2
- +37 ;always send this flag *70
- SET $PIECE(PSBREC,U,16)=PSBNJECT
- +38 IF $PIECE(PSBREC,U,9)?1.4N1"-"1.4N.E
- SET $PIECE(PSBREC,U,17)=1
- +39 IF '$TEST
- SET $PIECE(PSBREC,U,17)=0
- +40 SET $PIECE(PSBREC,U,19)=$SELECT(PSBVNI]"":PSBVNI,PSBVNI']"":"***")
- +41 SET $PIECE(PSBREC,U,23)=""
- +42 SET $PIECE(PSBREC,U,26)=PSBOSP
- +43 SET $PIECE(PSBREC,U,27)=$$LASTG^PSBCSUTL($PIECE(PSBREC,U),$PIECE(PSBREC,U,15))
- +44 SET $PIECE(PSBREC,U,28)=0
- +45 IF ($GET(PSBTAB)="CVRSHT")
- SET $PIECE(PSBREC,U,28)=1
- +46 IF ($GET(PSBTAB)="UDTAB")
- IF PSBSCHT'="O"
- if (PSBOSTS="E")!(PSBOSTS["D")
- SET $PIECE(PSBREC,U,28)=1
- +47 ;*58 determine if override or intervn exists, send 1/0 (true/false)
- +48 NEW PSBARR
- DO GETPROVL^PSGSICH1(DFN,PSBONX,.PSBARR)
- +49 IF $ORDER(PSBARR(""))=""
- DO INTRDIC^PSGSICH1(DFN,PSBONX,.PSBARR,2)
- +50 SET $PIECE(PSBREC,U,29)=$SELECT($ORDER(PSBARR(""))]"":1,1:0)
- +51 ;add last site *70/*83
- +52 ;*83
- SET $PIECE(PSBREC,U,30)=$$LASTSITE^PSBINJEC(DFN,PSBOIT)
- +53 ; piece 31 special IVPB use in vdl's not for coversheet
- +54 ;If from coversheet use offset -1 *70
- IF $GET(PSBTAB)="CVRSHT"
- Begin DoDot:3
- +55 ;clinic name
- SET $PIECE(PSBREC,U,31)=$GET(PSBCLORD)
- +56 ;clinic ien ptr
- SET $PIECE(PSBREC,U,32)=$GET(PSBCLIEN)
- End DoDot:3
- +57 ;Else must be Unit does VDL calling
- IF $GET(PSBTAB)="UDTAB"
- Begin DoDot:3
- +58 ;clinic name
- SET $PIECE(PSBREC,U,32)=$GET(PSBCLORD)
- +59 ;clinic ien ptr
- SET $PIECE(PSBREC,U,33)=$GET(PSBCLIEN)
- +60 ;existing RM time
- SET $PIECE(PSBREC,U,35)=$PIECE(^PSB(53.79,PSBIEN,.1),U,7)
- End DoDot:3
- +61 ; piece 34-35 reserved for Remove meds and set by PSBVDLU1
- +62 ;Hazardous to Handle *106
- SET $PIECE(PSBREC,U,36)=$GET(PSBHAZHN)
- +63 ;Hazardous to Dispose *106
- SET $PIECE(PSBREC,U,37)=$GET(PSBHAZDS)
- +64 ;
- +65 ; Place into Coversheet activity ARRAY
- +66 SET PSBDIDX=""
- IF $DATA(^PSB(53.79,"AORD",DFN,PSBONX))
- Begin DoDot:3
- +67 SET PSBXDTI=""
- SET PSBXDTI=$ORDER(^PSB(53.79,"AORD",DFN,PSBONX,PSBXDTI),-1)
- +68 if '$DATA(^PSB(53.79,"AORD",DFN,PSBONX,PSBXDTI,PSBIEN))
- QUIT
- +69 SET PSBADMX(PSBONX,PSBXDTI,PSBIEN)=""
- SET PSBDIDX=1
- End DoDot:3
- +70 IF ('PSBDIDX)&$DATA(^PSB(53.79,"AORDX",DFN,PSBONX))
- Begin DoDot:3
- +71 SET PSBXXDTI=""
- SET PSBXXDTI=$ORDER(^PSB(53.79,"AORDX",DFN,PSBONX,PSBXXDTI),-1)
- +72 if '$DATA(^PSB(53.79,"AORDX",DFN,PSBONX,PSBXXDTI,PSBIEN))
- QUIT
- +73 SET PSBADMX(PSBONX,PSBXXDTI,PSBIEN)=""
- End DoDot:3
- End DoDot:2
- +74 SET $PIECE(PSBREC,U,18)="PATCH"
- +75 SET $PIECE(PSBREC,U,21)=PSBOST
- +76 SET $PIECE(PSBREC,U,22)=PSBOSTS
- +77 SET PSBDDS=""
- FOR Y=0:0
- SET Y=$ORDER(PSBDDA(Y))
- if 'Y
- QUIT
- if $PIECE(PSBDDA(Y),U,4)=""
- SET $PIECE(PSBDDA(Y),U,4)=1
- SET PSBDDS=PSBDDS_U_$PIECE(PSBDDA(Y),U,1,4)
- SET $PIECE(PSBDDS,U,1)=PSBDDS+1
- +78 SET PSBQRR=1
- +79 ; *83 Api below now calcs & adds MRR code & Remove time to (34,35)
- +80 DO ADD^PSBVDLU1(PSBREC,PSBOTXT,$PIECE(PSBREC,U,14),PSBDDS,"","",$SELECT($GET(PSBTAB)="CVRSHT":"CVRSHT",1:"UDTAB"))
- End DoDot:1
- +81 QUIT
