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

PRCHPAT.m

Go to the documentation of this file.
  1. PRCHPAT ;ID/RSD-CREATE ENTRY IN FILE 442 ;1/13/93 15:46
  1. V ;;5.1;IFCAP;**46,176**;Oct 20, 2000;Build 11
  1. ;Per VHA Directive 2004-038, this routine should not be modified
  1. ;
  1. EN ;ENTER NEW PAT IN FILE 442;
  1. ;;**VERSION 1.52**;
  1. K PRCHPO Q:'$D(PRC("SITE"))!('$D(DUZ))!('$D(PRCHP("T"))) Q:'$D(^PRCD(442.5,+PRCHP("T"),0))
  1. S PRCHP("A")=$S($D(PRCHP("A")):PRCHP("A"),1:"PAT NUMBER") K DA,DIC,DLAYGO
  1. S PRCHP("S")=+$G(PRCHP("S"))
  1. N ERR
  1. ;
  1. ENPO S DIC="^PRC(442.6,",DIC(0)="QEMZ"
  1. S DIC("S")="I +$P(^(0),U,1)=PRC(""SITE""),+$P(^(0),U,5)=PRCHP(""S"")"
  1. S:$D(PRCHP("S2")) DIC("S")=DIC("S")_PRCHP("S2")
  1. W !!,"ENTER A NEW ",PRCHP("A")," OR A COMMON NUMBERING SERIES"
  1. W !?3,PRCHP("A"),": " R X:DTIME G:X=""!(X=U) ENPOQ
  1. I $E(X,1)="?" S D="C" D IX^DIC G ENPO
  1. ;
  1. EN2 I $L(X)<4 S D="C" D IX^DIC G ENPO:Y<0,NUM
  1. ; check for valid common numbering series
  1. I X?6AN D CHKCNS G:ERR=1 ENPO
  1. S X=PRC("SITE")_"-"_X,DIC(0)="LEQ" I $D(^PRC(442,"B",X)) W !?3,PRCHP("A")," ",X," already exist !" G ENPO
  1. ;
  1. ENPO1 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
  1. S $P(^PRC(442,PRCHPO,0),U,2)=PRCHP("T"),$P(^(12),U,4,5)=DUZ_U_Y,^PRC(442,"F",PRCHP("T"),DA)=""
  1. D DOCID^PRCHUTL
  1. G ENPOQ
  1. ;
  1. NUM L +^PRC(442.6,+Y,0):$G(DILOCKTM,3) 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
  1. ;
  1. Z 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
  1. W !?3,"Are you adding '",X,"' as a new ",PRCHP("A"),$C(7) S %="" D YN^DICN I %'=1 L -^PRC(442.6,+Y,0) G ENPO
  1. S $P(^PRC(442.6,+Y,0),U,4)=+Z,DIC(0)="L" L -^PRC(442.6,+Y,0)
  1. G ENPO1
  1. ;
  1. CHKCNS ;check common numbering series
  1. ;
  1. N SAVEX,CNS,Y
  1. S SAVEX=X,ERR=0
  1. S CNS=$E(X,1,3)
  1. S X=CNS
  1. S DIC(0)="X"
  1. S D="C"
  1. S DIC="^PRC(442.6,"
  1. D IX^DIC
  1. I Y>0 S X=SAVEX Q
  1. I Y=-1 D
  1. . S X=$E(CNS,1,2)
  1. . S DIC(0)="X"
  1. . S D="C"
  1. . S DIC="^PRC(442.6,"
  1. . D IX^DIC
  1. I Y=-1 D
  1. . S ERR=1
  1. . W !?3," Not a valid Common Numbering Series.",$C(7)
  1. S X=SAVEX
  1. Q
  1. ;
  1. W1 W !?3," Common numbering series is being edited by another user, try later",$C(7)
  1. G ENPO
  1. ;
  1. W2 L -^PRC(442.6,+Y,0) W !?3,"UPPER BOUND HAS BEEN EXCEEDED FOR COMMON NUMBERING SERIES ",$P(Y,U,2),$C(7)
  1. G ENPO
  1. ;
  1. W3 W " PAT Number already exist, please try again ",$C(7)
  1. G ENPO
  1. ;
  1. ENPOQ K DIC,DLAYGO,%DT,PRCHP
  1. Q
  1. ;
  1. EN1 ;INPUT TRANSFORM FOR APPROPRIATION IN FILE 430
  1. S Z0=DA,Z1=DA(1),Z2=$P(^PRCA(430,Z1,2,Z0,0),U,1),DIC("S")="I $P(^(0),U,5)]"""""
  1. 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
  1. S PRC("APP")=$P(Y(0),U,3),(PRC("FY"),PRC("FYI"))=Z2 D ^PRCFY S X=PRC("APP")
  1. EN1Q S DA=Z0,DA(1)=Z1 K PRC("APP"),PRC("FYI"),Z0,Z1,Z2,DIC D EN4
  1. Q
  1. ;
  1. EN3 ;LOOK UP PO IN FILE 442
  1. K PRCHPO,PRCHNEW,DA,DIC,D0,DQ Q:'$D(PRC("SITE")) S DIC="^PRC(442,",DIC(0)="QEAMZ"
  1. S D=$S($G(PRCHPC)=1:"APCS",$G(PRCHPC)=2:"APCP",$G(PRCHDELV):"APCD",1:"C")
  1. 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:"")
  1. ;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:"")
  1. 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=""
  1. Q
  1. ;
  1. EN4 ;set appropriation to the flat field in the 430,AR file.
  1. 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
  1. Q