PSBCSUTX ;BIRMINGHAM/TEJ- BCMA-HSC COVER SHEET UTILITIES 2 ;Mar 2004
;;3.0;BAR CODE MED ADMIN;**16,13,38,32,72,107,149**;Mar 2004;Build 2
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
; Reference/IA
; $$GET1^DIQ/2056
; $$FMADD^XLFDT/10103
; NEW PERSON FILE/10060
ADD ; otput: ORD-ORC-DD-ADD-SOL-ID-ADM-CMT-END segmnts
K PSBDONE S PSBRECHD="ORD",PSBDONE=0,PSBCNT1=^TMP("PSB",$J,PSBTAB,0),PSBCNT2=1,$P(^TMP("PSB",$J,"CVRSHT2",0),U)=0
F PSBI1=1:1:PSBCNT1 D Q:PSBDONE
.I PSBCNT1'>1 S PSBDONE=1 Q
.I PSBI1=1 S ^TMP("PSB",$J,"CVRSHT2",PSBCNT2)=^TMP("PSB",$J,"CVRSHT",1) Q
.I ^TMP("PSB",$J,PSBTAB,PSBI1)="END" S PSBRECHD="ORD",PSBCNT2=PSBCNT2+1,^TMP("PSB",$J,"CVRSHT2",PSBCNT2)="END" Q
.I PSBRECHD="ORD" D ORD Q
.I PSBRECHD="ORC" D ORC^PSBCSUTY Q
.I PSBRECHD="ORF" D ORF^PSBCSUTY
.I PSBRECHD="MED" D MED^PSBCSUTY Q
S $P(^TMP("PSB",$J,"CVRSHT2",0),U)=PSBCNT2
M ^TMP("PSB",$J,PSBTAB)=^TMP("PSB",$J,"CVRSHT2") K PSBNXTDU D ADM
K ^TMP("PSB",$J,PSBTAB) M ^TMP("PSB",$J,PSBTAB)=^TMP("PSB",$J,"CVRSHT2") K ^TMP("PSB",$J,"CVRSHT2") D FINALPAS^PSBCSUTY
K ^TMP("PSB",$J,PSBTAB) M ^TMP("PSB",$J,PSBTAB)=^TMP("PSB",$J,"CVRSHT2") K ^TMP("PSB",$J,"CVRSHT2")
Q
ORD ;
S PSBCNT2=PSBCNT2+1,(PSBORREC,PSBXREC)=^TMP("PSB",$J,PSBTAB,PSBI1)
S ($P(PSBXREC,U,12),$P(PSBXREC,U,23),$P(PSBXREC,U,24),PSBSCHTM,PSBONMBR,PSBIENX,PSBBAGID,PSBACT,PSBACTBY,PSBACTDT,PSBACTPT,PSBPRNRE,PSBXX,PSBXXX)=""
S ^TMP("PSB",$J,"CVRSHT2",PSBCNT2)="ORD",$P(^TMP("PSB",$J,"CVRSHT2",PSBCNT2),U,2)=PSBXREC
S PSBSCHTM=$P(PSBORREC,U,14),PSBONMBR=$P(PSBORREC,U,2),PSBIENX=$P(PSBORREC,U,12),PSBLRGIV=0
D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBONMBR) S:(PSBONMBR["V")&'$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,+$G(PSBIVPSH)) PSBLRGIV=1
I '$D(PSBLST4X(PSBONMBR)) S PSBXX="" F PSBI=1:1 S PSBXX=$O(PSBADMX(PSBONMBR,PSBXX),-1) Q:PSBXX="" S PSBXXX="" D Q:$G(PSBLST4X(PSBONMBR))=4
.F S PSBXXX=$O(PSBADMX(PSBONMBR,PSBXX,PSBXXX)) Q:PSBXXX="" D Q:$G(PSBLST4X(PSBONMBR))=4
..I $$GET1^DIQ(53.79,PSBXXX_",","ACTION STATUS","I")'="N" S PSBLST4X(PSBONMBR,PSBXXX)="",PSBLST4X(PSBONMBR)=$G(PSBLST4X(PSBONMBR))+1
..I ($$GET1^DIQ(53.79,PSBXXX_",","ACTION STATUS","I")="N")&($O(PSBADMX(PSBONMBR,PSBXX))="") S PSBLST4X(PSBONMBR,PSBXXX)="",PSBLST4X(PSBONMBR)=$G(PSBLST4X(PSBONMBR))+1
I PSBIENX]"",$D(PSBLST4X(PSBONMBR,PSBIENX)) D
.S PSBBAGID=$$GET1^DIQ(53.79,PSBIENX_",","IV UNIQUE ID")
.S PSBACTDT=$$GET1^DIQ(53.79,PSBIENX_",","ACTION DATE/TIME","I")
.S PSBACT=$$GET1^DIQ(53.79,PSBIENX_",","ACTION STATUS","I")
.S PSBPRNRE=$$GET1^DIQ(53.79,PSBIENX_",","PRN REASON")
.S PSBACTBY=$$GETINIT^PSBCSUTX(PSBIENX,"I") S:PSBACTBY']"" PSBACTBY="***" ;Get initials of who took action, PSB*3*72
.S PSBACTPT=$$GETINIT^PSBCSUTX(PSBIENX,"II") ;Get IEN of who took action, PSB*3*72
.I '$D(PSBDONE(PSBIENX)) D
..I PSBLRGIV,(PSBFON]"") Q
..S PSBADMS(PSBONMBR,PSBSCHTM_PSBIENX)=PSBSCHTM_"^"_PSBBAGID_"^"_PSBIENX_"^"_PSBACT_"^"_PSBACTDT_"^"_PSBACTBY_"^"_PSBACTPT_"^"_PSBPRNRE
..I PSBLRGIV D
...I PSBOSP<PSBNOW S PSBADMS(PSBONMBR,"EXP")=""
...S PSBADMS(PSBONMBR,PSBSCHTM_PSBIENX,1)=1
..S PSBDONE(PSBIENX)="" K PSBADMX(PSBONMBR,PSBSCHTM,PSBIENX) D
...S PSBXX="" F S PSBXX=$O(PSBADMX(PSBONMBR,PSBXX)) Q:PSBXX="" I $D(PSBADMX(PSBONMBR,PSBXX,PSBIENX)) K PSBADMX(PSBONMBR,PSBXX,PSBIENX)
I PSBIENX']"" D
.S PSBADMS(PSBONMBR,PSBSCHTM_PSBIENX)=PSBSCHTM_"^^^^^^^"
.I PSBLRGIV S PSBADMS(PSBONMBR,PSBSCHTM,1)=1
I "^O^OC^P^"[(U_PSBSCHT_U)&('$D(PSBADMS(PSBONMBR))) S PSBADMS(PSBONMBR,PSBSCHTM_PSBIENX)=PSBSCHTM_"^^^^^^^"
S PSBRECHD="ORC" K PSBSCHTM S PSBXREC=""
Q
ADM ; Admn data
K PSBDONE S (PSBONMBR,PSBSCHTM)="" F PSBI1=2:1:$P(^TMP("PSB",$J,PSBTAB,0),U) D
.I $P(^TMP("PSB",$J,PSBTAB,PSBI1),U)="ORD" S PSBONMBR=$P(^TMP("PSB",$J,PSBTAB,PSBI1),U,3),$P(^TMP("PSB",$J,"CVRSHT2",PSBI1),U,15)=""
.S (PSBXX,PSBXXX)="" F S PSBXX=$O(PSBADMX(PSBONMBR,PSBXX)) Q:PSBXX="" F S PSBXXX=$O(PSBADMX(PSBONMBR,PSBXX,PSBXXX)) Q:PSBXXX="" D
..S PSBSCHTM=PSBXX,PSBIENX=PSBXXX
..I $D(PSBNOX(PSBONMBR)) I $P(^TMP("PSB",$J,"CVRSHT2",$O(PSBNOX(PSBONMBR,""))),U)="NOX" K ^TMP("PSB",$J,"CVRSHT2",$O(PSBNOX(PSBONMBR,"")))
..Q:'$D(PSBLST4X(PSBONMBR,PSBIENX))
..S PSBACT=$$GET1^DIQ(53.79,PSBIENX_",","ACTION STATUS","I")
..I PSBACT']"" S PSBACT="U"
..S PSBACTDT=$$GET1^DIQ(53.79,PSBIENX_",","ACTION DATE/TIME","I")
..S PSBBAGID=$$GET1^DIQ(53.79,PSBIENX_",","IV UNIQUE ID")
..S PSBPRNRE=$$GET1^DIQ(53.79,PSBIENX_",","PRN REASON")
..S PSBACTBY=$$GETINIT^PSBCSUTX(PSBIENX,"I") S:PSBACTBY']"" PSBACTBY="***" ;Get initials of who took action, PSB*3*72
..S PSBACTPT=$$GETINIT^PSBCSUTX(PSBIENX,"II") ;Get initials of who took action, PSB*3*72
..S PSBADMS(PSBONMBR,PSBSCHTM_PSBIENX)=PSBSCHTM_"^"_PSBBAGID_"^"_PSBIENX_"^"_PSBACT_"^"_PSBACTDT_"^"_PSBACTBY_"^"_PSBACTPT_"^"_PSBPRNRE
..I PSBIENX]"" K PSBADMX(PSBONMBR,PSBSCHTM,PSBIENX)
.I '$D(PSBADMS(PSBONMBR)) K ^TMP("PSB",$J,"CVRSHT2",PSBI1) Q
.I $P(^TMP("PSB",$J,PSBTAB,PSBI1),U)="END" K PSBADMS(PSBONMBR) Q
.I $P(^TMP("PSB",$J,PSBTAB,PSBI1+1),U)="END" D Q
..S PSBCNT2=1,PSBSCHTM=""
..F S PSBSCHTM=$O(PSBADMS(PSBONMBR,PSBSCHTM)) Q:+$G(PSBSCHTM)=0 D
...S PSBIENX=$P(PSBADMS(PSBONMBR,PSBSCHTM),U,3)
...I PSBIENX]"",'$D(PSBDONE(PSBIENX)) D
....I $D(PSBNOX(PSBONMBR)) I $P(^TMP("PSB",$J,"CVRSHT2",$O(PSBNOX(PSBONMBR,""))),U)="NOX" K ^TMP("PSB",$J,"CVRSHT2",$O(PSBNOX(PSBONMBR,"")))
....S PSBACT=$$GET1^DIQ(53.79,PSBIENX_",","ACTION STATUS","I")
....I PSBACT']"" S PSBACT="U"
....S PSBACTDT=$$GET1^DIQ(53.79,PSBIENX_",","ACTION DATE/TIME","I")
....Q:PSBACT="N"
....Q:$D(PSBADMS(PSBONMBR,"EXP"))&("SI"'[PSBACT)
....S $P(PSBADMS(PSBONMBR,PSBSCHTM),U,4)=PSBACT
....S ^TMP("PSB",$J,"CVRSHT2",PSBI1,PSBCNT2)="ADM^"_PSBADMS(PSBONMBR,PSBSCHTM)_"^"_$$NEXTADM(PSBDFNX,PSBONMBR),PSBCNT2=PSBCNT2+1
....S PSBDONE(PSBIENX)=""
....D CMT^PSBCSUTY
...I (PSBIENX']"")&($G(PSBADMS(PSBONMBR,PSBSCHTM,1))'=1) D
....S ^TMP("PSB",$J,"CVRSHT2",PSBI1,PSBCNT2)="ADM^"_PSBADMS(PSBONMBR,PSBSCHTM)_"^"_$$NEXTADM(PSBDFNX,PSBONMBR),PSBCNT2=PSBCNT2+1
....I $D(PSBNOX(PSBONMBR)) I $P(^TMP("PSB",$J,"CVRSHT2",$O(PSBNOX(PSBONMBR,""))),U)="NOX" K ^TMP("PSB",$J,"CVRSHT2",$O(PSBNOX(PSBONMBR,"")))
K PSBSCHTM
Q
NEXTADM(XX,YY) ;
S NEXTADM=""
I $D(PSBNXTDU(YY)) S NEXTADM=PSBNXTDU(YY) Q NEXTADM
D:YY'["P"
.S PSBPATX=XX,PSBORXX=YY D CLEAN^PSBVT,PSJ1^PSBVT(XX,YY)
.Q:(PSBORXX["V")&'$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,+$G(PSBIVPSH))
.S PSBGSCH=PSBADST,XX=PSBPATX,YY=PSBORXX,(NEXTADM,X,Y)="",X=$O(^PSB(53.79,"AORD",XX,YY,X),-1)
.I X]"" S Y=$O(^PSB(53.79,"AORD",XX,YY,X,Y),-1) I ($F("NM",$P(^PSB(53.79,Y,0),U,9))>1)!($P(^PSB(53.79,Y,0),U,9)="") S NEXTADM=X
.D:X']""
..S Y="",X=$O(^PSB(53.79,"AORDX",XX,YY,X),-1)
..I X]"" S Y=$O(^PSB(53.79,"AORDX",XX,YY,X,Y),-1) I $F("NM",$P(^PSB(53.79,Y,0),U,9))>1!($P(^PSB(53.79,Y,0),U,9)="") S NEXTADM=$P(^PSB(53.79,Y,0),U,6)
.D:NEXTADM=""
..S PSBGOTY=Y,PSBFREQ=$$GETFREQ^PSBVDLU1(XX,YY)
..S PSBFREQ=$S(PSBFREQ="O":1440,PSBFREQ="D":"",1:PSBFREQ)
..S (PSBXSCH,LSTTIME,LSTIEN)=""
..S:PSBGOTY]"" LSTTIME=$O(^PSB(53.79,"AORD",PSBPATX,PSBORXX,LSTTIME),-1) I LSTTIME]"" S LSTIEN=$O(^PSB(53.79,"AORD",PSBPATX,PSBORXX,LSTTIME,""),-1)
..I LSTIEN]"" S:$P(^PSB(53.79,LSTIEN,0),U,9)']"" LSTTIME=""
..S:LSTTIME="" LSTTIME=$$FMADD^XLFDT(PSBOST,,,,-0.1)
..I +PSBFREQ>0 S PSBXSCH=(+PSBFREQ/60)_"H"
..S X=LSTTIME
..F PSBIX1=1:1:($L(PSBGSCH,"-")+1) D Q:NEXTADM>LSTTIME
...I ($P(PSBGSCH,"-",PSBIX1))']"" D Q
....I PSBIX1=1 D Q
.....I X<PSBOST S NEXTADM=PSBOST Q
.....S X=PSBOST F S X=$$FMADD^XLFDT(X,,,PSBXSCH*60) S Y="" S Y=$O(^PSB(53.79,"AORD",PSBPATX,PSBORXX,Y),-1) I X>Y S NEXTADM=X Q
....I PSBGSCH]"" D Q
.....I (+PSBFREQ'>1440) F I=0:1 S PSBDTXX=$$FMADD^XLFDT(PSBOST,I) S $P(PSBDTXX,".",2)=($P(PSBGSCH,"-")) I PSBDTXX>LSTTIME S NEXTADM=PSBDTXX Q
.....I (+PSBFREQ'<1440),(1440#PSBFREQ=1440) F I=0:1 S PSBDTXX=$$FMADD^XLFDT(PSBOST,(I*(PSBFREQ\1440))) S $P(PSBDTXX,".",2)=($P(PSBGSCH,"-")) I PSBDTXX>LSTTIME S NEXTADM=PSBDTXX Q
....S $P(X,".",2)=$P(PSBGSCH,"-"),NEXTADM=$$FMADD^XLFDT(X,,,PSBXSCH*60) Q
...S $P(X,".",2)=$P(PSBGSCH,"-",PSBIX1) S:X<PSBOSP NEXTADM=X
.S:NEXTADM'<PSBOSP NEXTADM=""
.I $$PSBDCHK1^PSBVT1(PSBSCH) D
..S YY=PSBORXX,XX=PSBPATX
..I $G(LSTTIME)]"" S NEXTADM=$S(LSTTIME'<PSBOST:LSTTIME,NEXTADM>LSTTIME:NEXTADM,1:PSBOST)
..I PSBFREQ="" S PSBDTX=$P(NEXTADM,".") F PSBIX3=0:1 S X=$$FMADD^XLFDT(PSBDTX,PSBIX3) Q:X>PSBOSP D Q:$G(PSBYS)
...S PSBNXTDT=X D DW^%DTC S PSBYS=0 F PSBIX2=1:1 S PSBDY=$P($P(PSBSCH,"@"),"-",PSBIX2) Q:PSBDY="" I $E(X,1,2)=$E(PSBDY,1,2) S PSBYS=1 ;P149 change $F to $E
...I PSBYS S PSBSCTM=$$GETADMIN^PSBVDLU1(XX,YY,PSBNXTDT,"","") K ^TMP("PSB",$J,"GETADMIN") D
....F PSBIX4=1:1 S PSBTX=$P(PSBSCTM,"-",PSBIX4) Q:PSBTX="" D Q:PSBYS
.....I NEXTADM>(PSBNXTDT_"."_PSBTX) S PSBYS=0 Q
.....S NEXTADM=PSBNXTDT,$P(NEXTADM,".",2)=PSBTX
.....I NEXTADM]"" I (NEXTADM<PSBOST)!$D(^PSB(53.79,"AORD",PSBPATX,PSBORXX,+NEXTADM))!(NEXTADM>PSBOSP) S PSBYS=0,NEXTADM="" Q
.....S PSBYS=1
.S PSBNXTDU(PSBORXX)=NEXTADM
.D CLEAN^PSBVT
Q NEXTADM
GETINIT(PSBIEN,PSBTYPE) ;Get initials or name of who actually took the action, PSB*3*72
N PSBACT,PSBINT
S (PSBINT,PSBACT)="" I $D(^PSB(53.79,PSBIEN,.9)) D
.F S PSBACT=$O(^PSB(53.79,PSBIEN,.9,PSBACT),-1) Q:'PSBACT I $P($G(^PSB(53.79,PSBIEN,.9,PSBACT,0)),U,3)["Field: ACTION STATUS" S PSBINT=$P(^PSB(53.79,PSBIEN,.9,PSBACT,0),U,5) Q
I PSBINT,PSBTYPE="II" Q PSBINT
I PSBINT,PSBTYPE="I" S PSBINT=$$GET1^DIQ(200,PSBINT,1)
I PSBINT,PSBTYPE="N" S PSBINT=$$GET1^DIQ(200,PSBINT,.01)
Q PSBINT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBCSUTX 9600 printed Dec 13, 2024@01:40:02 Page 2
PSBCSUTX ;BIRMINGHAM/TEJ- BCMA-HSC COVER SHEET UTILITIES 2 ;Mar 2004
+1 ;;3.0;BAR CODE MED ADMIN;**16,13,38,32,72,107,149**;Mar 2004;Build 2
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ; Reference/IA
+4 ; $$GET1^DIQ/2056
+5 ; $$FMADD^XLFDT/10103
+6 ; NEW PERSON FILE/10060
ADD ; otput: ORD-ORC-DD-ADD-SOL-ID-ADM-CMT-END segmnts
+1 KILL PSBDONE
SET PSBRECHD="ORD"
SET PSBDONE=0
SET PSBCNT1=^TMP("PSB",$JOB,PSBTAB,0)
SET PSBCNT2=1
SET $PIECE(^TMP("PSB",$JOB,"CVRSHT2",0),U)=0
+2 FOR PSBI1=1:1:PSBCNT1
Begin DoDot:1
+3 IF PSBCNT1'>1
SET PSBDONE=1
QUIT
+4 IF PSBI1=1
SET ^TMP("PSB",$JOB,"CVRSHT2",PSBCNT2)=^TMP("PSB",$JOB,"CVRSHT",1)
QUIT
+5 IF ^TMP("PSB",$JOB,PSBTAB,PSBI1)="END"
SET PSBRECHD="ORD"
SET PSBCNT2=PSBCNT2+1
SET ^TMP("PSB",$JOB,"CVRSHT2",PSBCNT2)="END"
QUIT
+6 IF PSBRECHD="ORD"
DO ORD
QUIT
+7 IF PSBRECHD="ORC"
DO ORC^PSBCSUTY
QUIT
+8 IF PSBRECHD="ORF"
DO ORF^PSBCSUTY
+9 IF PSBRECHD="MED"
DO MED^PSBCSUTY
QUIT
End DoDot:1
if PSBDONE
QUIT
+10 SET $PIECE(^TMP("PSB",$JOB,"CVRSHT2",0),U)=PSBCNT2
+11 MERGE ^TMP("PSB",$JOB,PSBTAB)=^TMP("PSB",$JOB,"CVRSHT2")
KILL PSBNXTDU
DO ADM
+12 KILL ^TMP("PSB",$JOB,PSBTAB)
MERGE ^TMP("PSB",$JOB,PSBTAB)=^TMP("PSB",$JOB,"CVRSHT2")
KILL ^TMP("PSB",$JOB,"CVRSHT2")
DO FINALPAS^PSBCSUTY
+13 KILL ^TMP("PSB",$JOB,PSBTAB)
MERGE ^TMP("PSB",$JOB,PSBTAB)=^TMP("PSB",$JOB,"CVRSHT2")
KILL ^TMP("PSB",$JOB,"CVRSHT2")
+14 QUIT
ORD ;
+1 SET PSBCNT2=PSBCNT2+1
SET (PSBORREC,PSBXREC)=^TMP("PSB",$JOB,PSBTAB,PSBI1)
+2 SET ($PIECE(PSBXREC,U,12),$PIECE(PSBXREC,U,23),$PIECE(PSBXREC,U,24),PSBSCHTM,PSBONMBR,PSBIENX,PSBBAGID,PSBACT,PSBACTBY,PSBACTDT,PSBACTPT,PSBPRNRE,PSBXX,PSBXXX)=""
+3 SET ^TMP("PSB",$JOB,"CVRSHT2",PSBCNT2)="ORD"
SET $PIECE(^TMP("PSB",$JOB,"CVRSHT2",PSBCNT2),U,2)=PSBXREC
+4 SET PSBSCHTM=$PIECE(PSBORREC,U,14)
SET PSBONMBR=$PIECE(PSBORREC,U,2)
SET PSBIENX=$PIECE(PSBORREC,U,12)
SET PSBLRGIV=0
+5 DO CLEAN^PSBVT
DO PSJ1^PSBVT(DFN,PSBONMBR)
if (PSBONMBR["V")&'$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,+$GET(PSBIVPSH))
SET PSBLRGIV=1
+6 IF '$DATA(PSBLST4X(PSBONMBR))
SET PSBXX=""
FOR PSBI=1:1
SET PSBXX=$ORDER(PSBADMX(PSBONMBR,PSBXX),-1)
if PSBXX=""
QUIT
SET PSBXXX=""
Begin DoDot:1
+7 FOR
SET PSBXXX=$ORDER(PSBADMX(PSBONMBR,PSBXX,PSBXXX))
if PSBXXX=""
QUIT
Begin DoDot:2
+8 IF $$GET1^DIQ(53.79,PSBXXX_",","ACTION STATUS","I")'="N"
SET PSBLST4X(PSBONMBR,PSBXXX)=""
SET PSBLST4X(PSBONMBR)=$GET(PSBLST4X(PSBONMBR))+1
+9 IF ($$GET1^DIQ(53.79,PSBXXX_",","ACTION STATUS","I")="N")&($ORDER(PSBADMX(PSBONMBR,PSBXX))="")
SET PSBLST4X(PSBONMBR,PSBXXX)=""
SET PSBLST4X(PSBONMBR)=$GET(PSBLST4X(PSBONMBR))+1
End DoDot:2
if $GET(PSBLST4X(PSBONMBR))=4
QUIT
End DoDot:1
if $GET(PSBLST4X(PSBONMBR))=4
QUIT
+10 IF PSBIENX]""
IF $DATA(PSBLST4X(PSBONMBR,PSBIENX))
Begin DoDot:1
+11 SET PSBBAGID=$$GET1^DIQ(53.79,PSBIENX_",","IV UNIQUE ID")
+12 SET PSBACTDT=$$GET1^DIQ(53.79,PSBIENX_",","ACTION DATE/TIME","I")
+13 SET PSBACT=$$GET1^DIQ(53.79,PSBIENX_",","ACTION STATUS","I")
+14 SET PSBPRNRE=$$GET1^DIQ(53.79,PSBIENX_",","PRN REASON")
+15 ;Get initials of who took action, PSB*3*72
SET PSBACTBY=$$GETINIT^PSBCSUTX(PSBIENX,"I")
if PSBACTBY']""
SET PSBACTBY="***"
+16 ;Get IEN of who took action, PSB*3*72
SET PSBACTPT=$$GETINIT^PSBCSUTX(PSBIENX,"II")
+17 IF '$DATA(PSBDONE(PSBIENX))
Begin DoDot:2
+18 IF PSBLRGIV
IF (PSBFON]"")
QUIT
+19 SET PSBADMS(PSBONMBR,PSBSCHTM_PSBIENX)=PSBSCHTM_"^"_PSBBAGID_"^"_PSBIENX_"^"_PSBACT_"^"_PSBACTDT_"^"_PSBACTBY_"^"_PSBACTPT_"^"_PSBPRNRE
+20 IF PSBLRGIV
Begin DoDot:3
+21 IF PSBOSP<PSBNOW
SET PSBADMS(PSBONMBR,"EXP")=""
+22 SET PSBADMS(PSBONMBR,PSBSCHTM_PSBIENX,1)=1
End DoDot:3
+23 SET PSBDONE(PSBIENX)=""
KILL PSBADMX(PSBONMBR,PSBSCHTM,PSBIENX)
Begin DoDot:3
+24 SET PSBXX=""
FOR
SET PSBXX=$ORDER(PSBADMX(PSBONMBR,PSBXX))
if PSBXX=""
QUIT
IF $DATA(PSBADMX(PSBONMBR,PSBXX,PSBIENX))
KILL PSBADMX(PSBONMBR,PSBXX,PSBIENX)
End DoDot:3
End DoDot:2
End DoDot:1
+25 IF PSBIENX']""
Begin DoDot:1
+26 SET PSBADMS(PSBONMBR,PSBSCHTM_PSBIENX)=PSBSCHTM_"^^^^^^^"
+27 IF PSBLRGIV
SET PSBADMS(PSBONMBR,PSBSCHTM,1)=1
End DoDot:1
+28 IF "^O^OC^P^"[(U_PSBSCHT_U)&('$DATA(PSBADMS(PSBONMBR)))
SET PSBADMS(PSBONMBR,PSBSCHTM_PSBIENX)=PSBSCHTM_"^^^^^^^"
+29 SET PSBRECHD="ORC"
KILL PSBSCHTM
SET PSBXREC=""
+30 QUIT
ADM ; Admn data
+1 KILL PSBDONE
SET (PSBONMBR,PSBSCHTM)=""
FOR PSBI1=2:1:$PIECE(^TMP("PSB",$JOB,PSBTAB,0),U)
Begin DoDot:1
+2 IF $PIECE(^TMP("PSB",$JOB,PSBTAB,PSBI1),U)="ORD"
SET PSBONMBR=$PIECE(^TMP("PSB",$JOB,PSBTAB,PSBI1),U,3)
SET $PIECE(^TMP("PSB",$JOB,"CVRSHT2",PSBI1),U,15)=""
+3 SET (PSBXX,PSBXXX)=""
FOR
SET PSBXX=$ORDER(PSBADMX(PSBONMBR,PSBXX))
if PSBXX=""
QUIT
FOR
SET PSBXXX=$ORDER(PSBADMX(PSBONMBR,PSBXX,PSBXXX))
if PSBXXX=""
QUIT
Begin DoDot:2
+4 SET PSBSCHTM=PSBXX
SET PSBIENX=PSBXXX
+5 IF $DATA(PSBNOX(PSBONMBR))
IF $PIECE(^TMP("PSB",$JOB,"CVRSHT2",$ORDER(PSBNOX(PSBONMBR,""))),U)="NOX"
KILL ^TMP("PSB",$JOB,"CVRSHT2",$ORDER(PSBNOX(PSBONMBR,"")))
+6 if '$DATA(PSBLST4X(PSBONMBR,PSBIENX))
QUIT
+7 SET PSBACT=$$GET1^DIQ(53.79,PSBIENX_",","ACTION STATUS","I")
+8 IF PSBACT']""
SET PSBACT="U"
+9 SET PSBACTDT=$$GET1^DIQ(53.79,PSBIENX_",","ACTION DATE/TIME","I")
+10 SET PSBBAGID=$$GET1^DIQ(53.79,PSBIENX_",","IV UNIQUE ID")
+11 SET PSBPRNRE=$$GET1^DIQ(53.79,PSBIENX_",","PRN REASON")
+12 ;Get initials of who took action, PSB*3*72
SET PSBACTBY=$$GETINIT^PSBCSUTX(PSBIENX,"I")
if PSBACTBY']""
SET PSBACTBY="***"
+13 ;Get initials of who took action, PSB*3*72
SET PSBACTPT=$$GETINIT^PSBCSUTX(PSBIENX,"II")
+14 SET PSBADMS(PSBONMBR,PSBSCHTM_PSBIENX)=PSBSCHTM_"^"_PSBBAGID_"^"_PSBIENX_"^"_PSBACT_"^"_PSBACTDT_"^"_PSBACTBY_"^"_PSBACTPT_"^"_PSBPRNRE
+15 IF PSBIENX]""
KILL PSBADMX(PSBONMBR,PSBSCHTM,PSBIENX)
End DoDot:2
+16 IF '$DATA(PSBADMS(PSBONMBR))
KILL ^TMP("PSB",$JOB,"CVRSHT2",PSBI1)
QUIT
+17 IF $PIECE(^TMP("PSB",$JOB,PSBTAB,PSBI1),U)="END"
KILL PSBADMS(PSBONMBR)
QUIT
+18 IF $PIECE(^TMP("PSB",$JOB,PSBTAB,PSBI1+1),U)="END"
Begin DoDot:2
+19 SET PSBCNT2=1
SET PSBSCHTM=""
+20 FOR
SET PSBSCHTM=$ORDER(PSBADMS(PSBONMBR,PSBSCHTM))
if +$GET(PSBSCHTM)=0
QUIT
Begin DoDot:3
+21 SET PSBIENX=$PIECE(PSBADMS(PSBONMBR,PSBSCHTM),U,3)
+22 IF PSBIENX]""
IF '$DATA(PSBDONE(PSBIENX))
Begin DoDot:4
+23 IF $DATA(PSBNOX(PSBONMBR))
IF $PIECE(^TMP("PSB",$JOB,"CVRSHT2",$ORDER(PSBNOX(PSBONMBR,""))),U)="NOX"
KILL ^TMP("PSB",$JOB,"CVRSHT2",$ORDER(PSBNOX(PSBONMBR,"")))
+24 SET PSBACT=$$GET1^DIQ(53.79,PSBIENX_",","ACTION STATUS","I")
+25 IF PSBACT']""
SET PSBACT="U"
+26 SET PSBACTDT=$$GET1^DIQ(53.79,PSBIENX_",","ACTION DATE/TIME","I")
+27 if PSBACT="N"
QUIT
+28 if $DATA(PSBADMS(PSBONMBR,"EXP"))&("SI"'[PSBACT)
QUIT
+29 SET $PIECE(PSBADMS(PSBONMBR,PSBSCHTM),U,4)=PSBACT
+30 SET ^TMP("PSB",$JOB,"CVRSHT2",PSBI1,PSBCNT2)="ADM^"_PSBADMS(PSBONMBR,PSBSCHTM)_"^"_$$NEXTADM(PSBDFNX,PSBONMBR)
SET PSBCNT2=PSBCNT2+1
+31 SET PSBDONE(PSBIENX)=""
+32 DO CMT^PSBCSUTY
End DoDot:4
+33 IF (PSBIENX']"")&($GET(PSBADMS(PSBONMBR,PSBSCHTM,1))'=1)
Begin DoDot:4
+34 SET ^TMP("PSB",$JOB,"CVRSHT2",PSBI1,PSBCNT2)="ADM^"_PSBADMS(PSBONMBR,PSBSCHTM)_"^"_$$NEXTADM(PSBDFNX,PSBONMBR)
SET PSBCNT2=PSBCNT2+1
+35 IF $DATA(PSBNOX(PSBONMBR))
IF $PIECE(^TMP("PSB",$JOB,"CVRSHT2",$ORDER(PSBNOX(PSBONMBR,""))),U)="NOX"
KILL ^TMP("PSB",$JOB,"CVRSHT2",$ORDER(PSBNOX(PSBONMBR,"")))
End DoDot:4
End DoDot:3
End DoDot:2
QUIT
End DoDot:1
+36 KILL PSBSCHTM
+37 QUIT
NEXTADM(XX,YY) ;
+1 SET NEXTADM=""
+2 IF $DATA(PSBNXTDU(YY))
SET NEXTADM=PSBNXTDU(YY)
QUIT NEXTADM
+3 if YY'["P"
Begin DoDot:1
+4 SET PSBPATX=XX
SET PSBORXX=YY
DO CLEAN^PSBVT
DO PSJ1^PSBVT(XX,YY)
+5 if (PSBORXX["V")&'$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,+$GET(PSBIVPSH))
QUIT
+6 SET PSBGSCH=PSBADST
SET XX=PSBPATX
SET YY=PSBORXX
SET (NEXTADM,X,Y)=""
SET X=$ORDER(^PSB(53.79,"AORD",XX,YY,X),-1)
+7 IF X]""
SET Y=$ORDER(^PSB(53.79,"AORD",XX,YY,X,Y),-1)
IF ($FIND("NM",$PIECE(^PSB(53.79,Y,0),U,9))>1)!($PIECE(^PSB(53.79,Y,0),U,9)="")
SET NEXTADM=X
+8 if X']""
Begin DoDot:2
+9 SET Y=""
SET X=$ORDER(^PSB(53.79,"AORDX",XX,YY,X),-1)
+10 IF X]""
SET Y=$ORDER(^PSB(53.79,"AORDX",XX,YY,X,Y),-1)
IF $FIND("NM",$PIECE(^PSB(53.79,Y,0),U,9))>1!($PIECE(^PSB(53.79,Y,0),U,9)="")
SET NEXTADM=$PIECE(^PSB(53.79,Y,0),U,6)
End DoDot:2
+11 if NEXTADM=""
Begin DoDot:2
+12 SET PSBGOTY=Y
SET PSBFREQ=$$GETFREQ^PSBVDLU1(XX,YY)
+13 SET PSBFREQ=$SELECT(PSBFREQ="O":1440,PSBFREQ="D":"",1:PSBFREQ)
+14 SET (PSBXSCH,LSTTIME,LSTIEN)=""
+15 if PSBGOTY]""
SET LSTTIME=$ORDER(^PSB(53.79,"AORD",PSBPATX,PSBORXX,LSTTIME),-1)
IF LSTTIME]""
SET LSTIEN=$ORDER(^PSB(53.79,"AORD",PSBPATX,PSBORXX,LSTTIME,""),-1)
+16 IF LSTIEN]""
if $PIECE(^PSB(53.79,LSTIEN,0),U,9)']""
SET LSTTIME=""
+17 if LSTTIME=""
SET LSTTIME=$$FMADD^XLFDT(PSBOST,,,,-0.1)
+18 IF +PSBFREQ>0
SET PSBXSCH=(+PSBFREQ/60)_"H"
+19 SET X=LSTTIME
+20 FOR PSBIX1=1:1:($LENGTH(PSBGSCH,"-")+1)
Begin DoDot:3
+21 IF ($PIECE(PSBGSCH,"-",PSBIX1))']""
Begin DoDot:4
+22 IF PSBIX1=1
Begin DoDot:5
+23 IF X<PSBOST
SET NEXTADM=PSBOST
QUIT
+24 SET X=PSBOST
FOR
SET X=$$FMADD^XLFDT(X,,,PSBXSCH*60)
SET Y=""
SET Y=$ORDER(^PSB(53.79,"AORD",PSBPATX,PSBORXX,Y),-1)
IF X>Y
SET NEXTADM=X
QUIT
End DoDot:5
QUIT
+25 IF PSBGSCH]""
Begin DoDot:5
+26 IF (+PSBFREQ'>1440)
FOR I=0:1
SET PSBDTXX=$$FMADD^XLFDT(PSBOST,I)
SET $PIECE(PSBDTXX,".",2)=($PIECE(PSBGSCH,"-"))
IF PSBDTXX>LSTTIME
SET NEXTADM=PSBDTXX
QUIT
+27 IF (+PSBFREQ'<1440)
IF (1440#PSBFREQ=1440)
FOR I=0:1
SET PSBDTXX=$$FMADD^XLFDT(PSBOST,(I*(PSBFREQ\1440)))
SET $PIECE(PSBDTXX,".",2)=($PIECE(PSBGSCH,"-"))
IF PSBDTXX>LSTTIME
SET NEXTADM=PSBDTXX
QUIT
End DoDot:5
QUIT
+28 SET $PIECE(X,".",2)=$PIECE(PSBGSCH,"-")
SET NEXTADM=$$FMADD^XLFDT(X,,,PSBXSCH*60)
QUIT
End DoDot:4
QUIT
+29 SET $PIECE(X,".",2)=$PIECE(PSBGSCH,"-",PSBIX1)
if X<PSBOSP
SET NEXTADM=X
End DoDot:3
if NEXTADM>LSTTIME
QUIT
End DoDot:2
+30 if NEXTADM'<PSBOSP
SET NEXTADM=""
+31 IF $$PSBDCHK1^PSBVT1(PSBSCH)
Begin DoDot:2
+32 SET YY=PSBORXX
SET XX=PSBPATX
+33 IF $GET(LSTTIME)]""
SET NEXTADM=$SELECT(LSTTIME'<PSBOST:LSTTIME,NEXTADM>LSTTIME:NEXTADM,1:PSBOST)
+34 IF PSBFREQ=""
SET PSBDTX=$PIECE(NEXTADM,".")
FOR PSBIX3=0:1
SET X=$$FMADD^XLFDT(PSBDTX,PSBIX3)
if X>PSBOSP
QUIT
Begin DoDot:3
+35 ;P149 change $F to $E
SET PSBNXTDT=X
DO DW^%DTC
SET PSBYS=0
FOR PSBIX2=1:1
SET PSBDY=$PIECE($PIECE(PSBSCH,"@"),"-",PSBIX2)
if PSBDY=""
QUIT
IF $EXTRACT(X,1,2)=$EXTRACT(PSBDY,1,2)
SET PSBYS=1
+36 IF PSBYS
SET PSBSCTM=$$GETADMIN^PSBVDLU1(XX,YY,PSBNXTDT,"","")
KILL ^TMP("PSB",$JOB,"GETADMIN")
Begin DoDot:4
+37 FOR PSBIX4=1:1
SET PSBTX=$PIECE(PSBSCTM,"-",PSBIX4)
if PSBTX=""
QUIT
Begin DoDot:5
+38 IF NEXTADM>(PSBNXTDT_"."_PSBTX)
SET PSBYS=0
QUIT
+39 SET NEXTADM=PSBNXTDT
SET $PIECE(NEXTADM,".",2)=PSBTX
+40 IF NEXTADM]""
IF (NEXTADM<PSBOST)!$DATA(^PSB(53.79,"AORD",PSBPATX,PSBORXX,+NEXTADM))!(NEXTADM>PSBOSP)
SET PSBYS=0
SET NEXTADM=""
QUIT
+41 SET PSBYS=1
End DoDot:5
if PSBYS
QUIT
End DoDot:4
End DoDot:3
if $GET(PSBYS)
QUIT
End DoDot:2
+42 SET PSBNXTDU(PSBORXX)=NEXTADM
+43 DO CLEAN^PSBVT
End DoDot:1
+44 QUIT NEXTADM
GETINIT(PSBIEN,PSBTYPE) ;Get initials or name of who actually took the action, PSB*3*72
+1 NEW PSBACT,PSBINT
+2 SET (PSBINT,PSBACT)=""
IF $DATA(^PSB(53.79,PSBIEN,.9))
Begin DoDot:1
+3 FOR
SET PSBACT=$ORDER(^PSB(53.79,PSBIEN,.9,PSBACT),-1)
if 'PSBACT
QUIT
IF $PIECE($GET(^PSB(53.79,PSBIEN,.9,PSBACT,0)),U,3)["Field: ACTION STATUS"
SET PSBINT=$PIECE(^PSB(53.79,PSBIEN,.9,PSBACT,0),U,5)
QUIT
End DoDot:1
+4 IF PSBINT
IF PSBTYPE="II"
QUIT PSBINT
+5 IF PSBINT
IF PSBTYPE="I"
SET PSBINT=$$GET1^DIQ(200,PSBINT,1)
+6 IF PSBINT
IF PSBTYPE="N"
SET PSBINT=$$GET1^DIQ(200,PSBINT,.01)
+7 QUIT PSBINT
