PRCALM ;SF-ISC/YJK-CREATE CALM CODE SHEET FOR NEW TRANSACTION ;7/15/93 12:20 PM
V ;;4.5;Accounts Receivable;;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
N DIC,P0,PRCFASYS,PRCFX,LOOP,TRANNO,DIR,DIRUT,DUOUT
W ! S DIR("B")="YES",DIR("A")="Do you want to loop thru 'PENDING CALM CODE' Transactions",DIR(0)="Y" D ^DIR K DIR G:$D(DIRUT) END S LOOP=+Y,TRANNO=0
EN K PRCFDEL,DIC I ('$D(PRC("SITE")))!('$D(PRC("FY"))) D ^PRCFSITE Q:'$D(PRC("SITE")) W !
I LOOP D:TRANNO S DIC="^PRCA(433,",(TRANNO,DA,Y)=$O(^PRCA(433,"AE",1,TRANNO)) W:DA="" !!,"*** Loop Done ***",! G:DA="" END
.S DIR("B")="YES",DIR("A")="Do you want continue looping",DIR(0)="Y" D ^DIR K DIR I $D(DIRUT)!'Y S TRANNO="A"
.Q
I 'LOOP W ! S DIC="^PRCA(433,",DIC("A")="ENTER BILL NO. OR TRANSACTION NO.: ",DIC(0)="AEQM",DIC("S")="I +$P(^(0),U,3)=1,+$P(^(0),U,4)=2" D ^DIC Q:Y<0 S DA=+Y
S PRCA("LOCK")=0 D LOCKF^PRCAWO1 I PRCA("LOCK")=1 K PRCA,DA,DIC Q
S PRCAEN=+Y,PRCABN=+$P(^PRCA(433,PRCAEN,0),U,2) I PRCABN'>0 L -^PRCA(433,PRCAEN) K PRCAEN,PRCABN Q
K DXS S D0=PRCAEN D ^PRCATP9 K DXS W !
D PROC L -^PRCA(433,+$G(PRCAEN)) K PRCAEN,PRCABN G EN
PROC S PRCAENT=$P(^PRCA(433,PRCAEN,4,0),U,4),PRCALM=1
D @$S(+PRCAENT>1:"EN2",1:"EN1")
I PRCALM>1 S DIE="^PRCA(433,",DA=PRCAEN,DR="3////"_0_";5////"_DT_"" D ^DIE K ^PRCA(433,"AE",1,PRCAEN)
END K DIE,DR,PRCAENT,PRCA,DA,DIC,PRCALM,PRCAEN1,PRCATY Q
EN1 S PRCAEN1=+$P(^PRCA(433,PRCAEN,4,0),U,3) Q:PRCAEN1'>0 Q:$P(^PRCA(433,PRCAEN,4,PRCAEN1,0),U,4)=2 D CALM
Q ;end of EN1
EN2 W !!,"This bill has multiple PAT REF Numbers.",!
DIC1 S PRCACT=0 D PRPAT Q:PRCACT=0 K DIC S DIC="^PRCA(433,"_PRCAEN_",4,",DIC(0)="AEQM",DIC("S")="I +$P(^(0),U,4)<2" D ^DIC Q:Y<0 S PRCAEN1=+Y K DIC
D CALM K PRCACT G DIC1
CALM S PRCALM=1,PRCANODE=^PRCA(433,PRCAEN,4,PRCAEN1,0)
S %=$P(^PRCA(433,PRCAEN,1),U,1),PRCFA("TTDATE")=$E(%,4,7)_$E(%,2,3) K %
S PRCFA("REF")="" S:+$P(PRCANODE,U,3)>0 PRCFA("REF")=$S($D(^PRC(442,$P(PRCANODE,U,3),0)):$P($P(^PRC(442,$P(PRCANODE,U,3),0),U,1),"-",2),1:"") I PRCFA("REF")="" W !,*7,"NO PAT REF # !",! Q
I PRC("SITE")'=$P($P(^PRC(442,$P(PRCANODE,U,3),0),U,1),"-",1) S PRCKST=PRC("SITE"),PRC("SITE")=$P($P(^PRC(442,$P(PRCANODE,U,3),0),U,1),"-",1)
S PRCAKFY=$S($D(PRC("FY")):PRC("FY"),1:""),PRC("FY")=$P(PRCANODE,U,1)
S A=$S($P(^PRCA(430,PRCABN,2,PRCAEN1,0),U,5)]"":$P(^(0),U,5),1:"")
S X=$S(+A>0:$P(^PRCD(420.3,A,0),U,4),1:"") S A=X
I $E(A,2,4)'=718 D SE^PRCFALD,YALD 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 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(PRCANODE,U,5)=0:"",1:$J($P(PRCANODE,U,5)*100,0,0)) D EN1^PRCACLM
I $D(PRCKST) S PRC("SITE")=PRCKST K PRCKST
Q:PRCALM'>1
S $P(^PRCA(433,PRCAEN,4,PRCAEN1,0),U,4)=2
K PRCANODE,PRCFA Q ;end of CALM
PRPAT S A1=0
F J=0:0 S A1=$O(^PRCA(433,PRCAEN,4,A1)) Q:A1'>0 D P1
W !! K A1,A2,J Q
P1 I $D(^PRCA(433,PRCAEN,4,A1,0)) S Z0=^(0),PRCAKPAT=$S($P(Z0,U,3)>0:$P($P(^PRC(442,$P(Z0,U,3),0),U,1),"-",2),1:"")
S PRCAKCLM=$P(Z0,U,4) Q:PRCAKCLM=2 S PRCAKCLM=$S(PRCAKCLM=1:"NO",PRCAKCLM=2:"YES",1:"N/A")
W !,"PAT REF #: ",PRCAKPAT,?30,"CALM CODE SHEET DONE: ",PRCAKCLM
S PRCACT=PRCACT+1 K Z0,PRCAKCLM,PRCAKPAT Q
YALD S:Y="" Y=".." K:$L(Y)>4!(($L(Y)<2)&(Y'="$")) Y Q:Y=".."
I $D(Y),(Y'="$") S Y=$E(Y,1,2)_"."_$E(Y,3)_"."_$E(Y,4)
Q ;end of YALD
APPR ;WRITE APPROPRIATION SYMBOL IN THE 430
Q:('$D(PRCABN))!('$D(X)) S X1=$P(X,U,1) Q:$L(X1)'=2 S Z1=$S(+X1>70:"2"_X1,1:"3"_X1)
I $D(^PRCA(430,+PRCABN,2,+Z1,0)) W ?10,$P(^(0),U,4)
K Z1,X1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCALM 3682 printed Jan 18, 2025@02:41:31 Page 2
PRCALM ;SF-ISC/YJK-CREATE CALM CODE SHEET FOR NEW TRANSACTION ;7/15/93 12:20 PM
V ;;4.5;Accounts Receivable;;Mar 20, 1995
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+2 NEW DIC,P0,PRCFASYS,PRCFX,LOOP,TRANNO,DIR,DIRUT,DUOUT
+3 WRITE !
SET DIR("B")="YES"
SET DIR("A")="Do you want to loop thru 'PENDING CALM CODE' Transactions"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
SET LOOP=+Y
SET TRANNO=0
EN KILL PRCFDEL,DIC
IF ('$DATA(PRC("SITE")))!('$DATA(PRC("FY")))
DO ^PRCFSITE
if '$DATA(PRC("SITE"))
QUIT
WRITE !
+1 IF LOOP
if TRANNO
Begin DoDot:1
+2 SET DIR("B")="YES"
SET DIR("A")="Do you want continue looping"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)!'Y
SET TRANNO="A"
+3 QUIT
End DoDot:1
SET DIC="^PRCA(433,"
SET (TRANNO,DA,Y)=$ORDER(^PRCA(433,"AE",1,TRANNO))
if DA=""
WRITE !!,"*** Loop Done ***",!
if DA=""
GOTO END
+4 IF 'LOOP
WRITE !
SET DIC="^PRCA(433,"
SET DIC("A")="ENTER BILL NO. OR TRANSACTION NO.: "
SET DIC(0)="AEQM"
SET DIC("S")="I +$P(^(0),U,3)=1,+$P(^(0),U,4)=2"
DO ^DIC
if Y<0
QUIT
SET DA=+Y
+5 SET PRCA("LOCK")=0
DO LOCKF^PRCAWO1
IF PRCA("LOCK")=1
KILL PRCA,DA,DIC
QUIT
+6 SET PRCAEN=+Y
SET PRCABN=+$PIECE(^PRCA(433,PRCAEN,0),U,2)
IF PRCABN'>0
LOCK -^PRCA(433,PRCAEN)
KILL PRCAEN,PRCABN
QUIT
+7 KILL DXS
SET D0=PRCAEN
DO ^PRCATP9
KILL DXS
WRITE !
+8 DO PROC
LOCK -^PRCA(433,+$GET(PRCAEN))
KILL PRCAEN,PRCABN
GOTO EN
PROC SET PRCAENT=$PIECE(^PRCA(433,PRCAEN,4,0),U,4)
SET PRCALM=1
+1 DO @$SELECT(+PRCAENT>1:"EN2",1:"EN1")
+2 IF PRCALM>1
SET DIE="^PRCA(433,"
SET DA=PRCAEN
SET DR="3////"_0_";5////"_DT_""
DO ^DIE
KILL ^PRCA(433,"AE",1,PRCAEN)
END KILL DIE,DR,PRCAENT,PRCA,DA,DIC,PRCALM,PRCAEN1,PRCATY
QUIT
EN1 SET PRCAEN1=+$PIECE(^PRCA(433,PRCAEN,4,0),U,3)
if PRCAEN1'>0
QUIT
if $PIECE(^PRCA(433,PRCAEN,4,PRCAEN1,0),U,4)=2
QUIT
DO CALM
+1 ;end of EN1
QUIT
EN2 WRITE !!,"This bill has multiple PAT REF Numbers.",!
DIC1 SET PRCACT=0
DO PRPAT
if PRCACT=0
QUIT
KILL DIC
SET DIC="^PRCA(433,"_PRCAEN_",4,"
SET DIC(0)="AEQM"
SET DIC("S")="I +$P(^(0),U,4)<2"
DO ^DIC
if Y<0
QUIT
SET PRCAEN1=+Y
KILL DIC
+1 DO CALM
KILL PRCACT
GOTO DIC1
CALM SET PRCALM=1
SET PRCANODE=^PRCA(433,PRCAEN,4,PRCAEN1,0)
+1 SET %=$PIECE(^PRCA(433,PRCAEN,1),U,1)
SET PRCFA("TTDATE")=$EXTRACT(%,4,7)_$EXTRACT(%,2,3)
KILL %
+2 SET PRCFA("REF")=""
if +$PIECE(PRCANODE,U,3)>0
SET PRCFA("REF")=$SELECT($DATA(^PRC(442,$PIECE(PRCANODE,U,3),0)):$PIECE($PIECE(^PRC(442,$PIECE(PRCANODE,U,3),0),U,1),"-",2),1:"")
IF PRCFA("REF")=""
WRITE !,*7,"NO PAT REF # !",!
QUIT
+3 IF PRC("SITE")'=$PIECE($PIECE(^PRC(442,$PIECE(PRCANODE,U,3),0),U,1),"-",1)
SET PRCKST=PRC("SITE")
SET PRC("SITE")=$PIECE($PIECE(^PRC(442,$PIECE(PRCANODE,U,3),0),U,1),"-",1)
+4 SET PRCAKFY=$SELECT($DATA(PRC("FY")):PRC("FY"),1:"")
SET PRC("FY")=$PIECE(PRCANODE,U,1)
+5 SET A=$SELECT($PIECE(^PRCA(430,PRCABN,2,PRCAEN1,0),U,5)]"":$PIECE(^(0),U,5),1:"")
+6 SET X=$SELECT(+A>0:$PIECE(^PRCD(420.3,A,0),U,4),1:"")
SET A=X
+7 IF $EXTRACT(A,2,4)'=718
DO SE^PRCFALD
DO YALD
SET PRCFA("ALD")=$SELECT($DATA(Y):Y,1:"")
+8 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
SET PRCFA("ALD")=$SELECT($DATA(Y):Y,1:"")
+9 SET X=A
KILL A
if PRCAKFY'=""
SET PRC("FY")=PRCAKFY
KILL PRCAKFY
+10 SET PRCFA("AMT")=$SELECT($PIECE(PRCANODE,U,5)=0:"",1:$JUSTIFY($PIECE(PRCANODE,U,5)*100,0,0))
DO EN1^PRCACLM
+11 IF $DATA(PRCKST)
SET PRC("SITE")=PRCKST
KILL PRCKST
+12 if PRCALM'>1
QUIT
+13 SET $PIECE(^PRCA(433,PRCAEN,4,PRCAEN1,0),U,4)=2
+14 ;end of CALM
KILL PRCANODE,PRCFA
QUIT
PRPAT SET A1=0
+1 FOR J=0:0
SET A1=$ORDER(^PRCA(433,PRCAEN,4,A1))
if A1'>0
QUIT
DO P1
+2 WRITE !!
KILL A1,A2,J
QUIT
P1 IF $DATA(^PRCA(433,PRCAEN,4,A1,0))
SET Z0=^(0)
SET PRCAKPAT=$SELECT($PIECE(Z0,U,3)>0:$PIECE($PIECE(^PRC(442,$PIECE(Z0,U,3),0),U,1),"-",2),1:"")
+1 SET PRCAKCLM=$PIECE(Z0,U,4)
if PRCAKCLM=2
QUIT
SET PRCAKCLM=$SELECT(PRCAKCLM=1:"NO",PRCAKCLM=2:"YES",1:"N/A")
+2 WRITE !,"PAT REF #: ",PRCAKPAT,?30,"CALM CODE SHEET DONE: ",PRCAKCLM
+3 SET PRCACT=PRCACT+1
KILL Z0,PRCAKCLM,PRCAKPAT
QUIT
YALD if Y=""
SET Y=".."
if $LENGTH(Y)>4!(($LENGTH(Y)<2)&(Y'="$"))
KILL Y
if Y=".."
QUIT
+1 IF $DATA(Y)
IF (Y'="$")
SET Y=$EXTRACT(Y,1,2)_"."_$EXTRACT(Y,3)_"."_$EXTRACT(Y,4)
+2 ;end of YALD
QUIT
APPR ;WRITE APPROPRIATION SYMBOL IN THE 430
+1 if ('$DATA(PRCABN))!('$DATA(X))
QUIT
SET X1=$PIECE(X,U,1)
if $LENGTH(X1)'=2
QUIT
SET Z1=$SELECT(+X1>70:"2"_X1,1:"3"_X1)
+2 IF $DATA(^PRCA(430,+PRCABN,2,+Z1,0))
WRITE ?10,$PIECE(^(0),U,4)
+3 KILL Z1,X1
QUIT
