PRCHNPO9 ;WISC/SC/JDM-SPLITTED PRCHNPO ROUTINE, ENTER NEW P.O./REQ. ; [12/10/98 12:22pm]
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
EDITMSG ;messages-when editing P.O.
S PRCHEST=$P($G(^PRC(442,PRCHPO,0)),U,13),PRCHESTL=$P($G(^(0)),U,18)
CKSHBOC I PRCHEST>0 S ESTBOC=+$P($G(^PRC(442,PRCHPO,23)),U) I ESTBOC=""!(ESTBOC'>0) W ?5,!!,"The Estimated Shipping Charges is missing BOC!",$C(7) S PRCHER="",ERROR1=1
S SHPGBOC=$G(^PRC(442,PRCHPO,23))
I PRCHEST<0 S SHBOC="",PRCHEST="",$P(^PRC(442,PRCHPO,0),U,13)=PRCHEST,$P(^PRC(442,PRCHPO,23),U)=SHBOC
CKSRCCD I PRCHSC="",'$D(PRCHPC) W !!?5,"Source Code for "_$S($D(PRCHNRQ):"Requisition",1:"Purchase Order")_" is undefined !",$C(7) S ERROR1=1
CKPRCHD S PRCHDT=$S($P($G(^PRC(442,PRCHPO,1)),U,15)<2881001:0,$P($G(^(1)),U,15)>2880930:1,1:"")
I PRCHDT="" W !,$S($D(PRCHNRQ):"Requisition",1:"Purchase Order")_" has no date. ",$C(7) S ERROR1=1
CKSINFO I $P($G(^PRC(442,PRCHPO,1)),U,12),$P($G(^(0)),U,2)'=4,$P($G(^(0)),U,2)'=25,$P($G(^(1)),U,3)'="" W $C(7),!!,"P.O. contains both a 'Ship to Address' and a 'Direct Delivery Patient'.",!,"Shipping information is unclear!" S ERROR1=1
S PRCHNDX=+$P($G(^PRC(442,PRCHPO,0)),U,2),PRCHN("MP")="" G:PRCHNDX'>0 CKPMETH
S PRCHN("MP")=$P($G(^PRCD(442.5,PRCHNDX,0)),U,3)
CKPMETH I 'PRCHN("MP") W !,$C(7),"Method of Processing is not entered!" S ERROR1=1
CKFOBOR I $P($G(^PRC(442,PRCHPO,1)),U,6)="O"&(($P($G(^(0)),U,13)<0)!($P($G(^(0)),U,13)="")) W !,"F.O.B. Point with ORIGIN must have a Est. Shipping and/or Handling Charges" S ERROR1=1
Q
CKLI ;Messages if req'd Packaging Multiple, UCF or Drug Type Code are null
S ERMS1=" ",IMF=$P(^PRC(442,PRCHPO,2,LI,0),U,5),IMFD=$P(^PRC(441,IMF,0),U,2),VND=$P(^PRC(442,PRCHPO,1),U,1)
S ERMS2="Line item "_$P(^PRC(442,PRCHPO,2,LI,0),U)_" is missing "
I PRCHMUL=""&(PRTY=1!(PRTY=25)!(PRTY=26)) K E S E(1)=ERMS2,E(1,"F")="!",E(2)="Packaging Multiple!",E(2,"F")="",E(3)=ERMS1,E(3,"F")="!" D EN^DDIOL(.E) S ERRFL=1
I PRCHUCF=""&(PRTY=1!(PRTY=25)!(PRTY=26)) K E S E(1)=ERMS2,E(1,"F")="!",E(2)="Unit Conversion Factor!",E(2,"F")="",E(3)=ERMS1,E(3,"F")="!" D EN^DDIOL(.E) S ERRFL=2
I PRCHDRTY=""&(PRCHFSCD="6505") K E S E(1)=ERMS2,E(1,"F")="!",E(2)="Drug Type Code!",E(2,"F")="" D EN^DDIOL(.E) S ERRFL=3
Q
TSTREQ1 ;EP;Called from PO Input Templates to warn blank Packaging Multiple field will be required to complete transaction.
Q:$P($G(^PRC(442,PRCHPO,2,DA,0)),U,5)=""
S:'$D(^VA(200,DUZ,400)) SUPUSR=0
S:'$D(SUPUSR) SUPUSR=$P(^VA(200,DUZ,400),U,1)
S PRTY=$P($G(^PRC(442,PRCHPO,0)),U,2),LI=$P($G(^PRC(442,PRCHPO,2,0)),U,4),CUROPT=$P(XQY0,U,1),ERRFL=0
Q:(PRTY=25!(PRTY=26))&(SUPUSR'>2)
Q:PRTY'=1&(PRTY'=25)&(PRTY'=26)
I $P($G(^PRC(442,PRCHPO,2,DA,0)),U,12)']"" K W S W(1)="Pkg. Multiple is blank. It must be supplied to later complete this document!",W(1,"F")="!" D EN^DDIOL(.W)
Q
TSTREQ2 ;EP;Called from PO Input Templates to warn blank Drug Type Code will be required to complete transaction.
Q:$P($G(^PRC(442,PRCHPO,2,DA,2)),U,3)'="6505"
I $P($G(^PRC(442,PRCHPO,2,DA,4)),U,11)']"" K W S W(1)="For FSC 6505, DRUG TYPE CODE must be supplied to later complete document",W(1,"F")="!" D EN^DDIOL(.W)
Q
ERRCHKS ;EP;Called from routine PRCHNPO before allowing completion of transaction. Checks all line items for blank required fields (as appropriate) Pkg. Mult., UCF & Drug Type Code.
S ERRFL=0
S PRTY=$P(^PRC(442,PRCHPO,0),U,2),LI=0
K SUPUSR S:'$D(^VA(200,DUZ,400)) SUPUSR=0
S:'$D(SUPUSR) SUPUSR=$P(^VA(200,DUZ,400),U,1)
S CUROPT=$P(XQY0,U,1)
G:(PRTY=25!(PRTY=26))&(SUPUSR'>2) NOIMF
G:PRTY'=1&(PRTY'=25)&(PRTY'=26) NOIMF
F Q:$O(^PRC(442,PRCHPO,2,LI))'>0 S LI=$O(^PRC(442,PRCHPO,2,LI)) D
.Q:$P($G(^PRC(442,PRCHPO,2,LI,0)),U,5)=""
.S PRCHMUL=$P($G(^PRC(442,PRCHPO,2,LI,0)),U,12),PRCHUCF=$P(^PRC(442,PRCHPO,2,LI,0),U,17)
.S PRCHDRTY=$P($G(^PRC(442,PRCHPO,2,LI,4)),U,11),PRCHFSCD=$P(^PRC(442,PRCHPO,2,LI,2),U,3) D CKLI
NOIMF Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHNPO9 3963 printed Apr 09, 2024@21:15:17 Page 2
PRCHNPO9 ;WISC/SC/JDM-SPLITTED PRCHNPO ROUTINE, ENTER NEW P.O./REQ. ; [12/10/98 12:22pm]
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
EDITMSG ;messages-when editing P.O.
+1 SET PRCHEST=$PIECE($GET(^PRC(442,PRCHPO,0)),U,13)
SET PRCHESTL=$PIECE($GET(^(0)),U,18)
CKSHBOC IF PRCHEST>0
SET ESTBOC=+$PIECE($GET(^PRC(442,PRCHPO,23)),U)
IF ESTBOC=""!(ESTBOC'>0)
WRITE ?5,!!,"The Estimated Shipping Charges is missing BOC!",$CHAR(7)
SET PRCHER=""
SET ERROR1=1
+1 SET SHPGBOC=$GET(^PRC(442,PRCHPO,23))
+2 IF PRCHEST<0
SET SHBOC=""
SET PRCHEST=""
SET $PIECE(^PRC(442,PRCHPO,0),U,13)=PRCHEST
SET $PIECE(^PRC(442,PRCHPO,23),U)=SHBOC
CKSRCCD IF PRCHSC=""
IF '$DATA(PRCHPC)
WRITE !!?5,"Source Code for "_$SELECT($DATA(PRCHNRQ):"Requisition",1:"Purchase Order")_" is undefined !",$CHAR(7)
SET ERROR1=1
CKPRCHD SET PRCHDT=$SELECT($PIECE($GET(^PRC(442,PRCHPO,1)),U,15)<2881001:0,$PIECE($GET(^(1)),U,15)>2880930:1,1:"")
+1 IF PRCHDT=""
WRITE !,$SELECT($DATA(PRCHNRQ):"Requisition",1:"Purchase Order")_" has no date. ",$CHAR(7)
SET ERROR1=1
CKSINFO IF $PIECE($GET(^PRC(442,PRCHPO,1)),U,12)
IF $PIECE($GET(^(0)),U,2)'=4
IF $PIECE($GET(^(0)),U,2)'=25
IF $PIECE($GET(^(1)),U,3)'=""
WRITE $CHAR(7),!!,"P.O. contains both a 'Ship to Address' and a 'Direct Delivery Patient'.",!,"Shipping information is unclear!"
SET ERROR1=1
+1 SET PRCHNDX=+$PIECE($GET(^PRC(442,PRCHPO,0)),U,2)
SET PRCHN("MP")=""
if PRCHNDX'>0
GOTO CKPMETH
+2 SET PRCHN("MP")=$PIECE($GET(^PRCD(442.5,PRCHNDX,0)),U,3)
CKPMETH IF 'PRCHN("MP")
WRITE !,$CHAR(7),"Method of Processing is not entered!"
SET ERROR1=1
CKFOBOR IF $PIECE($GET(^PRC(442,PRCHPO,1)),U,6)="O"&(($PIECE($GET(^(0)),U,13)<0)!($PIECE($GET(^(0)),U,13)=""))
WRITE !,"F.O.B. Point with ORIGIN must have a Est. Shipping and/or Handling Charges"
SET ERROR1=1
+1 QUIT
CKLI ;Messages if req'd Packaging Multiple, UCF or Drug Type Code are null
+1 SET ERMS1=" "
SET IMF=$PIECE(^PRC(442,PRCHPO,2,LI,0),U,5)
SET IMFD=$PIECE(^PRC(441,IMF,0),U,2)
SET VND=$PIECE(^PRC(442,PRCHPO,1),U,1)
+2 SET ERMS2="Line item "_$PIECE(^PRC(442,PRCHPO,2,LI,0),U)_" is missing "
+3 IF PRCHMUL=""&(PRTY=1!(PRTY=25)!(PRTY=26))
KILL E
SET E(1)=ERMS2
SET E(1,"F")="!"
SET E(2)="Packaging Multiple!"
SET E(2,"F")=""
SET E(3)=ERMS1
SET E(3,"F")="!"
DO EN^DDIOL(.E)
SET ERRFL=1
+4 IF PRCHUCF=""&(PRTY=1!(PRTY=25)!(PRTY=26))
KILL E
SET E(1)=ERMS2
SET E(1,"F")="!"
SET E(2)="Unit Conversion Factor!"
SET E(2,"F")=""
SET E(3)=ERMS1
SET E(3,"F")="!"
DO EN^DDIOL(.E)
SET ERRFL=2
+5 IF PRCHDRTY=""&(PRCHFSCD="6505")
KILL E
SET E(1)=ERMS2
SET E(1,"F")="!"
SET E(2)="Drug Type Code!"
SET E(2,"F")=""
DO EN^DDIOL(.E)
SET ERRFL=3
+6 QUIT
TSTREQ1 ;EP;Called from PO Input Templates to warn blank Packaging Multiple field will be required to complete transaction.
+1 if $PIECE($GET(^PRC(442,PRCHPO,2,DA,0)),U,5)=""
QUIT
+2 if '$DATA(^VA(200,DUZ,400))
SET SUPUSR=0
+3 if '$DATA(SUPUSR)
SET SUPUSR=$PIECE(^VA(200,DUZ,400),U,1)
+4 SET PRTY=$PIECE($GET(^PRC(442,PRCHPO,0)),U,2)
SET LI=$PIECE($GET(^PRC(442,PRCHPO,2,0)),U,4)
SET CUROPT=$PIECE(XQY0,U,1)
SET ERRFL=0
+5 if (PRTY=25!(PRTY=26))&(SUPUSR'>2)
QUIT
+6 if PRTY'=1&(PRTY'=25)&(PRTY'=26)
QUIT
+7 IF $PIECE($GET(^PRC(442,PRCHPO,2,DA,0)),U,12)']""
KILL W
SET W(1)="Pkg. Multiple is blank. It must be supplied to later complete this document!"
SET W(1,"F")="!"
DO EN^DDIOL(.W)
+8 QUIT
TSTREQ2 ;EP;Called from PO Input Templates to warn blank Drug Type Code will be required to complete transaction.
+1 if $PIECE($GET(^PRC(442,PRCHPO,2,DA,2)),U,3)'="6505"
QUIT
+2 IF $PIECE($GET(^PRC(442,PRCHPO,2,DA,4)),U,11)']""
KILL W
SET W(1)="For FSC 6505, DRUG TYPE CODE must be supplied to later complete document"
SET W(1,"F")="!"
DO EN^DDIOL(.W)
+3 QUIT
ERRCHKS ;EP;Called from routine PRCHNPO before allowing completion of transaction. Checks all line items for blank required fields (as appropriate) Pkg. Mult., UCF & Drug Type Code.
+1 SET ERRFL=0
+2 SET PRTY=$PIECE(^PRC(442,PRCHPO,0),U,2)
SET LI=0
+3 KILL SUPUSR
if '$DATA(^VA(200,DUZ,400))
SET SUPUSR=0
+4 if '$DATA(SUPUSR)
SET SUPUSR=$PIECE(^VA(200,DUZ,400),U,1)
+5 SET CUROPT=$PIECE(XQY0,U,1)
+6 if (PRTY=25!(PRTY=26))&(SUPUSR'>2)
GOTO NOIMF
+7 if PRTY'=1&(PRTY'=25)&(PRTY'=26)
GOTO NOIMF
+8 FOR
if $ORDER(^PRC(442,PRCHPO,2,LI))'>0
QUIT
SET LI=$ORDER(^PRC(442,PRCHPO,2,LI))
Begin DoDot:1
+9 if $PIECE($GET(^PRC(442,PRCHPO,2,LI,0)),U,5)=""
QUIT
+10 SET PRCHMUL=$PIECE($GET(^PRC(442,PRCHPO,2,LI,0)),U,12)
SET PRCHUCF=$PIECE(^PRC(442,PRCHPO,2,LI,0),U,17)
+11 SET PRCHDRTY=$PIECE($GET(^PRC(442,PRCHPO,2,LI,4)),U,11)
SET PRCHFSCD=$PIECE(^PRC(442,PRCHPO,2,LI,2),U,3)
DO CKLI
End DoDot:1
NOIMF QUIT
