137 lines
8.6 KiB
Mathematica
137 lines
8.6 KiB
Mathematica
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
|