PSBCSUTX ;BIRMINGHAM/TEJ- BCMA-HSC COVER SHEET UTILITIES 2 ;Mar 2004
 ;;3.0;BAR CODE MED ADMIN;**16,13,38,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
 ; $$SCH^XLFDT/10103
 ; $$FMADD^XLFDT/10103
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=$$GET1^DIQ(53.79,PSBIENX_",","ACTION BY:INITIAL") S:PSBACTBY']"" PSBACTBY="***"
 .S PSBACTPT=$$GET1^DIQ(53.79,PSBIENX_",","ACTION BY","I")
 .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=$$GET1^DIQ(53.79,PSBIENX_",","ACTION BY:INITIAL") S:PSBACTBY']"" PSBACTBY="***"
 ..S PSBACTPT=$$GET1^DIQ(53.79,PSBIENX_",","ACTION BY","I")
 ..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=$$SCH^XLFDT(PSBXSCH,X) 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=$$SCH^XLFDT(PSBXSCH,X) 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 $F(X,PSBDY)>1 S PSBYS=1
 ...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