source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHFPNT.m@ 1800

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

initial load of WorldVistAEHR
File size: 3.6 KB
Line 
1PRCHFPNT ;WISC/RSD/RHD-PRINT FREE FORM 2138 ;10/27/95 2:23 PM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 S U="^",PRCH0=$G(^PRC(442,D0,0)),PRCH1=$G(^(1)),PRCH12=$G(^(12))
5 S PRCHSIT=$P(PRCH0,"-",1)
6 N PRCHSIT1
7 S PRCHSIT1=$S($P($G(^PRC(442,D0,23)),U,7)]"":$P(^(23),U,7),1:$P(PRCH0,"-"))
8 S PRCHDES=$S($D(PRCHQ("DEST")):PRCHQ("DEST"),$D(DEST):DEST,1:"")
9 I $P(PRCH0,U,2)=8 S PRCHNRQ=1
10 I $G(PRCHNRQ)=1 D SJD
11 S:IOBS="" IOBS="$C(8)" Q:PRCH0']""!(PRCH1']"")
12 ;S PRCHFPT=$S($D(PRCHFPT):PRCHFPT,1:0),(PRCHS,PRCHDA,PRCHDTA)=0,PRCHSHP="",$P(PRCHULN,"_",97)="" I +$P(PRCH0,U,2)'=4,$P(PRCH1,U,12)="" S PRCHSHP=$S($D(^PRC(411,PRCHSIT,1,+$P(PRCH1,U,3),0)):^(0),1:"")
13 S PRCHFPT=+$G(PRCHFPT),(PRCHS,PRCHDA,PRCHDTA)=0,PRCHSHP="",$P(PRCHULN,"_",97)="" I +$P(PRCH0,U,2)'=4,$P(PRCH1,U,12)="" S PRCHSHP=$G(^PRC(411,PRCHSIT1,1,+$P(PRCH1,U,3),0))
14 ;I '$T,$P(PRCH1,U,12)]"" S PRCHSHP=$S($D(^PRC(440.2,$P(PRCH1,U,12),0)):^(0),1:""),PRCHS=1 I +PRCHSHP>0 S $P(PRCHSHP,U,1)=$S($D(^DPT(+PRCHSHP,0)):$E($P(^(0),U,1),1,21),1:"")
15 I '$T,$P(PRCH1,U,12)]"" S PRCHSHP=$G(^PRC(440.2,$P(PRCH1,U,12),0)),PRCHS=1 I +PRCHSHP>0 S $P(PRCHSHP,U,1)=$E($P($G(^DPT(+PRCHSHP,0)),U,1),1,21)
16 S PRCHST=$G(^PRC(411,PRCHSIT1,0)),PRCHHSP=$G(^(3)),X=+$P(PRCH12,U,6),PRCHINV=$G(^(4,X,0))
17 S DIWL=1,DIWR=33,DIWF="",PRCH=0 F I=0:0 S PRCH=$O(^PRC(442,D0,2,PRCH)) Q:'PRCH K ^UTILITY($J,"W") D LC
18 S DIWL=1,DIWR=64,DIWF="",PRCH=0 K ^PRC(442,D0,15,9999999) I $D(^PRC(442,D0,11,PRCHFPT,0)),$P(^(0),U,10)="Y" S ^PRC(442,D0,15,9999999,0)=9999999
19 F I=0:0 S PRCH=$O(^PRC(442,D0,15,PRCH)) Q:'PRCH S PRCHI=PRCH,PRCHK=+^(PRCH,0) I $D(^PRC(442.7,PRCHK,0)),$O(^(1,0)) K ^UTILITY($J,"W") D LC1
20 I $D(PRCHI),PRCHI,$D(^PRC(442,D0,15,PRCHI,0)) S $P(^(0),U,2)=$P(^(0),U,2)-1
21 K PRCHI
22 G STP^PRCHFPT0
23 ;
24LC Q:'$D(^PRC(442,D0,2,PRCH,1,0)) S PRCHJ=0 F S PRCHJ=$O(^PRC(442,D0,2,PRCH,1,PRCHJ)) Q:PRCHJ="" S X=^(PRCHJ,0) D DIWP^PRCUTL($G(DA))
25 S PRCHLC=+^UTILITY($J,"W",1) S:PRCHLC>0 $P(^PRC(442,D0,2,PRCH,2),U,4)=PRCHLC,X=$O(^PRC(442,D0,2,PRCH,3,"AC",PRCHFPT,0))
26 I PRCHDES="R",X,$D(^PRC(442,D0,2,PRCH,3,X,0)) S PRCHDA=PRCHDA+$P(^(0),U,5),PRCHDTA=PRCHDTA+$P(^(0),U,3)
27 Q
28 ;
29LC1 F PRCHJ=0:0 S PRCHJ=$O(^PRC(442.7,PRCHK,1,PRCHJ)) Q:'PRCHJ S X=^(PRCHJ,0) D DIWP^PRCUTL($G(DA))
30 S PRCHLC=+^UTILITY($J,"W",1) S:PRCHLC>0 $P(^PRC(442,D0,15,PRCH,0),U,2)=PRCHLC+1
31 Q
32 ;
33FTYP ; RETURN FACILITY TYPE IN 'PRCHFTYP'
34 N PRCSUB
35 ;S PRCHFTYP="V.A. *FACILITY TYPE UNDEFINED*",X=$S($D(^PRC(411,PRC("SITE"),0)):$P(^(0),"^",7),1:"") S:X="" X=1
36 S PRCHFTYP="V.A. *FACILITY TYPE UNDEFINED*"
37 S X=$P($G(^PRC(411,PRC("SITE"),0)),"^",7) S:X="" X=1
38 I $P($G(^PRC(442,D0,23)),U,7)]"" S PRCSUB=$P(^(23),U,7) D
39 . S X=$P($G(^PRC(411,PRCSUB,0)),"^",7) S:X="" X=1
40 ;I '$D(PRCHFTP2) S PRCHFTYP=$S($D(^PRC(411.2,+X,0)):$P(^(0),U,2),1:"")
41 I '$D(PRCHFTP2) S PRCHFTYP=$P($G(^PRC(411.2,+X,0)),U,2)
42 ;I $D(PRCHFTP2) S PRCHFTYP=$S($D(^PRC(411.2,+X,0)):$P(^(0),U,1),1:"")
43 I $D(PRCHFTP2) S PRCHFTYP=$P($G(^PRC(411.2,+X,0)),U,1)
44 K PRCHFTP2
45 Q
46 ;
47FTYPS ;ABBREVIATED FACILITY TYPE
48 S PRCHFTP2="SHORT"
49 G FTYP
50 ;
51SJD ;SET JULIAN DATE
52 S X=$P(PRCH1,U,15) D JD^PRCFDLN S PRCHJD=$E(Y,4)_$E(Y,1,3)
53 Q
54 ;
55PSNO ;PRINT SERIAL NO.
56 W:$D(^PRC(442,D0,2,PRCH,4)) $S($P(^(4),U,1):" ("_PRCHJD_"-"_$P(^(4),U,1)_")",1:"")
57 Q
58FTYP1 ; RETURN FACILITY TYPE IN 'PRCHFTYP'
59 N PRCSUB
60 S PRCHFTYP="V.A. *FACILITY TYPE UNDEFINED*"
61 S X=$P($G(^PRC(411,PRC("SITE"),0)),"^",7) S:X="" X=1
62 I $P($G(^PRCS(410,D0,0)),U,10)]"" S PRCSUB=$P(^(0),U,10) D
63 . S X=$P($G(^PRC(411,PRCSUB,0)),"^",7) S:X="" X=1
64 I '$D(PRCHFTP2) S PRCHFTYP=$P($G(^PRC(411.2,+X,0)),U,2)
65 I $D(PRCHFTP2) S PRCHFTYP=$P($G(^PRC(411.2,+X,0)),U,1)
66 K PRCHFTP2
67 Q
Note: See TracBrowser for help on using the repository browser.