- PRCHEC1 ;SF-ISC/TKW-SUPPLEMENTAL ROUTINES CALLED FROM PRCHEC ;4/20/92 9:41 AM
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- EDIT G:$D(PRCHENT) E2 G:$D(PRCHISMS) E2
- S %A=" Do you want to generate the codesheets",%B=" Answer NO if you do not wish to build the LOG codesheets at this time.",%=1 D ^PRCFYN I %=-1 K PRCHPO Q
- G:%=1 E2 W !!," Do you want to remove this P.O. or Receiving Report from the list of",!,"pending codesheets?"
- S %A="REMOVE FROM LIST",%B="If you answer YES, and later want to generate codesheets, you will have",%B(1)="to use the 'Create a Codesheet' option.",%=2 D ^PRCFYN D:%=1 R K PRCHPO
- Q
- ;
- E2 S PRCHPONO=$P(^PRC(442,PRCHPO,0),U,1)
- S X=$G(^PRC(442,PRCHPO,17)),Y=$G(^(18))
- W !!,"P.O.(PAT) No.: "_PRCHPONO,!,"Document Identifier: ",$P(Y,U,3) W:PRCHN("SC")=1 ?35,"Requisition Number: ",$P(Y,U,10) W !
- W:PRCHN("SFC")'=2&(PRCHN("SC")'=0) "Department No.: ",$P(X,U,1),! W "Source Code: "_PRCHN("SC"),!
- Q:$D(PRCHISMS) G:PRCHTYP'="R" EDIT1
- W !,"Payable Code: "_$P(Y,U,2),!
- W "Reason Code: "_$P(X,U,14),!,"DEPOT (or Releasing Facility): ",$P(Y,U,1)
- I PRCHN("SC")=1 W ?45,"Depot Voucher No.: ",$P($G(^PRC(442,PRCHPO,1)),U,13)
- W ! I PRCHN("SFC")'=2 W $C(7),!," *** ENTER DIETETICS COST PERIOD IF THIS IS A SUBSISTANCE ORDER ***",!,?5,"**** Dietetics Cost Period: "_$P($G(^PRC(442,PRCHPO,11,PRCHRPT,1)),U,2),!! G EDIT2
- ;
- EDIT1 G:PRCHN("SC")'=0 EDIT2
- W !,"Document Identifier Code: "_$P(X,U,2),?38,"Routing Identifier Code: "_$P($G(^PRCD(441.4,+$P(X,U,3),0)),U,1)
- W !,"Media & Status Code: "_$P($G(^PRCD(441.4,+$P(X,U,11),0)),U,1),?38,"Activity Address Code: "_$P(X,U,16)
- W !,"Dept.Designation (Demand Code): "_$P($G(^PRCD(441.4,+$P(X,U,4),0)),U,1),?38,"Fund Code: "_$P(X,U,6),!,"Distribution Code: "_$P(X,U,7),?38,"Project Code: "_$P(X,U,8)
- W !,"Priority Code: "_$P($G(^PRCD(441.4,+$P(X,U,9),0)),U,1),?38,"Advice Code: "_$P($G(^PRCD(441.4,+$P(X,U,10),0)),U,1),!!
- ;
- EDIT2 S %A="Do you wish to pre-edit codesheet data ",%B="This data will go on every code sheet. 'NO' will cause the",%B(1)="code sheets to be built with the data as shown,",%B(2)="'^' to quit.",%=2 D YN^PRCFYN
- K:%=-1 PRCHPO Q:%'=1 W !!! K DIE,DA,DR S DIE="^PRC(442,",DA=PRCHPO,DR=102 S:PRCHN("SC")=1 DR=DR_";102.4" S:PRCHN("SFC")'=2&(PRCHN("SC")'=0) DR=DR_";70"
- I PRCHTYP="R" S:PRCHN("SFC")=2 DR=DR_";83//^S X=1" S:PRCHN("SC")=1 DR=DR_";107;.09" S DR=DR_";101"
- S:PRCHTYP="A"&(PRCHN("SC")=0) DR=DR_";71;72;80;72.4;73;75;76;77;78;79"
- D ^DIE K DIE,DA,DR I PRCHTYP="R",PRCHN("SFC")'=2 S DIE="^PRC(442,"_PRCHPO_",11,",DA(1)=PRCHPO,DA=PRCHRPT,DR=20 D ^DIE K DIE,DA,DR
- Q:PRCHTYP'="R" Q:PRCHN("SFC")'=2 W !!!,"Select any items for which you wish to enter a source deviation code.",!
- ;
- EDIT3 S DIC="^PRC(442,"_PRCHPO_",2,",DA(1)=PRCHPO,DIC(0)="AEQM" D ^DIC I Y>0 S DIE=DIC,DA=+Y,DR=39.5 D ^DIE G EDIT3
- Q
- ;
- SETUP S PRCHN("SC")="" I $D(^PRC(442,PRCHPO,1)) S PRCHN("SC")=$S($D(^PRCD(420.8,+$P(^(1),U,7),0)):$P(^(0),U,1),1:"") S:"013"[PRCHN("SC") PRCHNRQ=1
- S PRCHN("MP")=$P($G(^PRCD(442.5,+$P(^PRC(442,PRCHPO,0),U,2),0)),U,3)
- S PRCHN("SFC")=$P(^PRC(442,PRCHPO,0),U,19),PRCHEMG=$P($G(^(1)),U,17)
- Q
- ;
- OBL Q:'$P(^PRC(442,PRCHPO,0),U,12) I $D(^PRC(442,PRCHPO,18)),$P(^(18),U,12) W $C(7),!!!,"Control Point Obligated Balances have already been updated.",!! Q
- W !! S %A=" Update Control Point Obligated Balance",%B=" Review the Order first to make sure it is correct. This step should be",%B(1)="done to make sure the Control Point Balance matches CALM."
- S %=2 D ^PRCFYN I %'=1 K PRCHPO Q
- D OBL^PRCHNRQ
- Q
- ;
- ASK ;Ask user if they want to report showing code sheets to be created
- W !!!,$C(7),"**** Do you want to print a report showing code sheets to be created? ****" S %A="PRINT REPORT",%B="Answer 'Y' to see what orders have not yet had code sheets generated",%=2
- D YN^PRCFYN
- Q
- ;
- R ;REMOVE P.O. OR RECEIVING REPORT FROM PENDING LIST
- I PRCHTYP="A" K ^PRC(442,"AE","N",PRCHPO) Q
- I PRCHTYP="R" K ^PRC(442,"AF","N",PRCHPO,PRCHRPT)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHEC1 4050 printed Jan 18, 2025@03:08:20 Page 2
- PRCHEC1 ;SF-ISC/TKW-SUPPLEMENTAL ROUTINES CALLED FROM PRCHEC ;4/20/92 9:41 AM
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;
- EDIT if $DATA(PRCHENT)
- GOTO E2
- if $DATA(PRCHISMS)
- GOTO E2
- +1 SET %A=" Do you want to generate the codesheets"
- SET %B=" Answer NO if you do not wish to build the LOG codesheets at this time."
- SET %=1
- DO ^PRCFYN
- IF %=-1
- KILL PRCHPO
- QUIT
- +2 if %=1
- GOTO E2
- WRITE !!," Do you want to remove this P.O. or Receiving Report from the list of",!,"pending codesheets?"
- +3 SET %A="REMOVE FROM LIST"
- SET %B="If you answer YES, and later want to generate codesheets, you will have"
- SET %B(1)="to use the 'Create a Codesheet' option."
- SET %=2
- DO ^PRCFYN
- if %=1
- DO R
- KILL PRCHPO
- +4 QUIT
- +5 ;
- E2 SET PRCHPONO=$PIECE(^PRC(442,PRCHPO,0),U,1)
- +1 SET X=$GET(^PRC(442,PRCHPO,17))
- SET Y=$GET(^(18))
- +2 WRITE !!,"P.O.(PAT) No.: "_PRCHPONO,!,"Document Identifier: ",$PIECE(Y,U,3)
- if PRCHN("SC")=1
- WRITE ?35,"Requisition Number: ",$PIECE(Y,U,10)
- WRITE !
- +3 if PRCHN("SFC")'=2&(PRCHN("SC")'=0)
- WRITE "Department No.: ",$PIECE(X,U,1),!
- WRITE "Source Code: "_PRCHN("SC"),!
- +4 if $DATA(PRCHISMS)
- QUIT
- if PRCHTYP'="R"
- GOTO EDIT1
- +5 WRITE !,"Payable Code: "_$PIECE(Y,U,2),!
- +6 WRITE "Reason Code: "_$PIECE(X,U,14),!,"DEPOT (or Releasing Facility): ",$PIECE(Y,U,1)
- +7 IF PRCHN("SC")=1
- WRITE ?45,"Depot Voucher No.: ",$PIECE($GET(^PRC(442,PRCHPO,1)),U,13)
- +8 WRITE !
- IF PRCHN("SFC")'=2
- WRITE $CHAR(7),!," *** ENTER DIETETICS COST PERIOD IF THIS IS A SUBSISTANCE ORDER ***",!,?5,"**** Dietetics Cost Period: "_$PIECE($GET(^PRC(442,PRCHPO,11,PRCHRPT,1)),U,2),!!
- GOTO EDIT2
- +9 ;
- EDIT1 if PRCHN("SC")'=0
- GOTO EDIT2
- +1 WRITE !,"Document Identifier Code: "_$PIECE(X,U,2),?38,"Routing Identifier Code: "_$PIECE($GET(^PRCD(441.4,+$PIECE(X,U,3),0)),U,1)
- +2 WRITE !,"Media & Status Code: "_$PIECE($GET(^PRCD(441.4,+$PIECE(X,U,11),0)),U,1),?38,"Activity Address Code: "_$PIECE(X,U,16)
- +3 WRITE !,"Dept.Designation (Demand Code): "_$PIECE($GET(^PRCD(441.4,+$PIECE(X,U,4),0)),U,1),?38,"Fund Code: "_$PIECE(X,U,6),!,"Distribution Code: "_$PIECE(X,U,7),?38,"Project Code: "_$PIECE(X,U,8)
- +4 WRITE !,"Priority Code: "_$PIECE($GET(^PRCD(441.4,+$PIECE(X,U,9),0)),U,1),?38,"Advice Code: "_$PIECE($GET(^PRCD(441.4,+$PIECE(X,U,10),0)),U,1),!!
- +5 ;
- EDIT2 SET %A="Do you wish to pre-edit codesheet data "
- SET %B="This data will go on every code sheet. 'NO' will cause the"
- SET %B(1)="code sheets to be built with the data as shown,"
- SET %B(2)="'^' to quit."
- SET %=2
- DO YN^PRCFYN
- +1 if %=-1
- KILL PRCHPO
- if %'=1
- QUIT
- WRITE !!!
- KILL DIE,DA,DR
- SET DIE="^PRC(442,"
- SET DA=PRCHPO
- SET DR=102
- if PRCHN("SC")=1
- SET DR=DR_";102.4"
- if PRCHN("SFC")'=2&(PRCHN("SC")'=0)
- SET DR=DR_";70"
- +2 IF PRCHTYP="R"
- if PRCHN("SFC")=2
- SET DR=DR_";83//^S X=1"
- if PRCHN("SC")=1
- SET DR=DR_";107;.09"
- SET DR=DR_";101"
- +3 if PRCHTYP="A"&(PRCHN("SC")=0)
- SET DR=DR_";71;72;80;72.4;73;75;76;77;78;79"
- +4 DO ^DIE
- KILL DIE,DA,DR
- IF PRCHTYP="R"
- IF PRCHN("SFC")'=2
- SET DIE="^PRC(442,"_PRCHPO_",11,"
- SET DA(1)=PRCHPO
- SET DA=PRCHRPT
- SET DR=20
- DO ^DIE
- KILL DIE,DA,DR
- +5 if PRCHTYP'="R"
- QUIT
- if PRCHN("SFC")'=2
- QUIT
- WRITE !!!,"Select any items for which you wish to enter a source deviation code.",!
- +6 ;
- EDIT3 SET DIC="^PRC(442,"_PRCHPO_",2,"
- SET DA(1)=PRCHPO
- SET DIC(0)="AEQM"
- DO ^DIC
- IF Y>0
- SET DIE=DIC
- SET DA=+Y
- SET DR=39.5
- DO ^DIE
- GOTO EDIT3
- +1 QUIT
- +2 ;
- SETUP SET PRCHN("SC")=""
- IF $DATA(^PRC(442,PRCHPO,1))
- SET PRCHN("SC")=$SELECT($DATA(^PRCD(420.8,+$PIECE(^(1),U,7),0)):$PIECE(^(0),U,1),1:"")
- if "013"[PRCHN("SC")
- SET PRCHNRQ=1
- +1 SET PRCHN("MP")=$PIECE($GET(^PRCD(442.5,+$PIECE(^PRC(442,PRCHPO,0),U,2),0)),U,3)
- +2 SET PRCHN("SFC")=$PIECE(^PRC(442,PRCHPO,0),U,19)
- SET PRCHEMG=$PIECE($GET(^(1)),U,17)
- +3 QUIT
- +4 ;
- OBL if '$PIECE(^PRC(442,PRCHPO,0),U,12)
- QUIT
- IF $DATA(^PRC(442,PRCHPO,18))
- IF $PIECE(^(18),U,12)
- WRITE $CHAR(7),!!!,"Control Point Obligated Balances have already been updated.",!!
- QUIT
- +1 WRITE !!
- SET %A=" Update Control Point Obligated Balance"
- SET %B=" Review the Order first to make sure it is correct. This step should be"
- SET %B(1)="done to make sure the Control Point Balance matches CALM."
- +2 SET %=2
- DO ^PRCFYN
- IF %'=1
- KILL PRCHPO
- QUIT
- +3 DO OBL^PRCHNRQ
- +4 QUIT
- +5 ;
- ASK ;Ask user if they want to report showing code sheets to be created
- +1 WRITE !!!,$CHAR(7),"**** Do you want to print a report showing code sheets to be created? ****"
- SET %A="PRINT REPORT"
- SET %B="Answer 'Y' to see what orders have not yet had code sheets generated"
- SET %=2
- +2 DO YN^PRCFYN
- +3 QUIT
- +4 ;
- R ;REMOVE P.O. OR RECEIVING REPORT FROM PENDING LIST
- +1 IF PRCHTYP="A"
- KILL ^PRC(442,"AE","N",PRCHPO)
- QUIT
- +2 IF PRCHTYP="R"
- KILL ^PRC(442,"AF","N",PRCHPO,PRCHRPT)
- +3 QUIT