source: WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBCSUTX.m@ 846

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