- PRCSD121 ;WISC/SAW/BMM-CONTROL POINT ACTIVITY 2237 DISPLAY CON'T ;6/25/12 12:59
- ;;5.1;IFCAP;**70,81,167**;Oct 20, 2000;Build 17
- ;Per VHA Directive 2004-38, this routine should not be modified.
- ;PRINT ITEMS
- ;
- ;BMM PRC*5.1*81 edit PRCARD to also display new fields DM Doc ID
- ;(410.02, 17) and Date Needed By (410.02, 18) for 2237s originating
- ;from DynaMed requisitions
- ;
- I $D(^PRCS(410,DA,1)),$P(^(1),U,5)'="" S P=$P(^(1),U,5),P=$P($G(^PRCS(410.2,P,0)),U) W !,?13,P,":"
- S DIWL=13,DIWR=51,DIWF="",P(1)=0
- F I=1:1 K ^UTILITY($J,"W") S P(1)=$O(^PRCS(410,DA,"IT",P(1))) G VENDOR:P(1)'?1N.E D ITEM1
- ITEM1 Q:'$D(^PRCS(410,DA,"IT",P(1),0)) S Z=^(0)
- D:IOSL-$Y<3 NEWP Q:Z1=U
- S P(4)=$P(Z,U,6) I $L(P(4))>12 W !,$E(P(4),1,13),!,$E(P(4),13,24)
- I $L(P(4))<13 W !,P(4)
- ;The variable Z is equal to ^PRCS(410,DA,"IT",P(1),0)
- S PRCS("SUB")=+$P(Z,U,4),P(3)=$P(Z,U,3) S P(3)=$S($D(^PRCD(420.5,+P(3),0)):$P(^(0),U,1),1:"")
- S P(0)=$S($P(Z,U,2)[".":$J($P(Z,U,2),9,2),1:$J($P(Z,U,2),9))_" "_$J(P(3),4)_" "_$S($P(Z,U,7)="N/C":$J("N/C",9),1:$J($P(Z,U,7),9,4))
- G PRCARD:$P(Z,U,5)
- S P(2)=0 F I=1:1 S P(2)=$O(^PRCS(410,DA,"IT",P(1),1,P(2))) Q:P(2)="" S X=^(P(2),0) S:I=1 X=$P(^PRCS(410,DA,"IT",P(1),0),U,1)_" "_X D DIWP^PRCUTL($G(DA))
- ITEM2 I '$D(^UTILITY($J,"W",DIWL)) S ^(DIWL)=1,^(DIWL,1,0)="***NO DESCRIPTION***"
- S Z=^UTILITY($J,"W",DIWL)
- I Z>1 F J=1:1:(Z-1) W ?13,^UTILITY($J,"W",DIWL,J,0) D:IOSL-$Y<2 NEWP Q:Z1=U W !
- I Z>1 W ?13,^UTILITY($J,"W",DIWL,Z,0),?52,P(0) D:IOSL-$Y<2 NEWP Q:Z1=U W !
- I Z<2 W ?13,^UTILITY($J,"W",DIWL,1,0),?52,P(0) D:IOSL-$Y<2 NEWP Q:Z1=U W !
- I $P($G(^PRCS(410,DA,"IT",P(1),4)),U,3)]"" D:IOSL-$Y<2 NEWP Q:Z1=U W ?13,"eCMS Item Line ID ",$P(^PRCS(410,DA,"IT",P(1),4),U,3),!
- Q
- PRCARD S P("PR")=$P(^PRCS(410,DA,"IT",P(1),0),U,5) G ITEM2:'$D(^PRC(441,P("PR"),1,0))
- S P("PR1")=0,X=$P(^PRCS(410,DA,"IT",P(1),0),U)_" ITEM ID NO. "_P("PR") D DIWP^PRCUTL($G(DA)) F I=1:1 S P("PR1")=$O(^PRC(441,P("PR"),1,P("PR1"))) Q:P("PR1")="" S X=^(P("PR1"),0) D DIWP^PRCUTL($G(DA))
- S Z="" S:$P(^PRC(441,P("PR"),0),U,5)'="" Z=Z_" (NSN: "_$P(^(0),U,5)_")" S Z1=$P(^PRCS(410,DA,3),U,4) I Z1,$D(^PRC(441,P("PR"),2,Z1,0)) S:$P(^(0),U,5)'="" Z=Z_" (NDC: "_$P(^(0),U,5)_")" S:$P(^(0),U,3) Z2=$P(^(0),U,3)
- S:$P($G(^PRC(441,P("PR"),3)),U,7)'="" Z=Z_" FOOD GROUP: "_$P(^(3),U,7)
- I Z1,$D(^PRC(441,P("PR"),2,Z1,0)) S Z=Z_" PKG: "_$P(^(0),U,8)_" per "_$S($D(^PRCD(420.5,+$P(^(0),U,7),0)):$P(^(0),U),1:"")
- I Z1,$D(Z2),$D(^PRC(440,Z1,4,Z2,0)),$P(^(0),U,1)'="" S Y=$S($P(^(0),U,2):$P(^(0),U,2),1:"") X:Y ^DD("DD") S Z=Z_" (CONTRACT # "_$P(^PRC(440,Z1,4,Z2,0),U,1)_$S(Y'="":", EXPIRATION DATE: "_Y_")",1:")") K Z2
- S X=Z D:$L(X) DIWP^PRCUTL($G(DA))
- ;PRC*5.1*81 check DynaMed switch, if DM Doc ID exists, if so then
- ;add to display
- I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1,$P($G(^PRCS(410,DA,"IT",P(1),4)),U)]"" D
- . S X="DM Doc ID: "_$P(^PRCS(410,DA,"IT",P(1),4),U)_" Date Needed By: "_$$FMTE^XLFDT($P(^(4),U,2)) D DIWP^PRCUTL($G(DA))
- G ITEM2
- VENDOR ;PRINT VENDOR AND REQ MESSAGES
- N Z0
- Q:Z1=U I IOSL-$Y<3 D NEWP Q:Z1=U
- I $D(^PRCS(410,DA,4)),$P(^(4),U,1)'="" W !,?13,"TOTAL COST: ","$"_$J($P(^(4),U,1),0,2)
- W !,L I IOSL-$Y<2 D NEWP Q:Z1=U
- G RM:'$D(^PRCS(410,DA,2))
- I $D(^PRCS(410,DA,2)),$P(^(2),U,1)="" G RM
- I IOSL-$Y<7 D NEWP Q:Z1=U
- S (X,Z0)=$P(^PRCS(410,DA,3),"^",4),X=$S(X:"VENDOR INFORMATION: NO: "_X,1:"NEW VENDOR INFORMATION: ") W !,X
- I Z0,$D(^PRC(440,Z0,3)),$P(^(3),U,2)="Y" W ?38,"EDI"
- I Z0,$D(^PRC(440,Z0,10)),$P(^(10),U,6)'="" W ?46,"FAX: "_$P(^(10),U,6)
- W !,"VENDOR: ",$P(^PRCS(410,DA,2),U,1) W:$P(^(2),U,9)'="" ?42,"CONTACT: ",$P(^(2),U,9)
- W:$P(^PRCS(410,DA,2),U,2)'="" !,?8,$P(^(2),U,2) W:$P(^(2),U,10)'="" ?44,"PHONE: ",$P(^(2),U,10)
- S Z(1)=$Y W:$P(^PRCS(410,DA,2),U,3)'="" !,?8,$P(^(2),U,3) S Z1=$P(^(3),U,4) I Z1,$D(^PRC(440,Z1,2)),$P(^(2),U,1)'="" W:Z(1)=$Y ! W ?42,"ACCT. #: ",$P(^(2),U,1)
- W:$P(^PRCS(410,DA,2),U,4)'="" !,?8,$P(^(2),U,4) W:$P(^(2),U,5)'="" !,?8,$P(^(2),U,5)
- I $P(^PRCS(410,DA,2),U,6)'="" W !,?8,$P(^(2),U,6) W:+$P(^(2),U,7)'=0 ",",$P($G(^DIC(5,$P(^(2),U,7),0)),U,2) W:$P(^PRCS(410,DA,2),U,8)'="" " ",$P(^(2),U,8)
- W !,L W !,"Ref. Voucher Number: ",! I $P($G(^PRCS(410,DA,445)),"^")'="" W $P(^(445),"^"),!
- RM I IOSL-$Y<4 D NEWP Q:Z1=U
- I '$D(^PRCS(410,DA,"RM",0)) G DEL
- I $D(^PRCS(410,DA,"RM",0)) W ! S P(1)=0,DIWL=1,DIWR=80,DIWF="" K ^UTILITY($J,"W") S X="SPECIAL REMARKS:" D DIWP^PRCUTL($G(DA)) F J=1:1 S P(1)=$O(^PRCS(410,DA,"RM",P(1))) Q:P(1)="" S X=^(P(1),0) D DIWP^PRCUTL($G(DA))
- S Z=^UTILITY($J,"W",DIWL) F K=1:1:Z D:$Y>62 NEWP^PRCSD121 W !,^UTILITY($J,"W",DIWL,K,0)
- DEL I $D(^PRCS(410,DA,9)),$P(^(9),U,1)'="" W !,?6,"DELIVER TO: ",$P(^(9),U,1)
- W !,L Q
- NEWP ;PRINT HEADER FOR NEW PAGE
- S Z1="" W !,"Press return to continue, uparrow (^) to exit: " R Z1:DTIME S:'$T Z1=U W @IOF Q:Z1=U
- W !,?31,$P(^PRCS(410,DA,0),U,1) W !,L
- W !,?16,"REQUEST, TURN-IN, AND RECEIPT FOR PROPERTY OR SERVICES" W !,L
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSD121 4946 printed Feb 18, 2025@23:43:46 Page 2
- PRCSD121 ;WISC/SAW/BMM-CONTROL POINT ACTIVITY 2237 DISPLAY CON'T ;6/25/12 12:59
- +1 ;;5.1;IFCAP;**70,81,167**;Oct 20, 2000;Build 17
- +2 ;Per VHA Directive 2004-38, this routine should not be modified.
- +3 ;PRINT ITEMS
- +4 ;
- +5 ;BMM PRC*5.1*81 edit PRCARD to also display new fields DM Doc ID
- +6 ;(410.02, 17) and Date Needed By (410.02, 18) for 2237s originating
- +7 ;from DynaMed requisitions
- +8 ;
- +9 IF $DATA(^PRCS(410,DA,1))
- IF $PIECE(^(1),U,5)'=""
- SET P=$PIECE(^(1),U,5)
- SET P=$PIECE($GET(^PRCS(410.2,P,0)),U)
- WRITE !,?13,P,":"
- +10 SET DIWL=13
- SET DIWR=51
- SET DIWF=""
- SET P(1)=0
- +11 FOR I=1:1
- KILL ^UTILITY($JOB,"W")
- SET P(1)=$ORDER(^PRCS(410,DA,"IT",P(1)))
- if P(1)'?1N.E
- GOTO VENDOR
- DO ITEM1
- ITEM1 if '$DATA(^PRCS(410,DA,"IT",P(1),0))
- QUIT
- SET Z=^(0)
- +1 if IOSL-$Y<3
- DO NEWP
- if Z1=U
- QUIT
- +2 SET P(4)=$PIECE(Z,U,6)
- IF $LENGTH(P(4))>12
- WRITE !,$EXTRACT(P(4),1,13),!,$EXTRACT(P(4),13,24)
- +3 IF $LENGTH(P(4))<13
- WRITE !,P(4)
- +4 ;The variable Z is equal to ^PRCS(410,DA,"IT",P(1),0)
- +5 SET PRCS("SUB")=+$PIECE(Z,U,4)
- SET P(3)=$PIECE(Z,U,3)
- SET P(3)=$SELECT($DATA(^PRCD(420.5,+P(3),0)):$PIECE(^(0),U,1),1:"")
- +6 SET P(0)=$SELECT($PIECE(Z,U,2)[".":$JUSTIFY($PIECE(Z,U,2),9,2),1:$JUSTIFY($PIECE(Z,U,2),9))_" "_$JUSTIFY(P(3),4)_" "_$SELECT($PIECE(Z,U,7)="N/C":$JUSTIFY("N/C",9),1:$JUSTIFY($PIECE(Z,U,7),9,4))
- +7 if $PIECE(Z,U,5)
- GOTO PRCARD
- +8 SET P(2)=0
- FOR I=1:1
- SET P(2)=$ORDER(^PRCS(410,DA,"IT",P(1),1,P(2)))
- if P(2)=""
- QUIT
- SET X=^(P(2),0)
- if I=1
- SET X=$PIECE(^PRCS(410,DA,"IT",P(1),0),U,1)_" "_X
- DO DIWP^PRCUTL($GET(DA))
- ITEM2 IF '$DATA(^UTILITY($JOB,"W",DIWL))
- SET ^(DIWL)=1
- SET ^(DIWL,1,0)="***NO DESCRIPTION***"
- +1 SET Z=^UTILITY($JOB,"W",DIWL)
- +2 IF Z>1
- FOR J=1:1:(Z-1)
- WRITE ?13,^UTILITY($JOB,"W",DIWL,J,0)
- if IOSL-$Y<2
- DO NEWP
- if Z1=U
- QUIT
- WRITE !
- +3 IF Z>1
- WRITE ?13,^UTILITY($JOB,"W",DIWL,Z,0),?52,P(0)
- if IOSL-$Y<2
- DO NEWP
- if Z1=U
- QUIT
- WRITE !
- +4 IF Z<2
- WRITE ?13,^UTILITY($JOB,"W",DIWL,1,0),?52,P(0)
- if IOSL-$Y<2
- DO NEWP
- if Z1=U
- QUIT
- WRITE !
- +5 IF $PIECE($GET(^PRCS(410,DA,"IT",P(1),4)),U,3)]""
- if IOSL-$Y<2
- DO NEWP
- if Z1=U
- QUIT
- WRITE ?13,"eCMS Item Line ID ",$PIECE(^PRCS(410,DA,"IT",P(1),4),U,3),!
- +6 QUIT
- PRCARD SET P("PR")=$PIECE(^PRCS(410,DA,"IT",P(1),0),U,5)
- if '$DATA(^PRC(441,P("PR"),1,0))
- GOTO ITEM2
- +1 SET P("PR1")=0
- SET X=$PIECE(^PRCS(410,DA,"IT",P(1),0),U)_" ITEM ID NO. "_P("PR")
- DO DIWP^PRCUTL($GET(DA))
- FOR I=1:1
- SET P("PR1")=$ORDER(^PRC(441,P("PR"),1,P("PR1")))
- if P("PR1")=""
- QUIT
- SET X=^(P("PR1"),0)
- DO DIWP^PRCUTL($GET(DA))
- +2 SET Z=""
- if $PIECE(^PRC(441,P("PR"),0),U,5)'=""
- SET Z=Z_" (NSN: "_$PIECE(^(0),U,5)_")"
- SET Z1=$PIECE(^PRCS(410,DA,3),U,4)
- IF Z1
- IF $DATA(^PRC(441,P("PR"),2,Z1,0))
- if $PIECE(^(0),U,5)'=""
- SET Z=Z_" (NDC: "_$PIECE(^(0),U,5)_")"
- if $PIECE(^(0),U,3)
- SET Z2=$PIECE(^(0),U,3)
- +3 if $PIECE($GET(^PRC(441,P("PR"),3)),U,7)'=""
- SET Z=Z_" FOOD GROUP: "_$PIECE(^(3),U,7)
- +4 IF Z1
- IF $DATA(^PRC(441,P("PR"),2,Z1,0))
- SET Z=Z_" PKG: "_$PIECE(^(0),U,8)_" per "_$SELECT($DATA(^PRCD(420.5,+$PIECE(^(0),U,7),0)):$PIECE(^(0),U),1:"")
- +5 IF Z1
- IF $DATA(Z2)
- IF $DATA(^PRC(440,Z1,4,Z2,0))
- IF $PIECE(^(0),U,1)'=""
- SET Y=$SELECT($PIECE(^(0),U,2):$PIECE(^(0),U,2),1:"")
- if Y
- XECUTE ^DD("DD")
- SET Z=Z_" (CONTRACT # "_$PIECE(^PRC(440,Z1,4,Z2,0),U,1)_$SELECT(Y'="":", EXPIRATION DATE: "_Y_")",1:")")
- KILL Z2
- +6 SET X=Z
- if $LENGTH(X)
- DO DIWP^PRCUTL($GET(DA))
- +7 ;PRC*5.1*81 check DynaMed switch, if DM Doc ID exists, if so then
- +8 ;add to display
- +9 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1
- IF $PIECE($GET(^PRCS(410,DA,"IT",P(1),4)),U)]""
- Begin DoDot:1
- +10 SET X="DM Doc ID: "_$PIECE(^PRCS(410,DA,"IT",P(1),4),U)_" Date Needed By: "_$$FMTE^XLFDT($PIECE(^(4),U,2))
- DO DIWP^PRCUTL($GET(DA))
- End DoDot:1
- +11 GOTO ITEM2
- VENDOR ;PRINT VENDOR AND REQ MESSAGES
- +1 NEW Z0
- +2 if Z1=U
- QUIT
- IF IOSL-$Y<3
- DO NEWP
- if Z1=U
- QUIT
- +3 IF $DATA(^PRCS(410,DA,4))
- IF $PIECE(^(4),U,1)'=""
- WRITE !,?13,"TOTAL COST: ","$"_$JUSTIFY($PIECE(^(4),U,1),0,2)
- +4 WRITE !,L
- IF IOSL-$Y<2
- DO NEWP
- if Z1=U
- QUIT
- +5 if '$DATA(^PRCS(410,DA,2))
- GOTO RM
- +6 IF $DATA(^PRCS(410,DA,2))
- IF $PIECE(^(2),U,1)=""
- GOTO RM
- +7 IF IOSL-$Y<7
- DO NEWP
- if Z1=U
- QUIT
- +8 SET (X,Z0)=$PIECE(^PRCS(410,DA,3),"^",4)
- SET X=$SELECT(X:"VENDOR INFORMATION: NO: "_X,1:"NEW VENDOR INFORMATION: ")
- WRITE !,X
- +9 IF Z0
- IF $DATA(^PRC(440,Z0,3))
- IF $PIECE(^(3),U,2)="Y"
- WRITE ?38,"EDI"
- +10 IF Z0
- IF $DATA(^PRC(440,Z0,10))
- IF $PIECE(^(10),U,6)'=""
- WRITE ?46,"FAX: "_$PIECE(^(10),U,6)
- +11 WRITE !,"VENDOR: ",$PIECE(^PRCS(410,DA,2),U,1)
- if $PIECE(^(2),U,9)'=""
- WRITE ?42,"CONTACT: ",$PIECE(^(2),U,9)
- +12 if $PIECE(^PRCS(410,DA,2),U,2)'=""
- WRITE !,?8,$PIECE(^(2),U,2)
- if $PIECE(^(2),U,10)'=""
- WRITE ?44,"PHONE: ",$PIECE(^(2),U,10)
- +13 SET Z(1)=$Y
- if $PIECE(^PRCS(410,DA,2),U,3)'=""
- WRITE !,?8,$PIECE(^(2),U,3)
- SET Z1=$PIECE(^(3),U,4)
- IF Z1
- IF $DATA(^PRC(440,Z1,2))
- IF $PIECE(^(2),U,1)'=""
- if Z(1)=$Y
- WRITE !
- WRITE ?42,"ACCT. #: ",$PIECE(^(2),U,1)
- +14 if $PIECE(^PRCS(410,DA,2),U,4)'=""
- WRITE !,?8,$PIECE(^(2),U,4)
- if $PIECE(^(2),U,5)'=""
- WRITE !,?8,$PIECE(^(2),U,5)
- +15 IF $PIECE(^PRCS(410,DA,2),U,6)'=""
- WRITE !,?8,$PIECE(^(2),U,6)
- if +$PIECE(^(2),U,7)'=0
- WRITE ",",$PIECE($GET(^DIC(5,$PIECE(^(2),U,7),0)),U,2)
- if $PIECE(^PRCS(410,DA,2),U,8)'=""
- WRITE " ",$PIECE(^(2),U,8)
- +16 WRITE !,L
- WRITE !,"Ref. Voucher Number: ",!
- IF $PIECE($GET(^PRCS(410,DA,445)),"^")'=""
- WRITE $PIECE(^(445),"^"),!
- RM IF IOSL-$Y<4
- DO NEWP
- if Z1=U
- QUIT
- +1 IF '$DATA(^PRCS(410,DA,"RM",0))
- GOTO DEL
- +2 IF $DATA(^PRCS(410,DA,"RM",0))
- WRITE !
- SET P(1)=0
- SET DIWL=1
- SET DIWR=80
- SET DIWF=""
- KILL ^UTILITY($JOB,"W")
- SET X="SPECIAL REMARKS:"
- DO DIWP^PRCUTL($GET(DA))
- FOR J=1:1
- SET P(1)=$ORDER(^PRCS(410,DA,"RM",P(1)))
- if P(1)=""
- QUIT
- SET X=^(P(1),0)
- DO DIWP^PRCUTL($GET(DA))
- +3 SET Z=^UTILITY($JOB,"W",DIWL)
- FOR K=1:1:Z
- if $Y>62
- DO NEWP^PRCSD121
- WRITE !,^UTILITY($JOB,"W",DIWL,K,0)
- DEL IF $DATA(^PRCS(410,DA,9))
- IF $PIECE(^(9),U,1)'=""
- WRITE !,?6,"DELIVER TO: ",$PIECE(^(9),U,1)
- +1 WRITE !,L
- QUIT
- NEWP ;PRINT HEADER FOR NEW PAGE
- +1 SET Z1=""
- WRITE !,"Press return to continue, uparrow (^) to exit: "
- READ Z1:DTIME
- if '$TEST
- SET Z1=U
- WRITE @IOF
- if Z1=U
- QUIT
- +2 WRITE !,?31,$PIECE(^PRCS(410,DA,0),U,1)
- WRITE !,L
- +3 WRITE !,?16,"REQUEST, TURN-IN, AND RECEIPT FOR PROPERTY OR SERVICES"
- WRITE !,L
- +4 QUIT