Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSBCSUTY

PSBCSUTY.m

Go to the documentation of this file. 
  1. PSBCSUTY ;BIRMINGHAM/TEJ- BCMA-HSC COVER SHEET UTILITIES 3 ;Mar 2004
  1.  ;;3.0;BAR CODE MED ADMIN;**16,32,64**;Mar 2004;Build 14
  1.  ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
  1.  ;
  1.  ; Reference/IA
  1.  ; $$GET1^DIQ/2056
  1.  ; File 200/10060
  1. CMT ; Comment per admin.
  1.  S (PSBIENX,PSBPRNRE)="",PSBIENX=+$P(PSBADMS(PSBONMBR,PSBSCHTM),U,3),PSBPRNRE=$P(PSBADMS(PSBONMBR,PSBSCHTM),U,8)
  1.  D:+$O(^PSB(53.79,PSBIENX,.3,""),-1)>0
  1.  .S PSBI2=0 F  S PSBI2=$O(^PSB(53.79,PSBIENX,.3,PSBI2)) Q:PSBI2=""  D
  1.  ..S $P(^TMP("PSB",$J,"CVRSHT2",PSBI1,PSBCNT2),U)="CMT",$P(^TMP("PSB",$J,"CVRSHT2",PSBI1,PSBCNT2),U,2)=$P(^PSB(53.79,PSBIENX,.3,PSBI2,0),U)
  1.  ..S $P(^TMP("PSB",$J,"CVRSHT2",PSBI1,PSBCNT2),U,4)=$P(^PSB(53.79,PSBIENX,.3,PSBI2,0),U,2)
  1.  ..S $P(^TMP("PSB",$J,"CVRSHT2",PSBI1,PSBCNT2),U,5)=$$GET1^DIQ(200,$P(^PSB(53.79,PSBIENX,.3,PSBI2,0),U,2)_",","INITIAL")
  1.  ..S $P(^TMP("PSB",$J,"CVRSHT2",PSBI1,PSBCNT2),U,6)=$P(^PSB(53.79,PSBIENX,.3,PSBI2,0),U,3),PSBCNT2=PSBCNT2+1
  1.  D:($G(PSBPRNRE)]"")&($$GET1^DIQ(53.79,PSBIENX_",","PRN EFFECTIVENESS")]"")
  1.  .S $P(^TMP("PSB",$J,"CVRSHT2",PSBI1,PSBCNT2),U)="CMT",$P(^TMP("PSB",$J,"CVRSHT2",PSBI1,PSBCNT2),U,3)=$$GET1^DIQ(53.79,PSBIENX_",","PRN EFFECTIVENESS")
  1.  .S $P(^TMP("PSB",$J,"CVRSHT2",PSBI1,PSBCNT2),U,4)=$$GET1^DIQ(53.79,PSBIENX_",","PRN EFFECTIVENESS ENTERED BY","I")
  1.  .S $P(^TMP("PSB",$J,"CVRSHT2",PSBI1,PSBCNT2),U,5)=$$GET1^DIQ(53.79,PSBIENX_",","PRN EFFECTIVENESS ENTERED BY:INITIAL")
  1.  .S $P(^TMP("PSB",$J,"CVRSHT2",PSBI1,PSBCNT2),U,6)=$$GET1^DIQ(53.79,PSBIENX_",","PRN EFFECTIVENESS ENTERED AT","I"),PSBCNT2=PSBCNT2+1
  1.  Q
  1. XFERBAGS ;
  1.  ;  Logic to "move IV bags"
  1.  ;  Construct Temp arrays PSBADMX,PSBDONE
  1.  Q:PSBPONX']""
  1.  K PSBCHKED
  1.  S PSBNX2=PSBONX,PSBDFN2=PSBDFN,PSBPNX2=PSBPONX,PSBFN2=PSBFON F  Q:PSBFN2]""  D  Q:PSBPONX']""  S PSBPNX2=PSBPONX I $G(PSBCHKED(PSBPONX))=1 K PSBCHKED Q
  1.  .D CLEAN^PSBVT S PSBPONX=PSBPNX2,PSBCHKED(PSBPONX)=1 D PSJ1^PSBVT(PSBDFN2,PSBPONX)
  1.  .S (PSBXX,PSBXXX)="" F  S PSBXX=$O(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBXX)) Q:PSBXX=""  D
  1.  ..S PSBXXX=$O(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBXX,PSBXXX)) Q:PSBXXX=""  Q:$P(^PSB(53.79,PSBXXX,0),U,9)="C"  S:'$D(PSBDONE(PSBXXX)) (PSBADMX(PSBNX2,PSBXX,PSBXXX),PSBDONE(PSBXXX))=""
  1.  ; Refresh data
  1.  D CLEAN^PSBVT,PSJ1^PSBVT(PSBDFN2,PSBNX2)
  1.  K PSBNX2,PSBDFN2,PSBPNX2,PSBFN2
  1.  Q
  1. GETADMX ;
  1.  S (PSBXX,PSBXXX)="" F  S PSBXX=$O(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBXX)) Q:PSBXX=""  D
  1.  .Q:(PSBXX<PSBMHBCK)&'PSBLVIV
  1.  .F  S PSBXXX=$O(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBXX,PSBXXX)) Q:PSBXXX=""  Q:(PSBFON]"")&($P(^PSB(53.79,PSBXXX,0),U,9)'="C")&(PSBLVIV)  D
  1.  ..S (PSBADMX(PSBONX,PSBXX,PSBXXX),PSBDONE(PSBXXX))=""
  1.  ; Check "actions" that DO NOT get filed into AORDX !!
  1.  S (PSBXX,PSBXXX)="" F  S PSBXX=$O(^PSB(53.79,"AORD",PSBDFN,PSBONX,PSBXX)) Q:PSBXX=""  D
  1.  .F  S PSBXXX=$O(^PSB(53.79,"AORD",PSBDFN,PSBONX,PSBXX,PSBXXX)) Q:PSBXXX=""  D
  1.  ..S:('$D(PSBDONE(PSBXXX)))&($P(^PSB(53.79,PSBXXX,0),U,6)'<PSBMHBCK) PSBADMX(PSBONX,PSBXX,PSBXXX)=""
  1.  K PSBXX,PSBXXX,PSBDONE
  1.  Q
  1. LVIV ;
  1.  ; Set up variables to later extract LVIV data
  1.  ; Add all LVIVs that have been active with in the window!!
  1.  I (PSBOSP'<PSBWBEG)&(PSBOSP'>PSBWEND) D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBNOW\1_".",PSBDDS,PSBSOLS,PSBADDS,"CVRSHT")
  1.  S PSBEXPRD=0 I (PSBFON']"")&(PSBOSP<PSBNOW) S PSBEXPRD=1
  1.  S (PSBXX,PSBXXX)="" F  S PSBXX=$O(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBXX)) Q:PSBXX=""  D
  1.  .S PSBXXX=$O(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBXX,PSBXXX)) Q:PSBXXX=""
  1.  .I "IS"[$P(^PSB(53.79,PSBXXX,0),U,9)&(PSBFON']"") S PSBEXPRD=0
  1.  .S:'$D(PSBDONE(PSBXXX))&(PSBFON="") (PSBADMX(PSBONX,PSBXX,PSBXXX),PSBDONE(PSBXXX))=""
  1.  S (PSBXX,PSBXXX)="" F  S PSBXX=$O(PSBADMX(PSBONX,PSBXX)) Q:PSBXX=""  D
  1.  .S PSBXXX=$O(PSBADMX(PSBONX,PSBXX,PSBXXX)) Q:PSBXXX=""
  1.  .I "IS"[$P(^PSB(53.79,PSBXXX,0),U,9)&(PSBFON']"") S PSBEXPRD=0
  1.  .S:'$D(PSBDONE(PSBXXX))&(PSBFON="") (PSBADMX(PSBONX,PSBXX,PSBXXX),PSBDONE(PSBXXX))=""
  1.  Q
  1. QUT() ;
  1.  S QUT=0
  1.  D NOW^%DTC ;Set % variable, PSB*3*64
  1.  I PSBOST>($$FMADD^XLFDT($$NOW^XLFDT,,,$$GET^XPAR("DIV","PSB ADMIN BEFORE"))) S QUT=1 Q QUT
  1.  I '(($F("ED",PSBOSTS)'>1)&(PSBOSP'<%)) S QUT=1 Q QUT
  1.  Q QUT
  1. USED() ;
  1.  S (PSBXIEN,PSBUSD,USED)=0,PSBBAGX=$P(PSBXREC,U,2)
  1.  I $$QUT() S (PSBUSD,USED)=1 Q PSBUSD
  1.  S PSBXXX="" F  S PSBXXX=$O(^PSB(53.79,"AUID",PSBDFNX,PSBXXX)) Q:PSBXXX=""  D  Q:PSBUSD
  1.  .I $D(^PSB(53.79,"AUID",PSBDFNX,PSBXXX,PSBBAGX)) S PSBXIEN=$O(^PSB(53.79,"AUID",PSBDFNX,PSBXXX,PSBBAGX,"")) S:$F("GICSHRM",$P(^PSB(53.79,PSBXIEN,0),U,9))>1 (PSBUSD,USED)=1,PSBOBAG(PSBONMBR)=""
  1.  Q USED
  1. ORC ; Ord cmmnts
  1.  S PSBCNT2=PSBCNT2+1,^TMP("PSB",$J,"CVRSHT2",PSBCNT2)="ORC",$P(^TMP("PSB",$J,"CVRSHT2",PSBCNT2),U,2)=^TMP("PSB",$J,PSBTAB,PSBI1),PSBRECHD="ORF"
  1.  Q
  1. ORF ; Ordr flag  "ORF^FLAG^Flg Comment"
  1.  K ^TMP("PSJ1",$J),PSBNOX
  1.  D EN^PSJBCMA1(PSBDFN,PSBONMBR,1)
  1.  ;Set STAT FLAG
  1.  I $P(^TMP("PSJ1",$J,7),U,1) S PSBCNT2=PSBCNT2+1,^TMP("PSB",$J,"CVRSHT2",PSBCNT2)="ORF^STAT"
  1.  ;Set IM/CPRS ord flg and cmment
  1.  I $P(^TMP("PSJ1",$J,7),U,2) D
  1.  .S PSBCNT2=PSBCNT2+1,^TMP("PSB",$J,"CVRSHT2",PSBCNT2)="ORF^CPRS^"_$P(^TMP("PSJ1",$J,7),U,3)_U_$P(^TMP("PSJ1",$J,7),U,4)
  1.  .I $P(^TMP("PSJ1",$J,7),U,3)']"" D
  1.  ..S $P(^TMP("PSB",$J,"CVRSHT2",PSBCNT2),U,2)="CPRS"
  1.  ..S $P(^TMP("PSB",$J,"CVRSHT2",PSBCNT2),U,3)="*PSJ DATA ERROR* ^ PSJ Order Flag Error"
  1.  K ^TMP("PSJ1",$J)
  1.  ;Set No Act Flag
  1.  I ('$D(^PSB(53.79,"AORDX",PSBDFN,PSBONMBR))) I (PSBLRGIV) I '$D(PSBADMX(PSBONMBR)) I $P(PSBORREC,U,26)>$G(%,PSBNOW) D
  1.  .S PSBCNT2=PSBCNT2+1,^TMP("PSB",$J,"CVRSHT2",PSBCNT2)="ORF^NOX^No Action Taken On Order"
  1.  .S PSBNOX(PSBONMBR,PSBCNT2)=""
  1.  S PSBRECHD="MED"
  1.  Q
  1. MED ; Cnstr DD,ADD,SOL,ID
  1.  F I=PSBI1:1 S PSBXREC=^TMP("PSB",$J,PSBTAB,I) Q:PSBXREC="END"  D
  1.  .I $P(PSBXREC,U)="ID" S PSBUSED=$$USED()  Q:PSBUSED
  1.  .S PSBCNT2=PSBCNT2+1,^TMP("PSB",$J,"CVRSHT2",PSBCNT2)=PSBXREC
  1.  S PSBI1=I-1
  1.  Q
  1. FINALPAS ;
  1.  S PSBI1="^TMP(""PSB"",$J,""CVRSHT"")",PSBCNT1=0
  1.  F  S PSBI1=$Q(@PSBI1) Q:PSBI1["CVRSHT2"  D
  1.  .I $QS(PSBI1,4)'>1 S ^TMP("PSB",$J,"CVRSHT2",PSBCNT1)=@PSBI1,PSBCNT1=PSBCNT1+1 Q
  1.  .K PSBX2 M PSBX2=^TMP("PSB",$J,"CVRSHT",$QS(PSBI1,4))
  1.  .I $QS(PSBI1,5)="" S ^TMP("PSB",$J,"CVRSHT2",PSBCNT1)=@PSBI1,PSBCNT1=PSBCNT1+1 Q
  1.  .K PSBDONE
  1.  .I '$D(PSBX2(1)) S ^TMP("PSB",$J,"CVRSHT2",PSBCNT1)=@PSBI1,PSBCNT1=PSBCNT1+1 Q
  1.  .F PSBI2=1:1 Q:'$D(PSBX2(PSBI2))  D  ;sort actn/cmmnt rev. chrono
  1.  ..Q:$D(PSBDONE(PSBI2))
  1.  ..S PSBXDTTM=(-1*($P(PSBX2(PSBI2),U,6)))_+($E($P(PSBX2(PSBI2),U,4),$L($P(PSBX2(PSBI2),U,4))-6,999)),PSBMCODE=$P(PSBX2(PSBI2),U)
  1.  ..D:(+PSBXDTTM<0)&(PSBMCODE["ADM")
  1.  ...S PSBX3(+PSBXDTTM,-999)=PSBX2(PSBI2),PSBDONE(PSBI2)="" K ^TMP("PSB",$J,"CVRSHT",$QS(PSBI1,4),PSBI2)
  1.  ...F PSBI3=1:1 Q:'$D(PSBX2(PSBI2+PSBI3))  Q:$P(PSBX2(PSBI2+PSBI3),U)'["CMT"  D
  1.  ....S PSBX3(+PSBXDTTM,-1*PSBI3)=PSBX2(PSBI2+PSBI3),PSBDONE(PSBI2+PSBI3)="" K ^TMP("PSB",$J,"CVRSHT",$QS(PSBI1,4),PSBI2+PSBI3)
  1.  ..D:(+PSBXDTTM=0)&(PSBMCODE["ADM")
  1.  ...S PSBX3(PSBI2,0)=PSBX2(PSBI2),PSBDONE(PSBI2)="" K ^TMP("PSB",$J,"CVRSHT",$QS(PSBI1,4),PSBI2)
  1.  .I $D(PSBX3) D  K PSBX3
  1.  ..S PSBI2="" F  S PSBI2=$O(PSBX3(PSBI2)) Q:PSBI2=""  S PSBI3="" F  S PSBI3=$O(PSBX3(PSBI2,PSBI3)) Q:PSBI3=""  D
  1.  ...S ^TMP("PSB",$J,"CVRSHT2",PSBCNT1)=PSBX3(PSBI2,PSBI3),PSBCNT1=PSBCNT1+1
  1.  S $P(^TMP("PSB",$J,"CVRSHT2",0),U)=PSBCNT1-1
  1.  Q