PRCAPAT ;SF-ISC/YJK-ASSIGN PAT REF# ;2/9/94 8:45 AM
V ;;4.5;Accounts Receivable;**153,198**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
N P0,PRCACOM,PRCAMT1,PRCAPV,PRCFX,PRCHAUTO,LOOP,PRCABN
W ! S DIR("B")="YES",DIR("A")="Do you want to loop thru 'PENDING CALM CODE' Bills",DIR(0)="Y" D ^DIR K DIR G:$D(DIRUT) END S LOOP=+Y,PRCABN=0
EN G:$D(PRCAUTO) END K PRCA("ACTIVE"),PRCFDEL,PRCAMIS I ('$D(PRC("SITE")))!('$D(PRC("FY"))) D ^PRCFSITE Q:'$D(PRC("SITE"))!'$D(PRC("FY")) W !
I LOOP S Y=$O(^PRCA(430,"AC",21,PRCABN)) W:Y="" !!,"*** Loop Done ***",! G:Y="" END G AUTO
N DPTNOFZY,DPTNOFZK S (DPTNOFZY,DPTNOFZK)=1
S DIC="^PRCA(430,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,8)]"""",$P(^PRCA(430.3,$P(^(0),U,8),0),U,3)=107" D ^DIC G:Y<0 END
AUTO S (PRCABN,DA)=+Y,PRCA("DEBTOR")=$P(^PRCA(430,PRCABN,0),U,9),DIC="^PRCA(430,"
S PRCA("LOCK")=0 D LOCKF^PRCAWO1 I PRCA("LOCK")=1 K DIC G END
D:",22,23,26,"[(","_$P(^PRCA(430,PRCABN,0),"^",2)_",") PH^PRCACLM
K DIC G:$D(PRCAUTO) OV S D0=PRCABN D DISPL^PRCAPAT1 K D0
I $P(^PRCA(430,PRCABN,0),U,2)=$O(^PRCA(430.2,"AC",33,0)) G OV
ASK1 S %=1 W !!,"Do you want to edit the 'Control Point' and 'Appropriation symbol'" D YN^DICN G:%<0 END
I %=0 W !,"Answer 'Y' (YES) or 'N' (NO)",! G ASK1
D:%=1 EDGL^PRCAPAT1 K %
OV I +$P($G(^PRCA(430,PRCABN,2,0)),U,3)'>0 W !,*7," NO FISCAL YEAR DATA !",! G EN
S PRCAKENT=$P(^PRCA(430,PRCABN,2,0),U,4),PRCAT=$P(^PRCA(430,PRCABN,0),U,2)
D @$S(+PRCAKENT>1:"EN2",1:"EN1")
I $P(^PRCA(430,PRCABN,0),U,8)=$O(^PRCA(430.3,"AC",102,"")) D PREPAY^RCBEPAYP(PRCABN)
D KILLV W !
I LOOP W ! S DIR("B")="YES",DIR("A")="Continue looping",DIR(0)="Y" D ^DIR K DIR G:$D(DIRUT) END I +Y'=1 S LOOP=0
G EN
KILLV ;
END ;
L -^PRCA(430,+$G(PRCABN))
K PRCAREF,PRCAT,PRCFA,PRCHPO,DR,DIE,PRCFDEL,PRCAKENT,DA,DIC,PRCALM,A1,PRCA2,PRCATY,PRCAGL,PRCAGL1,PRCAI,PRCA,PRCABN1,PRCAPAT,PRCHP,PRCATY Q
EN1 S PRCA2=$P(^PRCA(430,PRCABN,2,0),U,3),PRCAGL=^PRCA(430,PRCABN,2,PRCA2,0)
I $P(PRCAGL,U,6)=2 S %=2 W !,"This bill has already been assigned a PAT REF #/CALM Code Sheet." D ASK2 Q:%'=1
D DIE
Q
EN2 W !!,"This bill has multiple appropriations. You should assign a PAT REF # to each appropriation.",!
S PRCABN1=$O(^PRCA(430,PRCABN,2,"B","")) Q:PRCABN1="" S PRCA2=$O(^(PRCABN1,"")) S PRCAGL=^PRCA(430,PRCABN,2,PRCA2,0) D W1
F PRCAI=0:0 S PRCABN1=$O(^PRCA(430,PRCABN,2,"B",PRCABN1)) Q:PRCABN1="" S PRCA2=$O(^(PRCABN1,"")) S PRCAGL=^PRCA(430,PRCABN,2,PRCA2,0) D W1
Q
W1 W !!,$P(PRCAGL,U,1),?15,$P(PRCAGL,U,4),!,"We'll assign a PAT REF # to this appropriation."
I $P(PRCAGL,U,6)=2 W !,*7," A CALM code sheet has already been assigned to this PAT REF # !",!! Q
DIE K PRCHPO I $P(PRCAGL,U,3)]"" S %=2 W !,"A PAT REF # has already been assigned to this appropriation symbol." D ASK2 Q:%<0 G:%=2 CODE
S X=$P(^PRCA(430,PRCABN,0),"^"),DIC(0)="L",PRCAREF=1,PRCHP("A")="PAT REFERENCE NUMBER",PRCHP("T")=24,PRCHP("S")=5 W !,"Assigning PAT REF # '",X,"' ...",! D ENPO1^PRCHPAT Q:'$D(PRCHPO)
S PRCAPAT=$P(^PRC(442,PRCHPO,0),U,1) D UP442^PRCAPAT1
S DIE="^PRCA(430,"_PRCABN_",2,",DA(1)=PRCABN,DA=PRCA2,DR="2///"_PRCAPAT_$S($P(^PRCA(430,PRCABN,2,DA,0),"^",5):"",1:";4") D ^DIE Q:$D(Y)
I PRCAT=$O(^PRCA(430.2,"AC",22,"")) W !,"Since this is a contingent asset, a calm code sheet is not needed.",! S PRCA("STATUS")=16,DEB=$P(^PRCA(430,PRCABN,0),"^",9) D UPSTATS^PRCAUT2,L1^PRCALT2 K PRCA("STATUS"),DEB Q
CODE S PRCALM=1 I $D(PRCAUTO) S $P(^PRCA(430,PRCABN,2,PRCA2,0),U,6)=2,PRCALM=2 G OV1
D CALM
OV1 I PRCALM>1,$P(^PRCA(430,PRCABN,0),U,2)'=$O(^PRCA(430.2,"AC",33,0)) S PRCA("STATUS")=$O(^PRCA(430.3,"AC",102,"")),DEB=$P(^PRCA(430,PRCABN,0),"^",9) D UPSTATS^PRCAUT2,L1^PRCALT2 D:'$D(PRCAMIS) SETAMIS^PRCAPAT1 K PRCA("STATUS"),DEB Q
Q ;end of DIE
CALM W !!,"Now, we'll create a CALM code sheet for this PAT REF #.",!
S PRCAGL1=^PRCA(430,PRCABN,2,PRCA2,0) D:'$D(DT) DT^PRCAPAT1
S PRCFA("TTDATE")=$E(DT,4,7)_$E(DT,2,3),PRCFA("REF")=$P($P(^PRC(442,$P(PRCAGL1,U,3),0),"^",1),"-",2)
I PRC("SITE")'=$P($P(^PRC(442,$P(PRCAGL1,U,3),0),U,1),"-",1) S PRCKST=PRC("SITE"),PRC("SITE")=$P($P(^PRC(442,$P(PRCAGL1,U,3),0),U,1),"-",1)
S PRCAKFY=$S($D(PRC("FY")):PRC("FY"),1:""),PRC("FY")=$P(PRCAGL1,U,1)
S (A,X)=$S($P(PRCAGL1,U,5)>0:$P(^PRCD(420.3,$P(PRCAGL1,U,5),0),U,4),1:"")
I $E(A,2,4)'=718 D SE^PRCFALD,YALD^PRCALM S PRCFA("ALD")=$S($D(Y):Y,1:"")
I $E(A,2,4)=718 S Y=$S($E(PRCFA("TTDATE"),1,2)>9:$E(PRCFA("TTDATE"),6)+1,1:$E(PRCFA("TTDATE"),6)) S Y=$E(Y)_$E(A,2,4) D YALD^PRCALM S PRCFA("ALD")=$S($D(Y):Y,1:"")
S X=A K A S:PRCAKFY'="" PRC("FY")=PRCAKFY K PRCAKFY
S PRCFA("AMT")=$S($P(PRCAGL1,U,2)=0:"",PRCAT=$O(^PRCA(430.2,"AC",33,0)):$J($P(^PRCA(430,PRCABN,7),U,18)*100,0,0),1:$J($P(PRCAGL1,U,2)*100,0,0)) D EN1^PRCACLM Q:PRCALM'>1
S $P(^PRCA(430,PRCABN,2,PRCA2,0),U,6)=2 Q
Q
ASK2 S %=2 W !,"Do you want to use a new PAT REF # " D YN^DICN Q:%<0
I %=0 W !,"Answer 'Y' or 'YES' if you want to use a new PAT Reference Number,",!,"answer 'N' or 'NO' if you don't want to.",! G ASK2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAPAT 5021 printed Oct 16, 2024@17:41:49 Page 2
PRCAPAT ;SF-ISC/YJK-ASSIGN PAT REF# ;2/9/94 8:45 AM
V ;;4.5;Accounts Receivable;**153,198**;Mar 20, 1995
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+2 NEW P0,PRCACOM,PRCAMT1,PRCAPV,PRCFX,PRCHAUTO,LOOP,PRCABN
+3 WRITE !
SET DIR("B")="YES"
SET DIR("A")="Do you want to loop thru 'PENDING CALM CODE' Bills"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
SET LOOP=+Y
SET PRCABN=0
EN if $DATA(PRCAUTO)
GOTO END
KILL PRCA("ACTIVE"),PRCFDEL,PRCAMIS
IF ('$DATA(PRC("SITE")))!('$DATA(PRC("FY")))
DO ^PRCFSITE
if '$DATA(PRC("SITE"))!'$DATA(PRC("FY"))
QUIT
WRITE !
+1 IF LOOP
SET Y=$ORDER(^PRCA(430,"AC",21,PRCABN))
if Y=""
WRITE !!,"*** Loop Done ***",!
if Y=""
GOTO END
GOTO AUTO
+2 NEW DPTNOFZY,DPTNOFZK
SET (DPTNOFZY,DPTNOFZK)=1
+3 SET DIC="^PRCA(430,"
SET DIC(0)="AEQM"
SET DIC("S")="I $P(^(0),U,8)]"""",$P(^PRCA(430.3,$P(^(0),U,8),0),U,3)=107"
DO ^DIC
if Y<0
GOTO END
AUTO SET (PRCABN,DA)=+Y
SET PRCA("DEBTOR")=$PIECE(^PRCA(430,PRCABN,0),U,9)
SET DIC="^PRCA(430,"
+1 SET PRCA("LOCK")=0
DO LOCKF^PRCAWO1
IF PRCA("LOCK")=1
KILL DIC
GOTO END
+2 if ",22,23,26,"[(","_$PIECE(^PRCA(430,PRCABN,0),"^",2)_",")
DO PH^PRCACLM
+3 KILL DIC
if $DATA(PRCAUTO)
GOTO OV
SET D0=PRCABN
DO DISPL^PRCAPAT1
KILL D0
+4 IF $PIECE(^PRCA(430,PRCABN,0),U,2)=$ORDER(^PRCA(430.2,"AC",33,0))
GOTO OV
ASK1 SET %=1
WRITE !!,"Do you want to edit the 'Control Point' and 'Appropriation symbol'"
DO YN^DICN
if %<0
GOTO END
+1 IF %=0
WRITE !,"Answer 'Y' (YES) or 'N' (NO)",!
GOTO ASK1
+2 if %=1
DO EDGL^PRCAPAT1
KILL %
OV IF +$PIECE($GET(^PRCA(430,PRCABN,2,0)),U,3)'>0
WRITE !,*7," NO FISCAL YEAR DATA !",!
GOTO EN
+1 SET PRCAKENT=$PIECE(^PRCA(430,PRCABN,2,0),U,4)
SET PRCAT=$PIECE(^PRCA(430,PRCABN,0),U,2)
+2 DO @$SELECT(+PRCAKENT>1:"EN2",1:"EN1")
+3 IF $PIECE(^PRCA(430,PRCABN,0),U,8)=$ORDER(^PRCA(430.3,"AC",102,""))
DO PREPAY^RCBEPAYP(PRCABN)
+4 DO KILLV
WRITE !
+5 IF LOOP
WRITE !
SET DIR("B")="YES"
SET DIR("A")="Continue looping"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
IF +Y'=1
SET LOOP=0
+6 GOTO EN
KILLV ;
END ;
+1 LOCK -^PRCA(430,+$GET(PRCABN))
+2 KILL PRCAREF,PRCAT,PRCFA,PRCHPO,DR,DIE,PRCFDEL,PRCAKENT,DA,DIC,PRCALM,A1,PRCA2,PRCATY,PRCAGL,PRCAGL1,PRCAI,PRCA,PRCABN1,PRCAPAT,PRCHP,PRCATY
QUIT
EN1 SET PRCA2=$PIECE(^PRCA(430,PRCABN,2,0),U,3)
SET PRCAGL=^PRCA(430,PRCABN,2,PRCA2,0)
+1 IF $PIECE(PRCAGL,U,6)=2
SET %=2
WRITE !,"This bill has already been assigned a PAT REF #/CALM Code Sheet."
DO ASK2
if %'=1
QUIT
+2 DO DIE
+3 QUIT
EN2 WRITE !!,"This bill has multiple appropriations. You should assign a PAT REF # to each appropriation.",!
+1 SET PRCABN1=$ORDER(^PRCA(430,PRCABN,2,"B",""))
if PRCABN1=""
QUIT
SET PRCA2=$ORDER(^(PRCABN1,""))
SET PRCAGL=^PRCA(430,PRCABN,2,PRCA2,0)
DO W1
+2 FOR PRCAI=0:0
SET PRCABN1=$ORDER(^PRCA(430,PRCABN,2,"B",PRCABN1))
if PRCABN1=""
QUIT
SET PRCA2=$ORDER(^(PRCABN1,""))
SET PRCAGL=^PRCA(430,PRCABN,2,PRCA2,0)
DO W1
+3 QUIT
W1 WRITE !!,$PIECE(PRCAGL,U,1),?15,$PIECE(PRCAGL,U,4),!,"We'll assign a PAT REF # to this appropriation."
+1 IF $PIECE(PRCAGL,U,6)=2
WRITE !,*7," A CALM code sheet has already been assigned to this PAT REF # !",!!
QUIT
DIE KILL PRCHPO
IF $PIECE(PRCAGL,U,3)]""
SET %=2
WRITE !,"A PAT REF # has already been assigned to this appropriation symbol."
DO ASK2
if %<0
QUIT
if %=2
GOTO CODE
+1 SET X=$PIECE(^PRCA(430,PRCABN,0),"^")
SET DIC(0)="L"
SET PRCAREF=1
SET PRCHP("A")="PAT REFERENCE NUMBER"
SET PRCHP("T")=24
SET PRCHP("S")=5
WRITE !,"Assigning PAT REF # '",X,"' ...",!
DO ENPO1^PRCHPAT
if '$DATA(PRCHPO)
QUIT
+2 SET PRCAPAT=$PIECE(^PRC(442,PRCHPO,0),U,1)
DO UP442^PRCAPAT1
+3 SET DIE="^PRCA(430,"_PRCABN_",2,"
SET DA(1)=PRCABN
SET DA=PRCA2
SET DR="2///"_PRCAPAT_$SELECT($PIECE(^PRCA(430,PRCABN,2,DA,0),"^",5):"",1:";4")
DO ^DIE
if $DATA(Y)
QUIT
+4 IF PRCAT=$ORDER(^PRCA(430.2,"AC",22,""))
WRITE !,"Since this is a contingent asset, a calm code sheet is not needed.",!
SET PRCA("STATUS")=16
SET DEB=$PIECE(^PRCA(430,PRCABN,0),"^",9)
DO UPSTATS^PRCAUT2
DO L1^PRCALT2
KILL PRCA("STATUS"),DEB
QUIT
CODE SET PRCALM=1
IF $DATA(PRCAUTO)
SET $PIECE(^PRCA(430,PRCABN,2,PRCA2,0),U,6)=2
SET PRCALM=2
GOTO OV1
+1 DO CALM
OV1 IF PRCALM>1
IF $PIECE(^PRCA(430,PRCABN,0),U,2)'=$ORDER(^PRCA(430.2,"AC",33,0))
SET PRCA("STATUS")=$ORDER(^PRCA(430.3,"AC",102,""))
SET DEB=$PIECE(^PRCA(430,PRCABN,0),"^",9)
DO UPSTATS^PRCAUT2
DO L1^PRCALT2
if '$DATA(PRCAMIS)
DO SETAMIS^PRCAPAT1
KILL PRCA("STATUS"),DEB
QUIT
+1 ;end of DIE
QUIT
CALM WRITE !!,"Now, we'll create a CALM code sheet for this PAT REF #.",!
+1 SET PRCAGL1=^PRCA(430,PRCABN,2,PRCA2,0)
if '$DATA(DT)
DO DT^PRCAPAT1
+2 SET PRCFA("TTDATE")=$EXTRACT(DT,4,7)_$EXTRACT(DT,2,3)
SET PRCFA("REF")=$PIECE($PIECE(^PRC(442,$PIECE(PRCAGL1,U,3),0),"^",1),"-",2)
+3 IF PRC("SITE")'=$PIECE($PIECE(^PRC(442,$PIECE(PRCAGL1,U,3),0),U,1),"-",1)
SET PRCKST=PRC("SITE")
SET PRC("SITE")=$PIECE($PIECE(^PRC(442,$PIECE(PRCAGL1,U,3),0),U,1),"-",1)
+4 SET PRCAKFY=$SELECT($DATA(PRC("FY")):PRC("FY"),1:"")
SET PRC("FY")=$PIECE(PRCAGL1,U,1)
+5 SET (A,X)=$SELECT($PIECE(PRCAGL1,U,5)>0:$PIECE(^PRCD(420.3,$PIECE(PRCAGL1,U,5),0),U,4),1:"")
+6 IF $EXTRACT(A,2,4)'=718
DO SE^PRCFALD
DO YALD^PRCALM
SET PRCFA("ALD")=$SELECT($DATA(Y):Y,1:"")
+7 IF $EXTRACT(A,2,4)=718
SET Y=$SELECT($EXTRACT(PRCFA("TTDATE"),1,2)>9:$EXTRACT(PRCFA("TTDATE"),6)+1,1:$EXTRACT(PRCFA("TTDATE"),6))
SET Y=$EXTRACT(Y)_$EXTRACT(A,2,4)
DO YALD^PRCALM
SET PRCFA("ALD")=$SELECT($DATA(Y):Y,1:"")
+8 SET X=A
KILL A
if PRCAKFY'=""
SET PRC("FY")=PRCAKFY
KILL PRCAKFY
+9 SET PRCFA("AMT")=$SELECT($PIECE(PRCAGL1,U,2)=0:"",PRCAT=$ORDER(^PRCA(430.2,"AC",33,0)):$JUSTIFY($PIECE(^PRCA(430,PRCABN,7),U,18)*100,0,0),1:$JUSTIFY($PIECE(PRCAGL1,U,2)*100,0,0))
DO EN1^PRCACLM
if PRCALM'>1
QUIT
+10 SET $PIECE(^PRCA(430,PRCABN,2,PRCA2,0),U,6)=2
QUIT
+11 QUIT
ASK2 SET %=2
WRITE !,"Do you want to use a new PAT REF # "
DO YN^DICN
if %<0
QUIT
+1 IF %=0
WRITE !,"Answer 'Y' or 'YES' if you want to use a new PAT Reference Number,",!,"answer 'N' or 'NO' if you don't want to.",!
GOTO ASK2
+2 QUIT
