PRCHPAT ;ID/RSD-CREATE ENTRY IN FILE 442 ;1/13/93 15:46
V ;;5.1;IFCAP;**46,176**;Oct 20, 2000;Build 11
;Per VHA Directive 2004-038, this routine should not be modified
;
EN ;ENTER NEW PAT IN FILE 442;
;;**VERSION 1.52**;
K PRCHPO Q:'$D(PRC("SITE"))!('$D(DUZ))!('$D(PRCHP("T"))) Q:'$D(^PRCD(442.5,+PRCHP("T"),0))
S PRCHP("A")=$S($D(PRCHP("A")):PRCHP("A"),1:"PAT NUMBER") K DA,DIC,DLAYGO
S PRCHP("S")=+$G(PRCHP("S"))
N ERR
;
ENPO S DIC="^PRC(442.6,",DIC(0)="QEMZ"
S DIC("S")="I +$P(^(0),U,1)=PRC(""SITE""),+$P(^(0),U,5)=PRCHP(""S"")"
S:$D(PRCHP("S2")) DIC("S")=DIC("S")_PRCHP("S2")
W !!,"ENTER A NEW ",PRCHP("A")," OR A COMMON NUMBERING SERIES"
W !?3,PRCHP("A"),": " R X:DTIME G:X=""!(X=U) ENPOQ
I $E(X,1)="?" S D="C" D IX^DIC G ENPO
;
EN2 I $L(X)<4 S D="C" D IX^DIC G ENPO:Y<0,NUM
; check for valid common numbering series
I X?6AN D CHKCNS G:ERR=1 ENPO
S X=PRC("SITE")_"-"_X,DIC(0)="LEQ" I $D(^PRC(442,"B",X)) W !?3,PRCHP("A")," ",X," already exist !" G ENPO
;
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
S $P(^PRC(442,PRCHPO,0),U,2)=PRCHP("T"),$P(^(12),U,4,5)=DUZ_U_Y,^PRC(442,"F",PRCHP("T"),DA)=""
D DOCID^PRCHUTL
G ENPOQ
;
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
;
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
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
S $P(^PRC(442.6,+Y,0),U,4)=+Z,DIC(0)="L" L -^PRC(442.6,+Y,0)
G ENPO1
;
CHKCNS ;check common numbering series
;
N SAVEX,CNS,Y
S SAVEX=X,ERR=0
S CNS=$E(X,1,3)
S X=CNS
S DIC(0)="X"
S D="C"
S DIC="^PRC(442.6,"
D IX^DIC
I Y>0 S X=SAVEX Q
I Y=-1 D
. S X=$E(CNS,1,2)
. S DIC(0)="X"
. S D="C"
. S DIC="^PRC(442.6,"
. D IX^DIC
I Y=-1 D
. S ERR=1
. W !?3," Not a valid Common Numbering Series.",$C(7)
S X=SAVEX
Q
;
W1 W !?3," Common numbering series is being edited by another user, try later",$C(7)
G ENPO
;
W2 L -^PRC(442.6,+Y,0) W !?3,"UPPER BOUND HAS BEEN EXCEEDED FOR COMMON NUMBERING SERIES ",$P(Y,U,2),$C(7)
G ENPO
;
W3 W " PAT Number already exist, please try again ",$C(7)
G ENPO
;
ENPOQ K DIC,DLAYGO,%DT,PRCHP
Q
;
EN1 ;INPUT TRANSFORM FOR APPROPRIATION IN FILE 430
S Z0=DA,Z1=DA(1),Z2=$P(^PRCA(430,Z1,2,Z0,0),U,1),DIC("S")="I $P(^(0),U,5)]"""""
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
S PRC("APP")=$P(Y(0),U,3),(PRC("FY"),PRC("FYI"))=Z2 D ^PRCFY S X=PRC("APP")
EN1Q S DA=Z0,DA(1)=Z1 K PRC("APP"),PRC("FYI"),Z0,Z1,Z2,DIC D EN4
Q
;
EN3 ;LOOK UP PO IN FILE 442
K PRCHPO,PRCHNEW,DA,DIC,D0,DQ Q:'$D(PRC("SITE")) S DIC="^PRC(442,",DIC(0)="QEAMZ"
S D=$S($G(PRCHPC)=1:"APCS",$G(PRCHPC)=2:"APCP",$G(PRCHDELV):"APCD",1:"C")
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:"")
;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:"")
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=""
Q
;
EN4 ;set appropriation to the flat field in the 430,AR file.
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHPAT 3615 printed Oct 16, 2024@18:10:07 Page 2
PRCHPAT ;ID/RSD-CREATE ENTRY IN FILE 442 ;1/13/93 15:46
V ;;5.1;IFCAP;**46,176**;Oct 20, 2000;Build 11
+1 ;Per VHA Directive 2004-038, this routine should not be modified
+2 ;
EN ;ENTER NEW PAT IN FILE 442;
+1 ;;**VERSION 1.52**;
+2 KILL PRCHPO
if '$DATA(PRC("SITE"))!('$DATA(DUZ))!('$DATA(PRCHP("T")))
QUIT
if '$DATA(^PRCD(442.5,+PRCHP("T"),0))
QUIT
+3 SET PRCHP("A")=$SELECT($DATA(PRCHP("A")):PRCHP("A"),1:"PAT NUMBER")
KILL DA,DIC,DLAYGO
+4 SET PRCHP("S")=+$GET(PRCHP("S"))
+5 NEW ERR
+6 ;
ENPO SET DIC="^PRC(442.6,"
SET DIC(0)="QEMZ"
+1 SET DIC("S")="I +$P(^(0),U,1)=PRC(""SITE""),+$P(^(0),U,5)=PRCHP(""S"")"
+2 if $DATA(PRCHP("S2"))
SET DIC("S")=DIC("S")_PRCHP("S2")
+3 WRITE !!,"ENTER A NEW ",PRCHP("A")," OR A COMMON NUMBERING SERIES"
+4 WRITE !?3,PRCHP("A"),": "
READ X:DTIME
if X=""!(X=U)
GOTO ENPOQ
+5 IF $EXTRACT(X,1)="?"
SET D="C"
DO IX^DIC
GOTO ENPO
+6 ;
EN2 IF $LENGTH(X)<4
SET D="C"
DO IX^DIC
if Y<0
GOTO ENPO
GOTO NUM
+1 ; check for valid common numbering series
+2 IF X?6AN
DO CHKCNS
if ERR=1
GOTO ENPO
+3 SET X=PRC("SITE")_"-"_X
SET DIC(0)="LEQ"
IF $DATA(^PRC(442,"B",X))
WRITE !?3,PRCHP("A")," ",X," already exist !"
GOTO ENPO
+4 ;
ENPO1 KILL DIC("S")
SET PRCHP("NEW")=""
SET DIC="^PRC(442,"
SET DLAYGO=442
DO ^DIC
if Y<0
GOTO ENPO
if '+$PIECE(Y,U,3)
GOTO W3
SET (DA,PRCHPO)=+Y
SET %DT="T"
SET X="NOW"
DO ^%DT
+1 SET $PIECE(^PRC(442,PRCHPO,0),U,2)=PRCHP("T")
SET $PIECE(^(12),U,4,5)=DUZ_U_Y
SET ^PRC(442,"F",PRCHP("T"),DA)=""
+2 DO DOCID^PRCHUTL
+3 GOTO ENPOQ
+4 ;
NUM LOCK +^PRC(442.6,+Y,0):$GET(DILOCKTM,3)
if '$TEST
GOTO W1
SET X=$PIECE(Y,U,2)
SET Z=$SELECT(+$PIECE(Y(0),U,4)<$PIECE(Y(0),U,2):+$PIECE(Y(0),U,2),1:+$PIECE(Y(0),U,4))
SET L=$LENGTH(X)#2-3
+1 ;
Z if Z>$PIECE(Y(0),U,3)
GOTO W2
SET Z="000"_Z
SET Z=$EXTRACT(Z,$LENGTH(Z)+L,$LENGTH(Z))
SET X=X_Z
IF $DATA(^PRC(442,"B",X))
SET Z=Z+1
SET X=$PIECE(Y,U,2)
GOTO Z
+1 WRITE !?3,"Are you adding '",X,"' as a new ",PRCHP("A"),$CHAR(7)
SET %=""
DO YN^DICN
IF %'=1
LOCK -^PRC(442.6,+Y,0)
GOTO ENPO
+2 SET $PIECE(^PRC(442.6,+Y,0),U,4)=+Z
SET DIC(0)="L"
LOCK -^PRC(442.6,+Y,0)
+3 GOTO ENPO1
+4 ;
CHKCNS ;check common numbering series
+1 ;
+2 NEW SAVEX,CNS,Y
+3 SET SAVEX=X
SET ERR=0
+4 SET CNS=$EXTRACT(X,1,3)
+5 SET X=CNS
+6 SET DIC(0)="X"
+7 SET D="C"
+8 SET DIC="^PRC(442.6,"
+9 DO IX^DIC
+10 IF Y>0
SET X=SAVEX
QUIT
+11 IF Y=-1
Begin DoDot:1
+12 SET X=$EXTRACT(CNS,1,2)
+13 SET DIC(0)="X"
+14 SET D="C"
+15 SET DIC="^PRC(442.6,"
+16 DO IX^DIC
End DoDot:1
+17 IF Y=-1
Begin DoDot:1
+18 SET ERR=1
+19 WRITE !?3," Not a valid Common Numbering Series.",$CHAR(7)
End DoDot:1
+20 SET X=SAVEX
+21 QUIT
+22 ;
W1 WRITE !?3," Common numbering series is being edited by another user, try later",$CHAR(7)
+1 GOTO ENPO
+2 ;
W2 LOCK -^PRC(442.6,+Y,0)
WRITE !?3,"UPPER BOUND HAS BEEN EXCEEDED FOR COMMON NUMBERING SERIES ",$PIECE(Y,U,2),$CHAR(7)
+1 GOTO ENPO
+2 ;
W3 WRITE " PAT Number already exist, please try again ",$CHAR(7)
+1 GOTO ENPO
+2 ;
ENPOQ KILL DIC,DLAYGO,%DT,PRCHP
+1 QUIT
+2 ;
EN1 ;INPUT TRANSFORM FOR APPROPRIATION IN FILE 430
+1 SET Z0=DA
SET Z1=DA(1)
SET Z2=$PIECE(^PRCA(430,Z1,2,Z0,0),U,1)
SET DIC("S")="I $P(^(0),U,5)]"""""
+2 SET DIC="^PRCD(420.3,"
SET DIC(0)="MEZQ"
SET D="C"
DO IX^DIC
KILL X
if Y<0
GOTO EN1Q
SET $PIECE(^PRCA(430,Z1,2,Z0,0),U,5)=+Y
IF $PIECE(Y(0),U,5)[" "
SET X=$PIECE(Y(0),U,5)
GOTO EN1Q
+3 SET PRC("APP")=$PIECE(Y(0),U,3)
SET (PRC("FY"),PRC("FYI"))=Z2
DO ^PRCFY
SET X=PRC("APP")
EN1Q SET DA=Z0
SET DA(1)=Z1
KILL PRC("APP"),PRC("FYI"),Z0,Z1,Z2,DIC
DO EN4
+1 QUIT
+2 ;
EN3 ;LOOK UP PO IN FILE 442
+1 KILL PRCHPO,PRCHNEW,DA,DIC,D0,DQ
if '$DATA(PRC("SITE"))
QUIT
SET DIC="^PRC(442,"
SET DIC(0)="QEAMZ"
+2 SET D=$SELECT($GET(PRCHPC)=1:"APCS",$GET(PRCHPC)=2:"APCP",$GET(PRCHDELV):"APCD",1:"C")
+3 SET DIC("A")=$SELECT($DATA(PRCHP("A")):PRCHP("A"),1:"PURCHASE ORDER: ")
SET DIC("S")="I +$P(^(0),U,1)=PRC(""SITE"")"_$SELECT($DATA(PRCHP("S")):","_PRCHP("S"),1:"")
+4 ;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:"")
+5 WRITE !!
DO IX^DIC
KILL DIC,PRCHP
SET X=""
if +Y<0
QUIT
SET (PRCHPO,DA)=+Y
SET X=$PIECE($GET(^PRCD(442.3,+$GET(^PRC(442,DA,7)),0)),U,2)
if X=0
SET X=""
+6 QUIT
+7 ;
EN4 ;set appropriation to the flat field in the 430,AR file.
+1 if '$DATA(X)
QUIT
SET Z0=X
if $EXTRACT(Z0,3)?1N
SET Z0=$EXTRACT(Z0,1,2)_" "_$EXTRACT(Z0,4,7)
SET $PIECE(^PRCA(430,DA(1),0),U,18)=Z0
KILL Z0
+2 QUIT
