- 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 Feb 18, 2025@23:06:42 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