PSBOMH3 ;ALBANY/BJR-MAH ; 2/16/12 1:00pm
;;3.0;BAR CODE MED ADMIN;**67**;Mar 2004;Build 23
;Per VHA Directive 2004-038, this routine should not be modified.
;
; Reference/IA
; File 200/10060
; $$GET1^DIQ/2056
;
RELINE(PSBWEEK) ;^TMP("PSB" global is expected, PSBWEEK variable is time frame for ^TMP("PSB"
;Line administrations up with their admin times. Move administrations given on the wrong day above or below admin times for current day - PSB*3*67
N PSBORD,PSBDT,PSBADM,PSBIEN,PSBSCH,PSBORDT,PSBORTM,PSBBFR,PSBAFTR,PSBTTL,PSBADTM,PSBFLG,PSBERLY,PSBCNT,PSBCNTR,PSBACDT,PSBCLR,PSBGDTM,PSBAT,PSBATTM
S PSBORD="" F S PSBORD=$O(^TMP("PSB",$J,PSBWEEK,PSBORD)) Q:'PSBORD D
.S PSBDT="" F S PSBDT=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT)) Q:'PSBDT D
..Q:^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT,0)=0
..;Set up administration time array
..S PSBAT=0,PSBATTM="" F S PSBAT=$O(^TMP("PSB",$J,"ORDERS",PSBORD,"AT",PSBAT)) Q:'PSBAT S PSBATTM=PSBATTM_$E(^TMP("PSB",$J,"ORDERS",PSBORD,"AT",PSBAT)_"0000",1,4)_", "
..S PSBADM=0 F S PSBADM=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT,PSBADM)) Q:PSBADM="" D ;Loop through temp global and get all entries on MAH - PSB*3*67
...S PSBIEN=$P(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT,PSBADM),U,4),PSBSCH=$$GET1^DIQ(53.79,PSBIEN_",",.13,"I"),PSBORDT=$P(PSBSCH,".") Q:'PSBORDT
...I $$GET1^DIQ(53.795,1_","_PSBIEN_",",.04)["PATCH" Q ;Do not modify report for patches
...;add ">" before action if admin times have been changed since administration and no longer have a corresponding admin time
...I PSBATTM,PSBATTM'[$E($P(PSBSCH,".",2)_"0000",1,4) S $P(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT,PSBADM),U,3)=">"_$P(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT,PSBADM),U,3)
...I PSBORDT>PSBDT S PSBBFR(PSBORD,PSBDT)=$G(PSBBFR(PSBORD,PSBDT))+1 ;Initialize array and set for orders given a day late
...I PSBORDT<PSBDT S PSBAFTR(PSBORD,PSBDT)=$G(PSBAFTR(PSBORD,PSBDT))+1 ;Initialize array and set for orders given a day early
S PSBORD="" F S PSBORD=$O(PSBBFR(PSBORD)) Q:PSBORD="" D ;Loop through Before Array
.S PSBCNTR=0,PSBDT="" F S PSBDT=$O(PSBBFR(PSBORD,PSBDT)) Q:PSBDT="" S:PSBCNTR<PSBBFR(PSBORD,PSBDT) PSBCNTR=PSBBFR(PSBORD,PSBDT) D
..F PSBBFR=1:1:PSBCNTR S ^TMP("PSB",$J,"ORDERS",PSBORD,"AT",$O(^TMP("PSB",$J,"ORDERS",PSBORD,"AT",""),-1)+1)="" ;Add additional lines to the end of the "AT" node
..S ^TMP("PSB",$J,"ORDERS",PSBORD,"AT",0)=$O(^TMP("PSB",$J,"ORDERS",PSBORD,"AT",""),-1) ;Reset "AT" Counter
S PSBORD="" F S PSBORD=$O(PSBAFTR(PSBORD)) Q:PSBORD="" D ;Loop through After Array
.S PSBCNTR=0,PSBDT="" F S PSBDT=$O(PSBAFTR(PSBORD,PSBDT)) Q:PSBDT="" S:PSBCNTR<PSBAFTR(PSBORD,PSBDT) PSBCNTR=PSBAFTR(PSBORD,PSBDT)
.F PSBAFTR=1:1:PSBCNTR S ^TMP("PSB",$J,"ORDERS",PSBORD,"AT",$O(^TMP("PSB",$J,"ORDERS",PSBORD,"AT",""),-1)+1)="" ;Add additional lines to the beginning of the "AT" node
.S PSBTTL=$O(^TMP("PSB",$J,"ORDERS",PSBORD,"AT",""),-1)
.F PSBAFTR=PSBTTL:-1:PSBCNTR+1 S ^TMP("PSB",$J,"ORDERS",PSBORD,"AT",PSBAFTR)=^TMP("PSB",$J,"ORDERS",PSBORD,"AT",PSBAFTR-PSBCNTR) ;Reset making room for additional lines at top
.F PSBAFTR=1:1:PSBCNTR S ^TMP("PSB",$J,"ORDERS",PSBORD,"AT",PSBAFTR)=""
.S ^TMP("PSB",$J,"ORDERS",PSBORD,"AT",0)=$O(^TMP("PSB",$J,"ORDERS",PSBORD,"AT",""),-1) ;Reset "AT" Counter
K ^TMP("PSBSRT",$J) M ^TMP("PSBSRT",$J)=^TMP("PSB",$J) ;Merge PSBSRT temp global and use to reline MAH report
S PSBCNT=0,PSBORD="" F S PSBORD=$O(^TMP("PSBSRT",$J,PSBWEEK,PSBORD)) Q:'PSBORD D
.S PSBDT="" F S PSBDT=$O(^TMP("PSBSRT",$J,PSBWEEK,PSBORD,PSBDT)) Q:'PSBDT D
..Q:^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT,0)=0
..S PSBCNT=1,PSBCLR=0 F S PSBCLR=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT,PSBCLR)) Q:PSBCLR="" S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT,PSBCLR)="" ;Clear out all orders on ^TMP("PSB"
..S PSBADM=0 F S PSBADM=$O(^TMP("PSBSRT",$J,PSBWEEK,PSBORD,PSBDT,PSBADM)) Q:PSBADM="" D ;Loop through All orders on MAH
...S PSBIEN=$P(^TMP("PSBSRT",$J,PSBWEEK,PSBORD,PSBDT,PSBADM),U,4) S PSBSCH=$$GET1^DIQ(53.79,PSBIEN_",",.13,"I"),PSBORDT=$P(PSBSCH,"."),PSBORTM=$E($P(PSBSCH,".",2)_"0000",1,4)
...I $$GET1^DIQ(53.795,1_","_PSBIEN_",",.04)["PATCH" S PSBGDTM(PSBORD,PSBDT)=1 Q ;Don't reline patches
...S PSBACDT=$P($$GET1^DIQ(53.79,PSBIEN_",",.06,"I"),".") ;Get date of last action taken on order
...I PSBORDT=PSBACDT S PSBADTM=0 F S PSBADTM=$O(^TMP("PSBSRT",$J,"ORDERS",PSBORD,"AT",PSBADTM)) Q:PSBADTM="" I ^TMP("PSBSRT",$J,"ORDERS",PSBORD,"AT",PSBADTM)=PSBORTM D
....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT,PSBADTM)=^TMP("PSBSRT",$J,PSBWEEK,PSBORD,PSBDT,PSBADM) S PSBGDTM=1 ;Set up ^TMP("PSB" lined up with admin time
....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT,0)=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT,""),-1) ;Set "MAH" counter
...I PSBORDT=PSBACDT,'$G(PSBGDTM) S PSBGDTM(PSBORD,PSBDT)=1 Q ;Sets the PSBGDTM array
...I '$G(PSBORDT),'$G(PSBGDTM) S PSBGDTM(PSBORD,PSBDT)=1 Q ;if not correct day, set PSBGDTM array and quit
...S PSBGDTM="" ;reset PSBGDTM variable to null
...;set a day early administration to below the admin times
...I PSBORDT>PSBACDT S PSBADTM="" F S PSBADTM=$O(^TMP("PSBSRT",$J,"ORDERS",PSBORD,"AT",PSBADTM),-1) Q:PSBADTM="" Q:^TMP("PSBSRT",$J,"ORDERS",PSBORD,"AT",PSBADTM)'=""
...I PSBORDT>PSBACDT S PSBERLY=PSBADTM F S PSBERLY=$O(^TMP("PSB",$J,"ORDERS",PSBORD,"AT",PSBERLY)) Q:'PSBERLY Q:$G(PSBFLG) I '$G(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT,PSBERLY)) D
....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT,PSBERLY)=^TMP("PSBSRT",$J,PSBWEEK,PSBORD,PSBDT,PSBADM),PSBFLG=1
...K PSBFLG
...;set a day late administration to above the admin times
...I PSBORDT<PSBACDT S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT,PSBCNT)=^TMP("PSBSRT",$J,PSBWEEK,PSBORD,PSBDT,PSBADM),PSBCNT=PSBCNT+1
;fill in ^TMP("PSB" with all administrations which don't have current admin times from PSBGDTM array
S PSBORD="" F S PSBORD=$O(PSBGDTM(PSBORD)) Q:PSBORD="" D
.S PSBDT="" F S PSBDT=$O(PSBGDTM(PSBORD,PSBDT)) Q:PSBDT="" D
..S PSBCLR=0 F S PSBCLR=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT,PSBCLR)) Q:PSBCLR="" S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT,PSBCLR)=""
..S PSBGDTM="" F S PSBGDTM=$O(^TMP("PSBSRT",$J,PSBWEEK,PSBORD,PSBDT,PSBGDTM)) Q:PSBGDTM="" S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT,PSBGDTM)=^TMP("PSBSRT",$J,PSBWEEK,PSBORD,PSBDT,PSBGDTM)
K ^TMP("PSBSRT",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBOMH3 6274 printed Dec 13, 2024@01:40:41 Page 2
PSBOMH3 ;ALBANY/BJR-MAH ; 2/16/12 1:00pm
+1 ;;3.0;BAR CODE MED ADMIN;**67**;Mar 2004;Build 23
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; File 200/10060
+6 ; $$GET1^DIQ/2056
+7 ;
RELINE(PSBWEEK) ;^TMP("PSB" global is expected, PSBWEEK variable is time frame for ^TMP("PSB"
+1 ;Line administrations up with their admin times. Move administrations given on the wrong day above or below admin times for current day - PSB*3*67
+2 NEW PSBORD,PSBDT,PSBADM,PSBIEN,PSBSCH,PSBORDT,PSBORTM,PSBBFR,PSBAFTR,PSBTTL,PSBADTM,PSBFLG,PSBERLY,PSBCNT,PSBCNTR,PSBACDT,PSBCLR,PSBGDTM,PSBAT,PSBATTM
+3 SET PSBORD=""
FOR
SET PSBORD=$ORDER(^TMP("PSB",$JOB,PSBWEEK,PSBORD))
if 'PSBORD
QUIT
Begin DoDot:1
+4 SET PSBDT=""
FOR
SET PSBDT=$ORDER(^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT))
if 'PSBDT
QUIT
Begin DoDot:2
+5 if ^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT,0)=0
QUIT
+6 ;Set up administration time array
+7 SET PSBAT=0
SET PSBATTM=""
FOR
SET PSBAT=$ORDER(^TMP("PSB",$JOB,"ORDERS",PSBORD,"AT",PSBAT))
if 'PSBAT
QUIT
SET PSBATTM=PSBATTM_$EXTRACT(^TMP("PSB",$JOB,"ORDERS",PSBORD,"AT",PSBAT)_"0000",1,4)_", "
+8 ;Loop through temp global and get all entries on MAH - PSB*3*67
SET PSBADM=0
FOR
SET PSBADM=$ORDER(^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT,PSBADM))
if PSBADM=""
QUIT
Begin DoDot:3
+9 SET PSBIEN=$PIECE(^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT,PSBADM),U,4)
SET PSBSCH=$$GET1^DIQ(53.79,PSBIEN_",",.13,"I")
SET PSBORDT=$PIECE(PSBSCH,".")
if 'PSBORDT
QUIT
+10 ;Do not modify report for patches
IF $$GET1^DIQ(53.795,1_","_PSBIEN_",",.04)["PATCH"
QUIT
+11 ;add ">" before action if admin times have been changed since administration and no longer have a corresponding admin time
+12 IF PSBATTM
IF PSBATTM'[$EXTRACT($PIECE(PSBSCH,".",2)_"0000",1,4)
SET $PIECE(^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT,PSBADM),U,3)=">"_$PIECE(^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT,PSBADM),U,3)
+13 ;Initialize array and set for orders given a day late
IF PSBORDT>PSBDT
SET PSBBFR(PSBORD,PSBDT)=$GET(PSBBFR(PSBORD,PSBDT))+1
+14 ;Initialize array and set for orders given a day early
IF PSBORDT<PSBDT
SET PSBAFTR(PSBORD,PSBDT)=$GET(PSBAFTR(PSBORD,PSBDT))+1
End DoDot:3
End DoDot:2
End DoDot:1
+15 ;Loop through Before Array
SET PSBORD=""
FOR
SET PSBORD=$ORDER(PSBBFR(PSBORD))
if PSBORD=""
QUIT
Begin DoDot:1
+16 SET PSBCNTR=0
SET PSBDT=""
FOR
SET PSBDT=$ORDER(PSBBFR(PSBORD,PSBDT))
if PSBDT=""
QUIT
if PSBCNTR<PSBBFR(PSBORD,PSBDT)
SET PSBCNTR=PSBBFR(PSBORD,PSBDT)
Begin DoDot:2
+17 ;Add additional lines to the end of the "AT" node
FOR PSBBFR=1:1:PSBCNTR
SET ^TMP("PSB",$JOB,"ORDERS",PSBORD,"AT",$ORDER(^TMP("PSB",$JOB,"ORDERS",PSBORD,"AT",""),-1)+1)=""
+18 ;Reset "AT" Counter
SET ^TMP("PSB",$JOB,"ORDERS",PSBORD,"AT",0)=$ORDER(^TMP("PSB",$JOB,"ORDERS",PSBORD,"AT",""),-1)
End DoDot:2
End DoDot:1
+19 ;Loop through After Array
SET PSBORD=""
FOR
SET PSBORD=$ORDER(PSBAFTR(PSBORD))
if PSBORD=""
QUIT
Begin DoDot:1
+20 SET PSBCNTR=0
SET PSBDT=""
FOR
SET PSBDT=$ORDER(PSBAFTR(PSBORD,PSBDT))
if PSBDT=""
QUIT
if PSBCNTR<PSBAFTR(PSBORD,PSBDT)
SET PSBCNTR=PSBAFTR(PSBORD,PSBDT)
+21 ;Add additional lines to the beginning of the "AT" node
FOR PSBAFTR=1:1:PSBCNTR
SET ^TMP("PSB",$JOB,"ORDERS",PSBORD,"AT",$ORDER(^TMP("PSB",$JOB,"ORDERS",PSBORD,"AT",""),-1)+1)=""
+22 SET PSBTTL=$ORDER(^TMP("PSB",$JOB,"ORDERS",PSBORD,"AT",""),-1)
+23 ;Reset making room for additional lines at top
FOR PSBAFTR=PSBTTL:-1:PSBCNTR+1
SET ^TMP("PSB",$JOB,"ORDERS",PSBORD,"AT",PSBAFTR)=^TMP("PSB",$JOB,"ORDERS",PSBORD,"AT",PSBAFTR-PSBCNTR)
+24 FOR PSBAFTR=1:1:PSBCNTR
SET ^TMP("PSB",$JOB,"ORDERS",PSBORD,"AT",PSBAFTR)=""
+25 ;Reset "AT" Counter
SET ^TMP("PSB",$JOB,"ORDERS",PSBORD,"AT",0)=$ORDER(^TMP("PSB",$JOB,"ORDERS",PSBORD,"AT",""),-1)
End DoDot:1
+26 ;Merge PSBSRT temp global and use to reline MAH report
KILL ^TMP("PSBSRT",$JOB)
MERGE ^TMP("PSBSRT",$JOB)=^TMP("PSB",$JOB)
+27 SET PSBCNT=0
SET PSBORD=""
FOR
SET PSBORD=$ORDER(^TMP("PSBSRT",$JOB,PSBWEEK,PSBORD))
if 'PSBORD
QUIT
Begin DoDot:1
+28 SET PSBDT=""
FOR
SET PSBDT=$ORDER(^TMP("PSBSRT",$JOB,PSBWEEK,PSBORD,PSBDT))
if 'PSBDT
QUIT
Begin DoDot:2
+29 if ^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT,0)=0
QUIT
+30 ;Clear out all orders on ^TMP("PSB"
SET PSBCNT=1
SET PSBCLR=0
FOR
SET PSBCLR=$ORDER(^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT,PSBCLR))
if PSBCLR=""
QUIT
SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT,PSBCLR)=""
+31 ;Loop through All orders on MAH
SET PSBADM=0
FOR
SET PSBADM=$ORDER(^TMP("PSBSRT",$JOB,PSBWEEK,PSBORD,PSBDT,PSBADM))
if PSBADM=""
QUIT
Begin DoDot:3
+32 SET PSBIEN=$PIECE(^TMP("PSBSRT",$JOB,PSBWEEK,PSBORD,PSBDT,PSBADM),U,4)
SET PSBSCH=$$GET1^DIQ(53.79,PSBIEN_",",.13,"I")
SET PSBORDT=$PIECE(PSBSCH,".")
SET PSBORTM=$EXTRACT($PIECE(PSBSCH,".",2)_"0000",1,4)
+33 ;Don't reline patches
IF $$GET1^DIQ(53.795,1_","_PSBIEN_",",.04)["PATCH"
SET PSBGDTM(PSBORD,PSBDT)=1
QUIT
+34 ;Get date of last action taken on order
SET PSBACDT=$PIECE($$GET1^DIQ(53.79,PSBIEN_",",.06,"I"),".")
+35 IF PSBORDT=PSBACDT
SET PSBADTM=0
FOR
SET PSBADTM=$ORDER(^TMP("PSBSRT",$JOB,"ORDERS",PSBORD,"AT",PSBADTM))
if PSBADTM=""
QUIT
IF ^TMP("PSBSRT",$JOB,"ORDERS",PSBORD,"AT",PSBADTM)=PSBORTM
Begin DoDot:4
+36 ;Set up ^TMP("PSB" lined up with admin time
SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT,PSBADTM)=^TMP("PSBSRT",$JOB,PSBWEEK,PSBORD,PSBDT,PSBADM)
SET PSBGDTM=1
+37 ;Set "MAH" counter
SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT,0)=$ORDER(^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT,""),-1)
End DoDot:4
+38 ;Sets the PSBGDTM array
IF PSBORDT=PSBACDT
IF '$GET(PSBGDTM)
SET PSBGDTM(PSBORD,PSBDT)=1
QUIT
+39 ;if not correct day, set PSBGDTM array and quit
IF '$GET(PSBORDT)
IF '$GET(PSBGDTM)
SET PSBGDTM(PSBORD,PSBDT)=1
QUIT
+40 ;reset PSBGDTM variable to null
SET PSBGDTM=""
+41 ;set a day early administration to below the admin times
+42 IF PSBORDT>PSBACDT
SET PSBADTM=""
FOR
SET PSBADTM=$ORDER(^TMP("PSBSRT",$JOB,"ORDERS",PSBORD,"AT",PSBADTM),-1)
if PSBADTM=""
QUIT
if ^TMP("PSBSRT",$JOB,"ORDERS",PSBORD,"AT",PSBADTM)'=""
QUIT
+43 IF PSBORDT>PSBACDT
SET PSBERLY=PSBADTM
FOR
SET PSBERLY=$ORDER(^TMP("PSB",$JOB,"ORDERS",PSBORD,"AT",PSBERLY))
if 'PSBERLY
QUIT
if $GET(PSBFLG)
QUIT
IF '$GET(^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT,PSBERLY))
Begin DoDot:4
+44 SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT,PSBERLY)=^TMP("PSBSRT",$JOB,PSBWEEK,PSBORD,PSBDT,PSBADM)
SET PSBFLG=1
End DoDot:4
+45 KILL PSBFLG
+46 ;set a day late administration to above the admin times
+47 IF PSBORDT<PSBACDT
SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT,PSBCNT)=^TMP("PSBSRT",$JOB,PSBWEEK,PSBORD,PSBDT,PSBADM)
SET PSBCNT=PSBCNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+48 ;fill in ^TMP("PSB" with all administrations which don't have current admin times from PSBGDTM array
+49 SET PSBORD=""
FOR
SET PSBORD=$ORDER(PSBGDTM(PSBORD))
if PSBORD=""
QUIT
Begin DoDot:1
+50 SET PSBDT=""
FOR
SET PSBDT=$ORDER(PSBGDTM(PSBORD,PSBDT))
if PSBDT=""
QUIT
Begin DoDot:2
+51 SET PSBCLR=0
FOR
SET PSBCLR=$ORDER(^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT,PSBCLR))
if PSBCLR=""
QUIT
SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT,PSBCLR)=""
+52 SET PSBGDTM=""
FOR
SET PSBGDTM=$ORDER(^TMP("PSBSRT",$JOB,PSBWEEK,PSBORD,PSBDT,PSBGDTM))
if PSBGDTM=""
QUIT
SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT,PSBGDTM)=^TMP("PSBSRT",$JOB,PSBWEEK,PSBORD,PSBDT,PSBGDTM)
End DoDot:2
End DoDot:1
+53 KILL ^TMP("PSBSRT",$JOB)
+54 QUIT
