source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHPAT.m@ 1259

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

initial load of WorldVistAEHR

File size: 3.4 KB
Line 
1PRCHPAT ;ID/RSD-CREATE ENTRY IN FILE 442 ;1/13/93 15:46
2V ;;5.1;IFCAP;**46**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5EN ;ENTER NEW PAT IN FILE 442;
6 ;;**VERSION 1.52**;
7 K PRCHPO Q:'$D(PRC("SITE"))!('$D(DUZ))!('$D(PRCHP("T"))) Q:'$D(^PRCD(442.5,+PRCHP("T"),0))
8 S PRCHP("A")=$S($D(PRCHP("A")):PRCHP("A"),1:"PAT NUMBER") K DA,DIC,DLAYGO
9 S PRCHP("S")=+$G(PRCHP("S"))
10 N ERR
11 ;
12ENPO S DIC="^PRC(442.6,",DIC(0)="QEMZ"
13 S DIC("S")="I +$P(^(0),U,1)=PRC(""SITE""),+$P(^(0),U,5)=PRCHP(""S"")"
14 S:$D(PRCHP("S2")) DIC("S")=DIC("S")_PRCHP("S2")
15 W !!,"ENTER A NEW ",PRCHP("A")," OR A COMMON NUMBERING SERIES"
16 W !?3,PRCHP("A"),": " R X:DTIME G:X=""!(X=U) ENPOQ
17 I $E(X,1)="?" S D="C" D IX^DIC G ENPO
18 ;
19EN2 I $L(X)<4 S D="C" D IX^DIC G ENPO:Y<0,NUM
20 ; check for valid common numbering series
21 I X?6AN D CHKCNS G:ERR=1 ENPO
22 S X=PRC("SITE")_"-"_X,DIC(0)="LEQ" I $D(^PRC(442,"B",X)) W !?3,PRCHP("A")," ",X," already exist !" G ENPO
23 ;
24ENPO1 K DIC("S") S PRCHP("NEW")="",DIC="^PRC(442,",DLAYGO=442 D ^DIC G ENPO:Y<0,W3:'+$P(Y,U,3) S (DA,PRCHPO)=+Y,%DT="T",X="NOW" D ^%DT
25 S $P(^PRC(442,PRCHPO,0),U,2)=PRCHP("T"),$P(^(12),U,4,5)=DUZ_U_Y,^PRC(442,"F",PRCHP("T"),DA)=""
26 D DOCID^PRCHUTL
27 G ENPOQ
28 ;
29NUM L ^PRC(442.6,+Y,0):1 G:'$T W1 S X=$P(Y,U,2),Z=$S(+$P(Y(0),U,4)<$P(Y(0),U,2):+$P(Y(0),U,2),1:+$P(Y(0),U,4)),L=$L(X)#2-3
30 ;
31Z G:Z>$P(Y(0),U,3) W2 S Z="000"_Z,Z=$E(Z,$L(Z)+L,$L(Z)),X=X_Z I $D(^PRC(442,"B",X)) S Z=Z+1,X=$P(Y,U,2) G Z
32 W !?3,"Are you adding '",X,"' as a new ",PRCHP("A"),$C(7) S %="" D YN^DICN I %'=1 L G ENPO
33 S $P(^PRC(442.6,+Y,0),U,4)=+Z,DIC(0)="L" L
34 G ENPO1
35 ;
36CHKCNS ;check common numbering series
37 ;
38 N SAVEX,CNS,Y
39 S SAVEX=X,ERR=0
40 S CNS=$E(X,1,3)
41 S X=CNS
42 S DIC(0)="X"
43 S D="C"
44 S DIC="^PRC(442.6,"
45 D IX^DIC
46 I Y>0 S X=SAVEX Q
47 I Y=-1 D
48 . S X=$E(CNS,1,2)
49 . S DIC(0)="X"
50 . S D="C"
51 . S DIC="^PRC(442.6,"
52 . D IX^DIC
53 I Y=-1 D
54 . S ERR=1
55 . W !?3," Not a valid Common Numbering Series.",$C(7)
56 S X=SAVEX
57 Q
58 ;
59W1 L W !?3," Common numbering series is being edited by another user, try later",$C(7)
60 G ENPO
61 ;
62W2 L W !?3,"UPPER BOUND HAS BEEN EXCEEDED FOR COMMON NUMBERING SERIES ",$P(Y,U,2),$C(7)
63 G ENPO
64 ;
65W3 W " PAT Number already exist, please try again ",$C(7)
66 G ENPO
67 ;
68ENPOQ K DIC,DLAYGO,%DT,PRCHP
69 Q
70 ;
71EN1 ;INPUT TRANSFORM FOR APPROPRIATION IN FILE 430
72 S Z0=DA,Z1=DA(1),Z2=$P(^PRCA(430,Z1,2,Z0,0),U,1),DIC("S")="I $P(^(0),U,5)]"""""
73 S DIC="^PRCD(420.3,",DIC(0)="MEZQ",D="C" D IX^DIC K X G:Y<0 EN1Q S $P(^PRCA(430,Z1,2,Z0,0),U,5)=+Y I $P(Y(0),U,5)[" " S X=$P(Y(0),U,5) G EN1Q
74 S PRC("APP")=$P(Y(0),U,3),(PRC("FY"),PRC("FYI"))=Z2 D ^PRCFY S X=PRC("APP")
75EN1Q S DA=Z0,DA(1)=Z1 K PRC("APP"),PRC("FYI"),Z0,Z1,Z2,DIC D EN4
76 Q
77 ;
78EN3 ;LOOK UP PO IN FILE 442
79 K PRCHPO,PRCHNEW,DA,DIC,D0,DQ Q:'$D(PRC("SITE")) S DIC="^PRC(442,",DIC(0)="QEAMZ"
80 S D=$S($G(PRCHPC)=1:"APCS",$G(PRCHPC)=2:"APCP",$G(PRCHDELV):"APCD",1:"C")
81 S DIC("A")=$S($D(PRCHP("A")):PRCHP("A"),1:"PURCHASE ORDER: "),DIC("S")="I +$P(^(0),U,1)=PRC(""SITE"")"_$S($D(PRCHP("S")):","_PRCHP("S"),1:"")
82 ;W !! D IX^DIC K DIC,PRCHP S X="" Q:+Y<0 S (PRCHPO,DA)=+Y,X=$S($D(^PRC(442,DA,7)):$S($D(^PRCD(442.3,+^(7),0)):$P(^(0),U,2),1:""),1:"")
83 W !! D IX^DIC K DIC,PRCHP S X="" Q:+Y<0 S (PRCHPO,DA)=+Y,X=$P($G(^PRCD(442.3,+$G(^PRC(442,DA,7)),0)),U,2) S:X=0 X=""
84 Q
85 ;
86EN4 ;set appropriation to the flat field in the 430,AR file.
87 Q:'$D(X) S Z0=X S:$E(Z0,3)?1N Z0=$E(Z0,1,2)_" "_$E(Z0,4,7) S $P(^PRCA(430,DA(1),0),U,18)=Z0 K Z0
88 Q
Note: See TracBrowser for help on using the repository browser.