- 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 Jan 18, 2025@03:10:33 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