- PRCHNPO2 ;WISC/RSD/RHD-CONT. OF NEW PO ;12/1/93 09:41
- V ;;5.1;IFCAP;**16**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- EN1 ;ASK REQUEST NUMBER FOR IMPREST FUND INPUT TEMPLATE
- S PRCHSZ=0 D EN0^PRCHNPO3 G Q:'$D(PRCHSY) S PRCHS="",PRCHJ=+$G(^PRCS(410,PRCHSY,10)) D MV1^PRCHSP1,EN4
- Q
- ;
- EN2 ;SCREEN FOR BREAKOUT CODE IN FILE 442
- S Z1=$P(^PRCD(420.6,Y,0),U,1),Z0=0,Z2="",Z5=$E(PRCHN("TC")) G:$P(^(0),U,3)'=PRCHDT EN2Q F ZI=0:0 S ZI=$O(^PRC(442,PRCHPO,9,DA,1,ZI)) Q:'ZI S Z2=Z2_$P($G(^PRCD(420.6,ZI,0)),U,1)
- I +PRCHN("MB")'<4!(Z5["F") S:Z1="O"&(Z2="") Z0=1 G EN2Q
- I +PRCHN("MB")=3!(+PRCHN("MB")=2&("CDE"[Z5))!(+PRCHN("MB")=1&("DE"[Z5)) S Z0=$S(Z1="O"&(Z2=""):1,"MWVY"[Z1&(Z2'["O"):1,1:0) G EN2Q
- I +PRCHN("MB")=1,Z5["C" S Z0=$S(Z1="O"&(Z2=""):1,Z1="M"&(Z2'["N")&(Z2'["O"):1,Z1="N"&("YVWYVYWVY"[Z2):1,"VWY"[Z1&(Z2'["O"):1,1:0)
- G:"AB"'[Z5 EN2Q
- I +PRCHN("MB")=2 S Z0=$S(Z1="O"&(Z2=""):1,Z1="J"&(PRCHN("LSA")="Y")&(Z2'["O"):1,"MWVY"[Z1&(Z2'["O"):1,1:0)
- I +PRCHN("MB")=1 D EN2Z S Z0=$S(Z1="O"&(Z2=""):1,Z1="G"&Z3:1,Z1="H"&Z3:1,Z1="J"&(PRCHN("LSA")="Y"&Z3):1,Z1="K"&(PRCHN("LSA")="Y"&Z3):1,Z1="M"&(Z2'["N")&(Z2'["O"):1,Z1="N"&("YVWYVYWVY"[Z2):1,"VWY"[Z1&(Z2'["O"):1,1:0)
- EN2Q I Z0
- K Z0,Z1,Z2,Z3,Z4,ZI
- Q
- ;
- EN2Z S Z3=1 F ZI=1:1:$L(Z2) Q:'Z3 S Z4=$E(Z2,ZI) I "MVWY"'[Z4 S Z3=0
- Q
- ;
- EN3 ;DISPLAYS BREAKOUT CODES,CALLED FROM TEMPLATE PRCHAMT
- I $O(PRCHB(0)) S ^PRC(442,PRCHPO,9,DA,1,0)=PRCHB(0) F I=0:0 S I=$O(PRCHB(I)) Q:'I S:$P(^PRCD(420.6,+I,0),"^",5)'="N" ^PRC(442,PRCHPO,9,DA,1,I,0)=I,^PRC(442,PRCHPO,9,DA,1,"B",I,I)=""
- S I=$P(^PRC(442,PRCHPO,9,DA,0),"^",2),PRCHN("TC")=$P($G(^PRCD(420.6,+I,0)),"^",1),I=0 W !?3,"Possible Breakout Codes: "
- F Y=49:0 S Y=$O(^PRCD(420.6,Y)) Q:Y>100 D EN2 I $T W:I "," W $P(^PRCD(420.6,Y,0),U,1) S I=I+1
- W ! K Z,Y,Z1
- Q
- ;
- EN4 ;CALLED FROM PRCHNPO3, ADDS COMMENTS
- G Q:'$D(PRCHSY),LST1:'PRCHSP I '$D(^PRCS(410,PRCHSP)) S PRCHSP="" G LST1
- S X=$P(^PRCS(410,PRCHSY,4),U,8),$P(^(4),U,1)=0,$P(^(4),U,8)=0,X(1)=$P(^PRCS(410,PRCHSP,4),U,8)+X,$P(^(4),U,1)=X(1),$P(^(4),U,8)=X(1),PRCHSX(1)=$P(^(0),U,1)
- I $P(^PRCS(410,PRCHSY,7),U,6)]"" D
- . N X,XX S XX=$P(^PRCS(410,PRCHSY,7),U,3) D REMOVE^PRCSC1(PRCHSY),ENCODE^PRCSC1(PRCHSY,XX,.X) Q
- I $P(^PRCS(410,PRCHSY,7),U,9)]"" D
- . N X,XX S XX=$P(^PRCS(410,PRCHSY,7),U,8) D REMOVE^PRCSC3(PRCHSY),ENCODE^PRCSC3(PRCHSY,XX) Q
- I $P(^PRCS(410,PRCHSP,7),U,6)]"" D
- . N X,XX S XX=$P(^PRCS(410,PRCHSY,7),U,3) D REMOVE^PRCSC1(PRCHSP),ENCODE^PRCSC1(PRCHSP,XX) Q
- I $P(^PRCS(410,PRCHSP,7),U,9)]"" D
- . N X,XX S XX=$P(^PRCS(410,PRCHSY,7),U,8) D REMOVE^PRCSC3(PRCHSP),ENCODE^PRCSC3(PRCHSP,XX) Q
- S J=0 F I=0:0 S I=$O(^PRCS(410,PRCHSY,"CO",I)) Q:'I S J=J+1
- S J=J+1,^PRCS(410,PRCHSY,"CO",J,0)=" THE COST OF THIS REQUEST, $"_X_" ,HAS BEEN CARRIED FORWARD TO TRANSACTION "_PRCHSX(1),^PRCS(410,PRCHSY,"CO",0)="^^"_J_U_J_U_DT_"^^"
- S J=0 F I=0:0 S I=$O(^PRCS(410,PRCHSP,"CO",I)) Q:'I S J=J+1
- S J=J+1,^PRCS(410,PRCHSP,"CO",J,0)=" THE COST OF THIS REQUEST, $"_X(1)_" , REFLECTS ORIGINAL COST PLUS, $"_X_" FROM TRANSACTION "_PRCHSX,^PRCS(410,PRCHSP,"CO",0)="^^"_J_U_J_U_DT_"^^"
- ;
- LST1 S:'PRCHSP $P(^PRC(442,PRCHPO,0),U,12)=PRCHSY I '$D(^PRC(442,PRCHPO,13)) S ^(13,0)="^442.14PA^0^0"
- I '$D(^PRC(442,PRCHPO,13,PRCHSY,0)) S ^(0)=PRCHSY(0) D REMOVE^PRCHES0(PRCHPO,PRCHSY),ENCODE^PRCHES0(PRCHPO,PRCHSY,$P(PRCHSY(0),U,2),.Y) G QQ:Y<1 D
- .S $P(^(0),U,3,4)=PRCHSY_U_($P(^PRC(442,PRCHPO,13,0),U,4)+1) S:$P(PRCHSY(0),U,11)]"" ^PRC(442,"G",$P(PRCHSY(0),U,11),PRCHPO,PRCHSY)="" Q
- I PRCHS W ! S %A="Want to print the new 2237, "_PRCHSX_" ",%B="",%=2 D ^PRCFYN I %=1 S DA=PRCHSY,PRCSF=1 D PRF1^PRCSP1 K PRCSF
- ;
- Q S (DA,D0)=PRCHPO,Y="@1" K DIC,X,PRCH,PRCHD,PRCHS,PRCHSIT,PRCHJ,PRCHK,PRCHSLI,PRCHSX,PRCHSY,PRCHX,^TMP($J,"PRCHS")
- Q
- ;
- EN6 ;DISPLAYS BUSINESS SIZE,CALLED FROM PRCHNPO1
- ;When Source Code is 5, Bus Type is stuffed in as 4 'Other Entities' via
- ;template PRCHAMT89 therefore quit & do not display Bus Type
- Q:$G(PRCHSC)=5
- S PRCHVAR=$S(PRCHDT:8.3,1:8.2)
- I $D(^DD(440,PRCHVAR,0)),$L(PRCHN("MB"))=1 S Z=$P(^(0),U,3) F J=1:1 S Z1=$P(Z,";",J) Q:Z1="" I $P(Z1,":",1)=PRCHN("MB") S PRCHN("MB")=PRCHN("MB")_" "_$P(Z1,":",2)
- I PRCHN("MB")="" W !?3,"Business Type is undefined for this vendor!",$C(7) K PRCHPO,Z,Z1 Q
- W !?3,"BUSINESS TYPE: ",PRCHN("MB") K Z,Z1
- Q
- ;
- EN7 ;SCREEN OF TYPE CODE
- S Z1=$P(^PRCD(420.6,Y,0),U,1),Z0=0 I $P(^(0),U,3)'=PRCHDT S Z0=0 G EN7Q
- I $E(PRCH,1,2)="GS" S Z0=$S(Z1["D"&(Z1[+PRCHN("MB")):1,1:0) G EN7Q
- I $E(PRCH,1,4)="V797" S Z0=$S(Z1[+PRCHN("MB")&("ABC"[$E(Z1)):1,1:0) G EN7Q
- I $E(PRCH,1,4)=".OM" S Z0=$S(Z1[+PRCHN("MB")&("ABCX"[$E(Z1)):1,1:0) G EN7Q
- I Z1[+PRCHN("MB"),Z1'["D" S Z0=1
- EN7Q I Z0
- K Z0,Z1
- Q
- ;
- QQ S:'$D(ROUTINE) ROUTINE=$T(+0) W !!,$$ERR^PRCHQQ(ROUTINE,PRCSIG) W:PRCSIG=0!(PRCSIG=-3) !,"Notify Application Coordinator!",$C(7) S DIR(0)="EAO",DIR("A")="Press <return> to continue" D ^DIR K PRCSIG,ROUTINE,DIR(0),DIR("A") G Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHNPO2 4945 printed Jan 18, 2025@03:10:06 Page 2
- PRCHNPO2 ;WISC/RSD/RHD-CONT. OF NEW PO ;12/1/93 09:41
- V ;;5.1;IFCAP;**16**;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;
- EN1 ;ASK REQUEST NUMBER FOR IMPREST FUND INPUT TEMPLATE
- +1 SET PRCHSZ=0
- DO EN0^PRCHNPO3
- if '$DATA(PRCHSY)
- GOTO Q
- SET PRCHS=""
- SET PRCHJ=+$GET(^PRCS(410,PRCHSY,10))
- DO MV1^PRCHSP1
- DO EN4
- +2 QUIT
- +3 ;
- EN2 ;SCREEN FOR BREAKOUT CODE IN FILE 442
- +1 SET Z1=$PIECE(^PRCD(420.6,Y,0),U,1)
- SET Z0=0
- SET Z2=""
- SET Z5=$EXTRACT(PRCHN("TC"))
- if $PIECE(^(0),U,3)'=PRCHDT
- GOTO EN2Q
- FOR ZI=0:0
- SET ZI=$ORDER(^PRC(442,PRCHPO,9,DA,1,ZI))
- if 'ZI
- QUIT
- SET Z2=Z2_$PIECE($GET(^PRCD(420.6,ZI,0)),U,1)
- +2 IF +PRCHN("MB")'<4!(Z5["F")
- if Z1="O"&(Z2="")
- SET Z0=1
- GOTO EN2Q
- +3 IF +PRCHN("MB")=3!(+PRCHN("MB")=2&("CDE"[Z5))!(+PRCHN("MB")=1&("DE"[Z5))
- SET Z0=$SELECT(Z1="O"&(Z2=""):1,"MWVY"[Z1&(Z2'["O"):1,1:0)
- GOTO EN2Q
- +4 IF +PRCHN("MB")=1
- IF Z5["C"
- SET Z0=$SELECT(Z1="O"&(Z2=""):1,Z1="M"&(Z2'["N")&(Z2'["O"):1,Z1="N"&("YVWYVYWVY"[Z2):1,"VWY"[Z1&(Z2'["O"):1,1:0)
- +5 if "AB"'[Z5
- GOTO EN2Q
- +6 IF +PRCHN("MB")=2
- SET Z0=$SELECT(Z1="O"&(Z2=""):1,Z1="J"&(PRCHN("LSA")="Y")&(Z2'["O"):1,"MWVY"[Z1&(Z2'["O"):1,1:0)
- +7 IF +PRCHN("MB")=1
- DO EN2Z
- SET Z0=$SELECT(Z1="O"&(Z2=""):1,Z1="G"&Z3:1,Z1="H"&Z3:1,Z1="J"&(PRCHN("LSA")="Y"&Z3):1,Z1="K"&(PRCHN("LSA")="Y"&Z3):1,Z1="M"&(Z2'["N")&(Z2'["O"):1,Z1="N"&("YVWYVYWVY"[Z2):1,"VWY"[Z1&(Z2'["O"):1,1:0)
- EN2Q IF Z0
- +1 KILL Z0,Z1,Z2,Z3,Z4,ZI
- +2 QUIT
- +3 ;
- EN2Z SET Z3=1
- FOR ZI=1:1:$LENGTH(Z2)
- if 'Z3
- QUIT
- SET Z4=$EXTRACT(Z2,ZI)
- IF "MVWY"'[Z4
- SET Z3=0
- +1 QUIT
- +2 ;
- EN3 ;DISPLAYS BREAKOUT CODES,CALLED FROM TEMPLATE PRCHAMT
- +1 IF $ORDER(PRCHB(0))
- SET ^PRC(442,PRCHPO,9,DA,1,0)=PRCHB(0)
- FOR I=0:0
- SET I=$ORDER(PRCHB(I))
- if 'I
- QUIT
- if $PIECE(^PRCD(420.6,+I,0),"^",5)'="N"
- SET ^PRC(442,PRCHPO,9,DA,1,I,0)=I
- SET ^PRC(442,PRCHPO,9,DA,1,"B",I,I)=""
- +2 SET I=$PIECE(^PRC(442,PRCHPO,9,DA,0),"^",2)
- SET PRCHN("TC")=$PIECE($GET(^PRCD(420.6,+I,0)),"^",1)
- SET I=0
- WRITE !?3,"Possible Breakout Codes: "
- +3 FOR Y=49:0
- SET Y=$ORDER(^PRCD(420.6,Y))
- if Y>100
- QUIT
- DO EN2
- IF $TEST
- if I
- WRITE ","
- WRITE $PIECE(^PRCD(420.6,Y,0),U,1)
- SET I=I+1
- +4 WRITE !
- KILL Z,Y,Z1
- +5 QUIT
- +6 ;
- EN4 ;CALLED FROM PRCHNPO3, ADDS COMMENTS
- +1 if '$DATA(PRCHSY)
- GOTO Q
- if 'PRCHSP
- GOTO LST1
- IF '$DATA(^PRCS(410,PRCHSP))
- SET PRCHSP=""
- GOTO LST1
- +2 SET X=$PIECE(^PRCS(410,PRCHSY,4),U,8)
- SET $PIECE(^(4),U,1)=0
- SET $PIECE(^(4),U,8)=0
- SET X(1)=$PIECE(^PRCS(410,PRCHSP,4),U,8)+X
- SET $PIECE(^(4),U,1)=X(1)
- SET $PIECE(^(4),U,8)=X(1)
- SET PRCHSX(1)=$PIECE(^(0),U,1)
- +3 IF $PIECE(^PRCS(410,PRCHSY,7),U,6)]""
- Begin DoDot:1
- +4 NEW X,XX
- SET XX=$PIECE(^PRCS(410,PRCHSY,7),U,3)
- DO REMOVE^PRCSC1(PRCHSY)
- DO ENCODE^PRCSC1(PRCHSY,XX,.X)
- QUIT
- End DoDot:1
- +5 IF $PIECE(^PRCS(410,PRCHSY,7),U,9)]""
- Begin DoDot:1
- +6 NEW X,XX
- SET XX=$PIECE(^PRCS(410,PRCHSY,7),U,8)
- DO REMOVE^PRCSC3(PRCHSY)
- DO ENCODE^PRCSC3(PRCHSY,XX)
- QUIT
- End DoDot:1
- +7 IF $PIECE(^PRCS(410,PRCHSP,7),U,6)]""
- Begin DoDot:1
- +8 NEW X,XX
- SET XX=$PIECE(^PRCS(410,PRCHSY,7),U,3)
- DO REMOVE^PRCSC1(PRCHSP)
- DO ENCODE^PRCSC1(PRCHSP,XX)
- QUIT
- End DoDot:1
- +9 IF $PIECE(^PRCS(410,PRCHSP,7),U,9)]""
- Begin DoDot:1
- +10 NEW X,XX
- SET XX=$PIECE(^PRCS(410,PRCHSY,7),U,8)
- DO REMOVE^PRCSC3(PRCHSP)
- DO ENCODE^PRCSC3(PRCHSP,XX)
- QUIT
- End DoDot:1
- +11 SET J=0
- FOR I=0:0
- SET I=$ORDER(^PRCS(410,PRCHSY,"CO",I))
- if 'I
- QUIT
- SET J=J+1
- +12 SET J=J+1
- SET ^PRCS(410,PRCHSY,"CO",J,0)=" THE COST OF THIS REQUEST, $"_X_" ,HAS BEEN CARRIED FORWARD TO TRANSACTION "_PRCHSX(1)
- SET ^PRCS(410,PRCHSY,"CO",0)="^^"_J_U_J_U_DT_"^^"
- +13 SET J=0
- FOR I=0:0
- SET I=$ORDER(^PRCS(410,PRCHSP,"CO",I))
- if 'I
- QUIT
- SET J=J+1
- +14 SET J=J+1
- SET ^PRCS(410,PRCHSP,"CO",J,0)=" THE COST OF THIS REQUEST, $"_X(1)_" , REFLECTS ORIGINAL COST PLUS, $"_X_" FROM TRANSACTION "_PRCHSX
- SET ^PRCS(410,PRCHSP,"CO",0)="^^"_J_U_J_U_DT_"^^"
- +15 ;
- LST1 if 'PRCHSP
- SET $PIECE(^PRC(442,PRCHPO,0),U,12)=PRCHSY
- IF '$DATA(^PRC(442,PRCHPO,13))
- SET ^(13,0)="^442.14PA^0^0"
- +1 IF '$DATA(^PRC(442,PRCHPO,13,PRCHSY,0))
- SET ^(0)=PRCHSY(0)
- DO REMOVE^PRCHES0(PRCHPO,PRCHSY)
- DO ENCODE^PRCHES0(PRCHPO,PRCHSY,$PIECE(PRCHSY(0),U,2),.Y)
- if Y<1
- GOTO QQ
- Begin DoDot:1
- +2 SET $PIECE(^(0),U,3,4)=PRCHSY_U_($PIECE(^PRC(442,PRCHPO,13,0),U,4)+1)
- if $PIECE(PRCHSY(0),U,11)]""
- SET ^PRC(442,"G",$PIECE(PRCHSY(0),U,11),PRCHPO,PRCHSY)=""
- QUIT
- End DoDot:1
- +3 IF PRCHS
- WRITE !
- SET %A="Want to print the new 2237, "_PRCHSX_" "
- SET %B=""
- SET %=2
- DO ^PRCFYN
- IF %=1
- SET DA=PRCHSY
- SET PRCSF=1
- DO PRF1^PRCSP1
- KILL PRCSF
- +4 ;
- Q SET (DA,D0)=PRCHPO
- SET Y="@1"
- KILL DIC,X,PRCH,PRCHD,PRCHS,PRCHSIT,PRCHJ,PRCHK,PRCHSLI,PRCHSX,PRCHSY,PRCHX,^TMP($JOB,"PRCHS")
- +1 QUIT
- +2 ;
- EN6 ;DISPLAYS BUSINESS SIZE,CALLED FROM PRCHNPO1
- +1 ;When Source Code is 5, Bus Type is stuffed in as 4 'Other Entities' via
- +2 ;template PRCHAMT89 therefore quit & do not display Bus Type
- +3 if $GET(PRCHSC)=5
- QUIT
- +4 SET PRCHVAR=$SELECT(PRCHDT:8.3,1:8.2)
- +5 IF $DATA(^DD(440,PRCHVAR,0))
- IF $LENGTH(PRCHN("MB"))=1
- SET Z=$PIECE(^(0),U,3)
- FOR J=1:1
- SET Z1=$PIECE(Z,";",J)
- if Z1=""
- QUIT
- IF $PIECE(Z1,":",1)=PRCHN("MB")
- SET PRCHN("MB")=PRCHN("MB")_" "_$PIECE(Z1,":",2)
- +6 IF PRCHN("MB")=""
- WRITE !?3,"Business Type is undefined for this vendor!",$CHAR(7)
- KILL PRCHPO,Z,Z1
- QUIT
- +7 WRITE !?3,"BUSINESS TYPE: ",PRCHN("MB")
- KILL Z,Z1
- +8 QUIT
- +9 ;
- EN7 ;SCREEN OF TYPE CODE
- +1 SET Z1=$PIECE(^PRCD(420.6,Y,0),U,1)
- SET Z0=0
- IF $PIECE(^(0),U,3)'=PRCHDT
- SET Z0=0
- GOTO EN7Q
- +2 IF $EXTRACT(PRCH,1,2)="GS"
- SET Z0=$SELECT(Z1["D"&(Z1[+PRCHN("MB")):1,1:0)
- GOTO EN7Q
- +3 IF $EXTRACT(PRCH,1,4)="V797"
- SET Z0=$SELECT(Z1[+PRCHN("MB")&("ABC"[$EXTRACT(Z1)):1,1:0)
- GOTO EN7Q
- +4 IF $EXTRACT(PRCH,1,4)=".OM"
- SET Z0=$SELECT(Z1[+PRCHN("MB")&("ABCX"[$EXTRACT(Z1)):1,1:0)
- GOTO EN7Q
- +5 IF Z1[+PRCHN("MB")
- IF Z1'["D"
- SET Z0=1
- EN7Q IF Z0
- +1 KILL Z0,Z1
- +2 QUIT
- +3 ;
- QQ if '$DATA(ROUTINE)
- SET ROUTINE=$TEXT(+0)
- WRITE !!,$$ERR^PRCHQQ(ROUTINE,PRCSIG)
- if PRCSIG=0!(PRCSIG=-3)
- WRITE !,"Notify Application Coordinator!",$CHAR(7)
- SET DIR(0)="EAO"
- SET DIR("A")="Press <return> to continue"
- DO ^DIR
- KILL PRCSIG,ROUTINE,DIR(0),DIR("A")
- GOTO Q
- +1 QUIT