PSBCSUTY ;BIRMINGHAM/TEJ- BCMA-HSC COVER SHEET UTILITIES 3 ;Mar 2004
;;3.0;BAR CODE MED ADMIN;**16,32**;Mar 2004;Build 32
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
; Reference/IA
; $$GET1^DIQ/2056
; File 200/10060
CMT ; Comment per admin.
S (PSBIENX,PSBPRNRE)="",PSBIENX=+$P(PSBADMS(PSBONMBR,PSBSCHTM),U,3),PSBPRNRE=$P(PSBADMS(PSBONMBR,PSBSCHTM),U,8)
D:+$O(^PSB(53.79,PSBIENX,.3,""),-1)>0
.S PSBI2=0 F S PSBI2=$O(^PSB(53.79,PSBIENX,.3,PSBI2)) Q:PSBI2="" D
..S $P(^TMP("PSB",$J,"CVRSHT2",PSBI1,PSBCNT2),U)="CMT",$P(^TMP("PSB",$J,"CVRSHT2",PSBI1,PSBCNT2),U,2)=$P(^PSB(53.79,PSBIENX,.3,PSBI2,0),U)
..S $P(^TMP("PSB",$J,"CVRSHT2",PSBI1,PSBCNT2),U,4)=$P(^PSB(53.79,PSBIENX,.3,PSBI2,0),U,2)
..S $P(^TMP("PSB",$J,"CVRSHT2",PSBI1,PSBCNT2),U,5)=$$GET1^DIQ(200,$P(^PSB(53.79,PSBIENX,.3,PSBI2,0),U,2)_",","INITIAL")
..S $P(^TMP("PSB",$J,"CVRSHT2",PSBI1,PSBCNT2),U,6)=$P(^PSB(53.79,PSBIENX,.3,PSBI2,0),U,3),PSBCNT2=PSBCNT2+1
D:($G(PSBPRNRE)]"")&($$GET1^DIQ(53.79,PSBIENX_",","PRN EFFECTIVENESS")]"")
.S $P(^TMP("PSB",$J,"CVRSHT2",PSBI1,PSBCNT2),U)="CMT",$P(^TMP("PSB",$J,"CVRSHT2",PSBI1,PSBCNT2),U,3)=$$GET1^DIQ(53.79,PSBIENX_",","PRN EFFECTIVENESS")
.S $P(^TMP("PSB",$J,"CVRSHT2",PSBI1,PSBCNT2),U,4)=$$GET1^DIQ(53.79,PSBIENX_",","PRN EFFECTIVENESS ENTERED BY","I")
.S $P(^TMP("PSB",$J,"CVRSHT2",PSBI1,PSBCNT2),U,5)=$$GET1^DIQ(53.79,PSBIENX_",","PRN EFFECTIVENESS ENTERED BY:INITIAL")
.S $P(^TMP("PSB",$J,"CVRSHT2",PSBI1,PSBCNT2),U,6)=$$GET1^DIQ(53.79,PSBIENX_",","PRN EFFECTIVENESS ENTERED AT","I"),PSBCNT2=PSBCNT2+1
Q
XFERBAGS ;
; Logic to "move IV bags"
; Construct Temp arrays PSBADMX,PSBDONE
Q:PSBPONX']""
K PSBCHKED
S PSBNX2=PSBONX,PSBDFN2=PSBDFN,PSBPNX2=PSBPONX,PSBFN2=PSBFON F Q:PSBFN2]"" D Q:PSBPONX']"" S PSBPNX2=PSBPONX I $G(PSBCHKED(PSBPONX))=1 K PSBCHKED Q
.D CLEAN^PSBVT S PSBPONX=PSBPNX2,PSBCHKED(PSBPONX)=1 D PSJ1^PSBVT(PSBDFN2,PSBPONX)
.S (PSBXX,PSBXXX)="" F S PSBXX=$O(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBXX)) Q:PSBXX="" D
..S PSBXXX=$O(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBXX,PSBXXX)) Q:PSBXXX="" Q:$P(^PSB(53.79,PSBXXX,0),U,9)="C" S:'$D(PSBDONE(PSBXXX)) (PSBADMX(PSBNX2,PSBXX,PSBXXX),PSBDONE(PSBXXX))=""
; Refresh data
D CLEAN^PSBVT,PSJ1^PSBVT(PSBDFN2,PSBNX2)
K PSBNX2,PSBDFN2,PSBPNX2,PSBFN2
Q
GETADMX ;
S (PSBXX,PSBXXX)="" F S PSBXX=$O(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBXX)) Q:PSBXX="" D
.Q:(PSBXX<PSBMHBCK)&'PSBLVIV
.F S PSBXXX=$O(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBXX,PSBXXX)) Q:PSBXXX="" Q:(PSBFON]"")&($P(^PSB(53.79,PSBXXX,0),U,9)'="C")&(PSBLVIV) D
..S (PSBADMX(PSBONX,PSBXX,PSBXXX),PSBDONE(PSBXXX))=""
; Check "actions" that DO NOT get filed into AORDX !!
S (PSBXX,PSBXXX)="" F S PSBXX=$O(^PSB(53.79,"AORD",PSBDFN,PSBONX,PSBXX)) Q:PSBXX="" D
.F S PSBXXX=$O(^PSB(53.79,"AORD",PSBDFN,PSBONX,PSBXX,PSBXXX)) Q:PSBXXX="" D
..S:('$D(PSBDONE(PSBXXX)))&($P(^PSB(53.79,PSBXXX,0),U,6)'<PSBMHBCK) PSBADMX(PSBONX,PSBXX,PSBXXX)=""
K PSBXX,PSBXXX,PSBDONE
Q
LVIV ;
; Set up variables to later extract LVIV data
; Add all LVIVs that have been active with in the window!!
I (PSBOSP'<PSBWBEG)&(PSBOSP'>PSBWEND) D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBNOW\1_".",PSBDDS,PSBSOLS,PSBADDS,"CVRSHT")
S PSBEXPRD=0 I (PSBFON']"")&(PSBOSP<PSBNOW) S PSBEXPRD=1
S (PSBXX,PSBXXX)="" F S PSBXX=$O(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBXX)) Q:PSBXX="" D
.S PSBXXX=$O(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBXX,PSBXXX)) Q:PSBXXX=""
.I "IS"[$P(^PSB(53.79,PSBXXX,0),U,9)&(PSBFON']"") S PSBEXPRD=0
.S:'$D(PSBDONE(PSBXXX))&(PSBFON="") (PSBADMX(PSBONX,PSBXX,PSBXXX),PSBDONE(PSBXXX))=""
S (PSBXX,PSBXXX)="" F S PSBXX=$O(PSBADMX(PSBONX,PSBXX)) Q:PSBXX="" D
.S PSBXXX=$O(PSBADMX(PSBONX,PSBXX,PSBXXX)) Q:PSBXXX=""
.I "IS"[$P(^PSB(53.79,PSBXXX,0),U,9)&(PSBFON']"") S PSBEXPRD=0
.S:'$D(PSBDONE(PSBXXX))&(PSBFON="") (PSBADMX(PSBONX,PSBXX,PSBXXX),PSBDONE(PSBXXX))=""
Q
QUT() ;
S QUT=0
I PSBOST>($$FMADD^XLFDT($$NOW^XLFDT,,,$$GET^XPAR("DIV","PSB ADMIN BEFORE"))) S QUT=1 Q QUT
I '(($F("ED",PSBOSTS)'>1)&(PSBOSP'<%)) S QUT=1 Q QUT
Q QUT
USED() ;
S (PSBXIEN,PSBUSD,USED)=0,PSBBAGX=$P(PSBXREC,U,2)
I $$QUT() S (PSBUSD,USED)=1 Q PSBUSD
S PSBXXX="" F S PSBXXX=$O(^PSB(53.79,"AUID",PSBDFNX,PSBXXX)) Q:PSBXXX="" D Q:PSBUSD
.I $D(^PSB(53.79,"AUID",PSBDFNX,PSBXXX,PSBBAGX)) S PSBXIEN=$O(^PSB(53.79,"AUID",PSBDFNX,PSBXXX,PSBBAGX,"")) S:$F("GICSHRM",$P(^PSB(53.79,PSBXIEN,0),U,9))>1 (PSBUSD,USED)=1,PSBOBAG(PSBONMBR)=""
Q USED
ORC ; Ord cmmnts
S PSBCNT2=PSBCNT2+1,^TMP("PSB",$J,"CVRSHT2",PSBCNT2)="ORC",$P(^TMP("PSB",$J,"CVRSHT2",PSBCNT2),U,2)=^TMP("PSB",$J,PSBTAB,PSBI1),PSBRECHD="ORF"
Q
ORF ; Ordr flag "ORF^FLAG^Flg Comment"
K ^TMP("PSJ1",$J),PSBNOX
D EN^PSJBCMA1(PSBDFN,PSBONMBR,1)
;Set STAT FLAG
I $P(^TMP("PSJ1",$J,7),U,1) S PSBCNT2=PSBCNT2+1,^TMP("PSB",$J,"CVRSHT2",PSBCNT2)="ORF^STAT"
;Set IM/CPRS ord flg and cmment
I $P(^TMP("PSJ1",$J,7),U,2) D
.S PSBCNT2=PSBCNT2+1,^TMP("PSB",$J,"CVRSHT2",PSBCNT2)="ORF^CPRS^"_$P(^TMP("PSJ1",$J,7),U,3)_U_$P(^TMP("PSJ1",$J,7),U,4)
.I $P(^TMP("PSJ1",$J,7),U,3)']"" D
..S $P(^TMP("PSB",$J,"CVRSHT2",PSBCNT2),U,2)="CPRS"
..S $P(^TMP("PSB",$J,"CVRSHT2",PSBCNT2),U,3)="*PSJ DATA ERROR* ^ PSJ Order Flag Error"
K ^TMP("PSJ1",$J)
;Set No Act Flag
I ('$D(^PSB(53.79,"AORDX",PSBDFN,PSBONMBR))) I (PSBLRGIV) I '$D(PSBADMX(PSBONMBR)) I $P(PSBORREC,U,26)>$G(%,PSBNOW) D
.S PSBCNT2=PSBCNT2+1,^TMP("PSB",$J,"CVRSHT2",PSBCNT2)="ORF^NOX^No Action Taken On Order"
.S PSBNOX(PSBONMBR,PSBCNT2)=""
S PSBRECHD="MED"
Q
MED ; Cnstr DD,ADD,SOL,ID
F I=PSBI1:1 S PSBXREC=^TMP("PSB",$J,PSBTAB,I) Q:PSBXREC="END" D
.I $P(PSBXREC,U)="ID" S PSBUSED=$$USED() Q:PSBUSED
.S PSBCNT2=PSBCNT2+1,^TMP("PSB",$J,"CVRSHT2",PSBCNT2)=PSBXREC
S PSBI1=I-1
Q
FINALPAS ;
S PSBI1="^TMP(""PSB"",$J,""CVRSHT"")",PSBCNT1=0
F S PSBI1=$Q(@PSBI1) Q:PSBI1["CVRSHT2" D
.I $QS(PSBI1,4)'>1 S ^TMP("PSB",$J,"CVRSHT2",PSBCNT1)=@PSBI1,PSBCNT1=PSBCNT1+1 Q
.K PSBX2 M PSBX2=^TMP("PSB",$J,"CVRSHT",$QS(PSBI1,4))
.I $QS(PSBI1,5)="" S ^TMP("PSB",$J,"CVRSHT2",PSBCNT1)=@PSBI1,PSBCNT1=PSBCNT1+1 Q
.K PSBDONE
.I '$D(PSBX2(1)) S ^TMP("PSB",$J,"CVRSHT2",PSBCNT1)=@PSBI1,PSBCNT1=PSBCNT1+1 Q
.F PSBI2=1:1 Q:'$D(PSBX2(PSBI2)) D ;sort actn/cmmnt rev. chrono
..Q:$D(PSBDONE(PSBI2))
..S PSBXDTTM=(-1*($P(PSBX2(PSBI2),U,6)))_+($E($P(PSBX2(PSBI2),U,4),$L($P(PSBX2(PSBI2),U,4))-6,999)),PSBMCODE=$P(PSBX2(PSBI2),U)
..D:(+PSBXDTTM<0)&(PSBMCODE["ADM")
...S PSBX3(+PSBXDTTM,-999)=PSBX2(PSBI2),PSBDONE(PSBI2)="" K ^TMP("PSB",$J,"CVRSHT",$QS(PSBI1,4),PSBI2)
...F PSBI3=1:1 Q:'$D(PSBX2(PSBI2+PSBI3)) Q:$P(PSBX2(PSBI2+PSBI3),U)'["CMT" D
....S PSBX3(+PSBXDTTM,-1*PSBI3)=PSBX2(PSBI2+PSBI3),PSBDONE(PSBI2+PSBI3)="" K ^TMP("PSB",$J,"CVRSHT",$QS(PSBI1,4),PSBI2+PSBI3)
..D:(+PSBXDTTM=0)&(PSBMCODE["ADM")
...S PSBX3(PSBI2,0)=PSBX2(PSBI2),PSBDONE(PSBI2)="" K ^TMP("PSB",$J,"CVRSHT",$QS(PSBI1,4),PSBI2)
.I $D(PSBX3) D K PSBX3
..S PSBI2="" F S PSBI2=$O(PSBX3(PSBI2)) Q:PSBI2="" S PSBI3="" F S PSBI3=$O(PSBX3(PSBI2,PSBI3)) Q:PSBI3="" D
...S ^TMP("PSB",$J,"CVRSHT2",PSBCNT1)=PSBX3(PSBI2,PSBI3),PSBCNT1=PSBCNT1+1
S $P(^TMP("PSB",$J,"CVRSHT2",0),U)=PSBCNT1-1
Q
PSBCSUTY ;BIRMINGHAM/TEJ- BCMA-HSC COVER SHEET UTILITIES 3 ;Mar 2004
+1 ;;3.0;BAR CODE MED ADMIN;**16,32**;Mar 2004;Build 32
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; $$GET1^DIQ/2056
+6 ; File 200/10060
CMT ; Comment per admin.
+1 SET (PSBIENX,PSBPRNRE)=""
SET PSBIENX=+$PIECE(PSBADMS(PSBONMBR,PSBSCHTM),U,3)
SET PSBPRNRE=$PIECE(PSBADMS(PSBONMBR,PSBSCHTM),U,8)
+2 IF +$ORDER(^PSB(53.79,PSBIENX,.3,""),-1)>0
Begin DoDot:1
+3 SET PSBI2=0
FOR
SET PSBI2=$ORDER(^PSB(53.79,PSBIENX,.3,PSBI2))
IF PSBI2=""
QUIT
Begin DoDot:2
+4 SET $PIECE(^TMP("PSB",$JOB,"CVRSHT2",PSBI1,PSBCNT2),U)="CMT"
SET $PIECE(^TMP("PSB",$JOB,"CVRSHT2",PSBI1,PSBCNT2),U,2)=$PIECE(^PSB(53.79,PSBIENX,.3,PSBI2,0),U)
+5 SET $PIECE(^TMP("PSB",$JOB,"CVRSHT2",PSBI1,PSBCNT2),U,4)=$PIECE(^PSB(53.79,PSBIENX,.3,PSBI2,0),U,2)
+6 SET $PIECE(^TMP("PSB",$JOB,"CVRSHT2",PSBI1,PSBCNT2),U,5)=$$GET1^DIQ(200,$PIECE(^PSB(53.79,PSBIENX,.3,PSBI2,0),U,2)_",","INITIAL")
+7 SET $PIECE(^TMP("PSB",$JOB,"CVRSHT2",PSBI1,PSBCNT2),U,6)=$PIECE(^PSB(53.79,PSBIENX,.3,PSBI2,0),U,3)
SET PSBCNT2=PSBCNT2+1
End DoDot:2
End DoDot:1
+8 IF ($GET(PSBPRNRE)]"")&($$GET1^DIQ(53.79,PSBIENX_",","PRN EFFECTIVENESS")]"")
Begin DoDot:1
+9 SET $PIECE(^TMP("PSB",$JOB,"CVRSHT2",PSBI1,PSBCNT2),U)="CMT"
SET $PIECE(^TMP("PSB",$JOB,"CVRSHT2",PSBI1,PSBCNT2),U,3)=$$GET1^DIQ(53.79,PSBIENX_",","PRN EFFECTIVENESS")
+10 SET $PIECE(^TMP("PSB",$JOB,"CVRSHT2",PSBI1,PSBCNT2),U,4)=$$GET1^DIQ(53.79,PSBIENX_",","PRN EFFECTIVENESS ENTERED BY","I")
+11 SET $PIECE(^TMP("PSB",$JOB,"CVRSHT2",PSBI1,PSBCNT2),U,5)=$$GET1^DIQ(53.79,PSBIENX_",","PRN EFFECTIVENESS ENTERED BY:INITIAL")
+12 SET $PIECE(^TMP("PSB",$JOB,"CVRSHT2",PSBI1,PSBCNT2),U,6)=$$GET1^DIQ(53.79,PSBIENX_",","PRN EFFECTIVENESS ENTERED AT","I")
SET PSBCNT2=PSBCNT2+1
End DoDot:1
+13 QUIT
XFERBAGS ;
+1 ; Logic to "move IV bags"
+2 ; Construct Temp arrays PSBADMX,PSBDONE
+3 IF PSBPONX']""
QUIT
+4 KILL PSBCHKED
+5 SET PSBNX2=PSBONX
SET PSBDFN2=PSBDFN
SET PSBPNX2=PSBPONX
SET PSBFN2=PSBFON
FOR
IF PSBFN2]""
QUIT
Begin DoDot:1
+6 DO CLEAN^PSBVT
SET PSBPONX=PSBPNX2
SET PSBCHKED(PSBPONX)=1
DO PSJ1^PSBVT(PSBDFN2,PSBPONX)
+7 SET (PSBXX,PSBXXX)=""
FOR
SET PSBXX=$ORDER(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBXX))
IF PSBXX=""
QUIT
Begin DoDot:2
+8 SET PSBXXX=$ORDER(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBXX,PSBXXX))
IF PSBXXX=""
QUIT
IF $PIECE(^PSB(53.79,PSBXXX,0),U,9)="C"
QUIT
IF '$DATA(PSBDONE(PSBXXX))
SET (PSBADMX(PSBNX2,PSBXX,PSBXXX),PSBDONE(PSBXXX))=""
End DoDot:2
End DoDot:1
IF PSBPONX']""
QUIT
SET PSBPNX2=PSBPONX
IF $GET(PSBCHKED(PSBPONX))=1
KILL PSBCHKED
QUIT
+9 ; Refresh data
+10 DO CLEAN^PSBVT
DO PSJ1^PSBVT(PSBDFN2,PSBNX2)
+11 KILL PSBNX2,PSBDFN2,PSBPNX2,PSBFN2
+12 QUIT
GETADMX ;
+1 SET (PSBXX,PSBXXX)=""
FOR
SET PSBXX=$ORDER(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBXX))
IF PSBXX=""
QUIT
Begin DoDot:1
+2 IF (PSBXX<PSBMHBCK)&'PSBLVIV
QUIT
+3 FOR
SET PSBXXX=$ORDER(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBXX,PSBXXX))
IF PSBXXX=""
QUIT
IF (PSBFON]"")&($PIECE(^PSB(53.79,PSBXXX,0),U,9)'="C")&(PSBLVIV)
QUIT
Begin DoDot:2
+4 SET (PSBADMX(PSBONX,PSBXX,PSBXXX),PSBDONE(PSBXXX))=""
End DoDot:2
End DoDot:1
+5 ; Check "actions" that DO NOT get filed into AORDX !!
+6 SET (PSBXX,PSBXXX)=""
FOR
SET PSBXX=$ORDER(^PSB(53.79,"AORD",PSBDFN,PSBONX,PSBXX))
IF PSBXX=""
QUIT
Begin DoDot:1
+7 FOR
SET PSBXXX=$ORDER(^PSB(53.79,"AORD",PSBDFN,PSBONX,PSBXX,PSBXXX))
IF PSBXXX=""
QUIT
Begin DoDot:2
+8 IF ('$DATA(PSBDONE(PSBXXX)))&($PIECE(^PSB(53.79,PSBXXX,0),U,6)'<PSBMHBCK)
SET PSBADMX(PSBONX,PSBXX,PSBXXX)=""
End DoDot:2
End DoDot:1
+9 KILL PSBXX,PSBXXX,PSBDONE
+10 QUIT
LVIV ;
+1 ; Set up variables to later extract LVIV data
+2 ; Add all LVIVs that have been active with in the window!!
+3 IF (PSBOSP'<PSBWBEG)&(PSBOSP'>PSBWEND)
DO ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBNOW\1_".",PSBDDS,PSBSOLS,PSBADDS,"CVRSHT")
+4 SET PSBEXPRD=0
IF (PSBFON']"")&(PSBOSP<PSBNOW)
SET PSBEXPRD=1
+5 SET (PSBXX,PSBXXX)=""
FOR
SET PSBXX=$ORDER(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBXX))
IF PSBXX=""
QUIT
Begin DoDot:1
+6 SET PSBXXX=$ORDER(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBXX,PSBXXX))
IF PSBXXX=""
QUIT
+7 IF "IS"[$PIECE(^PSB(53.79,PSBXXX,0),U,9)&(PSBFON']"")
SET PSBEXPRD=0
+8 IF '$DATA(PSBDONE(PSBXXX))&(PSBFON="")
SET (PSBADMX(PSBONX,PSBXX,PSBXXX),PSBDONE(PSBXXX))=""
End DoDot:1
+9 SET (PSBXX,PSBXXX)=""
FOR
SET PSBXX=$ORDER(PSBADMX(PSBONX,PSBXX))
IF PSBXX=""
QUIT
Begin DoDot:1
+10 SET PSBXXX=$ORDER(PSBADMX(PSBONX,PSBXX,PSBXXX))
IF PSBXXX=""
QUIT
+11 IF "IS"[$PIECE(^PSB(53.79,PSBXXX,0),U,9)&(PSBFON']"")
SET PSBEXPRD=0
+12 IF '$DATA(PSBDONE(PSBXXX))&(PSBFON="")
SET (PSBADMX(PSBONX,PSBXX,PSBXXX),PSBDONE(PSBXXX))=""
End DoDot:1
+13 QUIT
QUT() ;
+1 SET QUT=0
+2 IF PSBOST>($$FMADD^XLFDT($$NOW^XLFDT,,,$$GET^XPAR("DIV","PSB ADMIN BEFORE")))
SET QUT=1
QUIT QUT
+3 IF '(($FIND("ED",PSBOSTS)'>1)&(PSBOSP'<%))
SET QUT=1
QUIT QUT
+4 QUIT QUT
USED() ;
+1 SET (PSBXIEN,PSBUSD,USED)=0
SET PSBBAGX=$PIECE(PSBXREC,U,2)
+2 IF $$QUT()
SET (PSBUSD,USED)=1
QUIT PSBUSD
+3 SET PSBXXX=""
FOR
SET PSBXXX=$ORDER(^PSB(53.79,"AUID",PSBDFNX,PSBXXX))
IF PSBXXX=""
QUIT
Begin DoDot:1
+4 IF $DATA(^PSB(53.79,"AUID",PSBDFNX,PSBXXX,PSBBAGX))
SET PSBXIEN=$ORDER(^PSB(53.79,"AUID",PSBDFNX,PSBXXX,PSBBAGX,""))
IF $FIND("GICSHRM",$PIECE(^PSB(53.79,PSBXIEN,0),U,9))>1
SET (PSBUSD,USED)=1
SET PSBOBAG(PSBONMBR)=""
End DoDot:1
IF PSBUSD
QUIT
+5 QUIT USED
ORC ; Ord cmmnts
+1 SET PSBCNT2=PSBCNT2+1
SET ^TMP("PSB",$JOB,"CVRSHT2",PSBCNT2)="ORC"
SET $PIECE(^TMP("PSB",$JOB,"CVRSHT2",PSBCNT2),U,2)=^TMP("PSB",$JOB,PSBTAB,PSBI1)
SET PSBRECHD="ORF"
+2 QUIT
ORF ; Ordr flag "ORF^FLAG^Flg Comment"
+1 KILL ^TMP("PSJ1",$JOB),PSBNOX
+2 DO EN^PSJBCMA1(PSBDFN,PSBONMBR,1)
+3 ;Set STAT FLAG
+4 IF $PIECE(^TMP("PSJ1",$JOB,7),U,1)
SET PSBCNT2=PSBCNT2+1
SET ^TMP("PSB",$JOB,"CVRSHT2",PSBCNT2)="ORF^STAT"
+5 ;Set IM/CPRS ord flg and cmment
+6 IF $PIECE(^TMP("PSJ1",$JOB,7),U,2)
Begin DoDot:1
+7 SET PSBCNT2=PSBCNT2+1
SET ^TMP("PSB",$JOB,"CVRSHT2",PSBCNT2)="ORF^CPRS^"_$PIECE(^TMP("PSJ1",$JOB,7),U,3)_U_$PIECE(^TMP("PSJ1",$JOB,7),U,4)
+8 IF $PIECE(^TMP("PSJ1",$JOB,7),U,3)']""
Begin DoDot:2
+9 SET $PIECE(^TMP("PSB",$JOB,"CVRSHT2",PSBCNT2),U,2)="CPRS"
+10 SET $PIECE(^TMP("PSB",$JOB,"CVRSHT2",PSBCNT2),U,3)="*PSJ DATA ERROR* ^ PSJ Order Flag Error"
End DoDot:2
End DoDot:1
+11 KILL ^TMP("PSJ1",$JOB)
+12 ;Set No Act Flag
+13 IF ('$DATA(^PSB(53.79,"AORDX",PSBDFN,PSBONMBR)))
IF (PSBLRGIV)
IF '$DATA(PSBADMX(PSBONMBR))
IF $PIECE(PSBORREC,U,26)>$GET(%,PSBNOW)
Begin DoDot:1
+14 SET PSBCNT2=PSBCNT2+1
SET ^TMP("PSB",$JOB,"CVRSHT2",PSBCNT2)="ORF^NOX^No Action Taken On Order"
+15 SET PSBNOX(PSBONMBR,PSBCNT2)=""
End DoDot:1
+16 SET PSBRECHD="MED"
+17 QUIT
MED ; Cnstr DD,ADD,SOL,ID
+1 FOR I=PSBI1:1
SET PSBXREC=^TMP("PSB",$JOB,PSBTAB,I)
IF PSBXREC="END"
QUIT
Begin DoDot:1
+2 IF $PIECE(PSBXREC,U)="ID"
SET PSBUSED=$$USED()
IF PSBUSED
QUIT
+3 SET PSBCNT2=PSBCNT2+1
SET ^TMP("PSB",$JOB,"CVRSHT2",PSBCNT2)=PSBXREC
End DoDot:1
+4 SET PSBI1=I-1
+5 QUIT
FINALPAS ;
+1 SET PSBI1="^TMP(""PSB"",$J,""CVRSHT"")"
SET PSBCNT1=0
+2 FOR
SET PSBI1=$QUERY(@PSBI1)
IF PSBI1["CVRSHT2"
QUIT
Begin DoDot:1
+3 IF $QSUBSCRIPT(PSBI1,4)'>1
SET ^TMP("PSB",$JOB,"CVRSHT2",PSBCNT1)=@PSBI1
SET PSBCNT1=PSBCNT1+1
QUIT
+4 KILL PSBX2
MERGE PSBX2=^TMP("PSB",$JOB,"CVRSHT",$QSUBSCRIPT(PSBI1,4))
+5 IF $QSUBSCRIPT(PSBI1,5)=""
SET ^TMP("PSB",$JOB,"CVRSHT2",PSBCNT1)=@PSBI1
SET PSBCNT1=PSBCNT1+1
QUIT
+6 KILL PSBDONE
+7 IF '$DATA(PSBX2(1))
SET ^TMP("PSB",$JOB,"CVRSHT2",PSBCNT1)=@PSBI1
SET PSBCNT1=PSBCNT1+1
QUIT
+8 ;sort actn/cmmnt rev. chrono
FOR PSBI2=1:1
IF '$DATA(PSBX2(PSBI2))
QUIT
Begin DoDot:2
+9 IF $DATA(PSBDONE(PSBI2))
QUIT
+10 SET PSBXDTTM=(-1*($PIECE(PSBX2(PSBI2),U,6)))_+($EXTRACT($PIECE(PSBX2(PSBI2),U,4),$LENGTH($PIECE(PSBX2(PSBI2),U,4))-6,999))
SET PSBMCODE=$PIECE(PSBX2(PSBI2),U)
+11 IF (+PSBXDTTM<0)&(PSBMCODE["ADM")
Begin DoDot:3
+12 SET PSBX3(+PSBXDTTM,-999)=PSBX2(PSBI2)
SET PSBDONE(PSBI2)=""
KILL ^TMP("PSB",$JOB,"CVRSHT",$QSUBSCRIPT(PSBI1,4),PSBI2)
+13 FOR PSBI3=1:1
IF '$DATA(PSBX2(PSBI2+PSBI3))
QUIT
IF $PIECE(PSBX2(PSBI2+PSBI3),U)'["CMT"
QUIT
Begin DoDot:4
+14 SET PSBX3(+PSBXDTTM,-1*PSBI3)=PSBX2(PSBI2+PSBI3)
SET PSBDONE(PSBI2+PSBI3)=""
KILL ^TMP("PSB",$JOB,"CVRSHT",$QSUBSCRIPT(PSBI1,4),PSBI2+PSBI3)
End DoDot:4
End DoDot:3
+15 IF (+PSBXDTTM=0)&(PSBMCODE["ADM")
Begin DoDot:3
+16 SET PSBX3(PSBI2,0)=PSBX2(PSBI2)
SET PSBDONE(PSBI2)=""
KILL ^TMP("PSB",$JOB,"CVRSHT",$QSUBSCRIPT(PSBI1,4),PSBI2)
End DoDot:3
End DoDot:2
+17 IF $DATA(PSBX3)
Begin DoDot:2
+18 SET PSBI2=""
FOR
SET PSBI2=$ORDER(PSBX3(PSBI2))
IF PSBI2=""
QUIT
SET PSBI3=""
FOR
SET PSBI3=$ORDER(PSBX3(PSBI2,PSBI3))
IF PSBI3=""
QUIT
Begin DoDot:3
+19 SET ^TMP("PSB",$JOB,"CVRSHT2",PSBCNT1)=PSBX3(PSBI2,PSBI3)
SET PSBCNT1=PSBCNT1+1
End DoDot:3
End DoDot:2
KILL PSBX3
End DoDot:1
+20 SET $PIECE(^TMP("PSB",$JOB,"CVRSHT2",0),U)=PSBCNT1-1
+21 QUIT
