PRCHFPNT ;WISC/RSD/RHD-PRINT FREE FORM 2138 ;10/27/95  2:23 PM
V ;;5.1;IFCAP;;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S U="^",PRCH0=$G(^PRC(442,D0,0)),PRCH1=$G(^(1)),PRCH12=$G(^(12))
 S PRCHSIT=$P(PRCH0,"-",1)
 N PRCHSIT1
 S PRCHSIT1=$S($P($G(^PRC(442,D0,23)),U,7)]"":$P(^(23),U,7),1:$P(PRCH0,"-"))
 S PRCHDES=$S($D(PRCHQ("DEST")):PRCHQ("DEST"),$D(DEST):DEST,1:"")
 I $P(PRCH0,U,2)=8 S PRCHNRQ=1
 I $G(PRCHNRQ)=1 D SJD
 S:IOBS="" IOBS="$C(8)" Q:PRCH0']""!(PRCH1']"")
 ;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:"")
 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))
 ;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:"")
 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)
 S PRCHST=$G(^PRC(411,PRCHSIT1,0)),PRCHHSP=$G(^(3)),X=+$P(PRCH12,U,6),PRCHINV=$G(^(4,X,0))
 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
 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
 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
 I $D(PRCHI),PRCHI,$D(^PRC(442,D0,15,PRCHI,0)) S $P(^(0),U,2)=$P(^(0),U,2)-1
 K PRCHI
 G STP^PRCHFPT0
 ;
LC 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))
 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))
 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)
 Q
 ;
LC1 F PRCHJ=0:0 S PRCHJ=$O(^PRC(442.7,PRCHK,1,PRCHJ)) Q:'PRCHJ  S X=^(PRCHJ,0) D DIWP^PRCUTL($G(DA))
 S PRCHLC=+^UTILITY($J,"W",1) S:PRCHLC>0 $P(^PRC(442,D0,15,PRCH,0),U,2)=PRCHLC+1
 Q
 ;
FTYP ; RETURN FACILITY TYPE IN 'PRCHFTYP'
 N PRCSUB
 ;S PRCHFTYP="V.A. *FACILITY TYPE UNDEFINED*",X=$S($D(^PRC(411,PRC("SITE"),0)):$P(^(0),"^",7),1:"") S:X="" X=1
 S PRCHFTYP="V.A. *FACILITY TYPE UNDEFINED*"
 S X=$P($G(^PRC(411,PRC("SITE"),0)),"^",7) S:X="" X=1
 I $P($G(^PRC(442,D0,23)),U,7)]"" S PRCSUB=$P(^(23),U,7) D
 . S X=$P($G(^PRC(411,PRCSUB,0)),"^",7) S:X="" X=1
 ;I '$D(PRCHFTP2) S PRCHFTYP=$S($D(^PRC(411.2,+X,0)):$P(^(0),U,2),1:"")
 I '$D(PRCHFTP2) S PRCHFTYP=$P($G(^PRC(411.2,+X,0)),U,2)
 ;I $D(PRCHFTP2) S PRCHFTYP=$S($D(^PRC(411.2,+X,0)):$P(^(0),U,1),1:"")
 I $D(PRCHFTP2) S PRCHFTYP=$P($G(^PRC(411.2,+X,0)),U,1)
 K PRCHFTP2
 Q
 ;
FTYPS ;ABBREVIATED FACILITY TYPE
 S PRCHFTP2="SHORT"
 G FTYP
 ;
SJD ;SET JULIAN DATE
 S X=$P(PRCH1,U,15) D JD^PRCFDLN S PRCHJD=$E(Y,4)_$E(Y,1,3)
 Q
 ;
PSNO ;PRINT SERIAL NO.
 W:$D(^PRC(442,D0,2,PRCH,4)) $S($P(^(4),U,1):" ("_PRCHJD_"-"_$P(^(4),U,1)_")",1:"")
 Q
FTYP1 ; RETURN FACILITY TYPE IN 'PRCHFTYP'
 N PRCSUB
 S PRCHFTYP="V.A. *FACILITY TYPE UNDEFINED*"
 S X=$P($G(^PRC(411,PRC("SITE"),0)),"^",7) S:X="" X=1
 I $P($G(^PRCS(410,D0,0)),U,10)]"" S PRCSUB=$P(^(0),U,10) D
 . S X=$P($G(^PRC(411,PRCSUB,0)),"^",7) S:X="" X=1
 I '$D(PRCHFTP2) S PRCHFTYP=$P($G(^PRC(411.2,+X,0)),U,2)
 I $D(PRCHFTP2) S PRCHFTYP=$P($G(^PRC(411.2,+X,0)),U,1)
 K PRCHFTP2
 Q