source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBOCE1.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.0 KB
Line 
1PSBOCE1 ;BIRMINGHAM/TEJ-Expired/DC'd/EXPIRING ORDERS REPORT (1) ;Mar 2004
2 ;;3.0;BAR CODE MED ADMIN;**32**;Mar 2004;Build 32
3 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
4 ;
5FMTDT(Y) ;
6 ; Format date/time as displayed by GUI ie. 02/25/2005@2323
7 N X S X=$E(Y,4,5) X ^DD("DD") S Y=$TR(Y," ,:","//") S $P(Y,"/")=X
8 Q Y
9BUILDLN ; Constr recs
10 K J S J(0)="" F PSBFLD=1:1:8 S J=1 D FORMDAT(PSBFLD) S J($O(PSBRPLN(""),-1))=""
11 ; Write administration info...
12 Q:'PSBXFLG
13 S J=($O(J(""),-1)+1),PSBRPLN(J)=PSBBLANK,J(J)="",J=J+1
14 S (N,Y)=""
15 M PSBLGD("INITIALS")=PSBLGD(PSBX2X,"X","INITIALS")
16 F S Y=$O(PSBADM(PSBX2X,Y)) Q:Y']"" D
17 .F S N=$O(PSBADM(PSBX2X,Y,N)) Q:N']"" D
18 ..I $D(PSBBID(PSBX2X,$P(N,U,2))) S PSBDATA(2,0)="BAG ID: "_PSBBID(PSBX2X,$P(N,U,2))
19 ..S $E(PSBDATA(2,0),25)="ACTION BY: "_$P(PSBADM(PSBX2X,Y,N),U,7)_" "_$$FMTDT^PSBOCE1($E($P(PSBADM(PSBX2X,Y,N),U,6),1,12))
20 ..S X=$P(PSBADM(PSBX2X,Y,N),U,5) S $E(PSBDATA(2,0),56)="ACTION: "_$S(X="G":"GIVEN",X="R":"REFUSED",X="RM":"REMOVED",X="H":"HELD",X="S":"STOPPED",X="I":"INFUSING",X="C":"COMPLETED",X="M":"MISSING DOSE",X=" ":"*UNKNOWN*",1:" ")
21 ..I $D(PSBPRNR(PSBX2X)) S $E(PSBDATA(2,0),72)="PRN REASON: "_PSBPRNR(PSBX2X,$P(N,U,2))
22 ..I $G(PSBDATA(2,0))]" " D WRAPPER(1,132-1,PSBDATA(2,0)) K PSBDATA(2) S J=J+1
23 ..I $D(PSBPRNEF(PSBX2X,$P(N,U,2))) S PSBDATA(2,0)="PRN EFFECTIVENESS: "_PSBPRNEF(PSBX2X,$P(N,U,2))
24 ..I $G(PSBDATA(2,0))]" " D WRAPPER(30,132-30,PSBDATA(2,0)) K PSBDATA(2) S J=J+1
25 ..I ('PSBCFLG)!('$D(PSBCMT(PSBX2X,$P(N,U,2)))) S PSBRPLN(J)=PSBBLANK,J(J)="",J=J+1 Q
26 ..M PSBLGD("INITIALS")=PSBLGD(PSBX2X,"C","INITIALS")
27 ..S X="" F S X=$O(PSBCMT(PSBX2X,$P(N,U,2),X)) Q:X']"" D
28 ...S PSBDATA(2,0)="COMMENT BY: "_$S($P(PSBCMT(PSBX2X,$P(N,U,2),X),U,5)]"":$P(PSBCMT(PSBX2X,$P(N,U,2),X),U,5)_" "_$$FMTDT^PSBOCE1($E($P(PSBCMT(PSBX2X,$P(N,U,2),X),U,6),1,12)),1:" n/a ")
29 ...S PSBDATA(2,0)=PSBDATA(2,0)_" COMMENT: "_$S($P(PSBCMT(PSBX2X,$P(N,U,2),X),U,2)]"":$P(PSBCMT(PSBX2X,$P(N,U,2),X),U,2),1:" ")
30 ...I $G(PSBDATA(2,0))]" " D WRAPPER(30,132-30,PSBDATA(2,0)) K PSBDATA(2) S J=J+1
31 ..S PSBRPLN(J)=PSBBLANK,J(J)="",J=J+1
32 Q
33FORMDAT(FLD) ;
34 K PSBVAL
35 Q:'$D(PSBDATA(1,FLD))
36 S PSBVAL=PSBDATA(1,FLD)
37 D WRAPPER(@("PSBTAB"_(FLD-1))+1,((@("PSBTAB"_(FLD))-(@("PSBTAB"_(FLD-1))+1))),PSBVAL)
38 I FLD=4 S J=$O(J(""),-1)+1,PSBVAL=PSBDATA(1,4,0) D WRAPPER(@("PSBTAB"_(FLD-1))+1,((@("PSBTAB"_(FLD))-(@("PSBTAB"_(FLD-1))+1))),PSBVAL)
39 Q
40WRAPPER(X,Y,Z) ; Text WRAP
41 N PSB
42 I ($L(Z)>0),$F(Z,"""")>1 F Q:$F(Z,"""")'>1 S Z=$TR(Z,"""","^")
43 F Q:'$L(Z) D
44 .I $L(Z)<Y S $E(PSBRPLN(J),X)=Z S Z="" Q
45 .F PSB=Y:-1:0 Q:$E(Z,PSB)=" "
46 .S:PSB<1 PSB=Y
47 .S $E(PSBRPLN(J),X)=$E(Z,1,PSB)
48 .I $L(PSBRPLN(J),"^")>1 F X=1:1:$L(PSBRPLN(J),"^")-1 S $P(PSBRPLN(J),"^",X)=$P(PSBRPLN(J),"^",X)_""""
49 .S PSBRPLN(J)=$TR(PSBRPLN(J),"^","""")
50 .S Z=$E(Z,PSB+1,250),J=J+1,J(J)=""
51 Q ""
52PGC ;
53 S PSBPGNUM=PSBPGNUM+1,PSBLNTOT=PSBTOPHD S PSBMORE=$S(PSBMORE>(IOSL-(PSBTOPHD)):(IOSL-(PSBTOPHD)),1:PSBMORE)
54 S NOTE(PSBPGNUM)="( "_PSBX1X_" - Continued )"
55 Q
Note: See TracBrowser for help on using the repository browser.