- 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
- PSBCSUTX ;BIRMINGHAM/TEJ- BCMA-HSC COVER SHEET UTILITIES 2 ;Mar 2004
- +1 ;;3.0;BAR CODE MED ADMIN;**16,13,38,32**;Mar 2004;Build 32
- +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 ; $$SCH^XLFDT/10103
- +6 ; $$FMADD^XLFDT/10103
- 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 SET PSBACTBY=$$GET1^DIQ(53.79,PSBIENX_",","ACTION BY:INITIAL")
- IF PSBACTBY']""
- SET PSBACTBY="***"
- +16 SET PSBACTPT=$$GET1^DIQ(53.79,PSBIENX_",","ACTION BY","I")
- +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 SET PSBACTBY=$$GET1^DIQ(53.79,PSBIENX_",","ACTION BY:INITIAL")
- IF PSBACTBY']""
- SET PSBACTBY="***"
- +13 SET PSBACTPT=$$GET1^DIQ(53.79,PSBIENX_",","ACTION BY","I")
- +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=$$SCH^XLFDT(PSBXSCH,X)
- 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=$$SCH^XLFDT(PSBXSCH,X)
- 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 SET PSBNXTDT=X
- DO DW^%DTC
- SET PSBYS=0
- FOR PSBIX2=1:1
- SET PSBDY=$PIECE($PIECE(PSBSCH,"@"),"-",PSBIX2)
- IF PSBDY=""
- QUIT
- IF $FIND(X,PSBDY)>1
- 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
