PRCSP131 ;WISC/SAW-CPA PRINTS CON'T-TRANSACTION STATUS REPORT ;4/21/93 08:56
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
D:IO=IO(0) S^PRCSP13 Q:PRCSEX[U S PRCS7=$S($D(^PRCS(410,DA,7)):^(7),1:"")
N XNAME S XNAME=$P($G(^PRCS(410,DA,14)),"^")
I +XNAME'=0 W !,"Originator of Request: " I $P($G(^VA(200,XNAME,0)),"^")'="" W $P(^(0),"^") E W "*NO NEW PERSON ENTRY*"
W !,"Requestor: " S X=$P(^DD(410,40,0),"^",2) I X[200 W $S($D(^VA(200,+PRCS7,0)):$P(^(0),U),1:"")
W ?41,"Form Type: ",$S($D(^PRCS(410.5,+$P(PRCS0,U,4),0)):$P(^(0),U),1:"")
W !,"Requestor's Title: ",$P(PRCS7,U,2) W ?41,"Requesting Service: " S X=$S($D(^PRCS(410,DA,3)):$P(^(3),U,5),1:"") I $D(^DIC(49,+X,0)) W $P(^(0),U) W:$P(^(0),U,8)]"" " ("_$P(^(0),U,8)_")"
W !,"Approving Official: " S X=$P(^DD(410,42,0),"^",2) I X[200 W $S($D(^VA(200,+$P(PRCS7,U,3),0)):$P(^(0),U),1:"")
W ?41,"Inventory Dist. Point: " I $D(^PRCS(410,DA,0)),$P(^(0),U,6)'="" W $S($D(^PRCP(445,$P(^(0),U,6),0)):$P($P(^(0),U,1),"-",2),1:"")
W !,"Appr. Official's Title: ",$P(PRCS7,U,4) W ?41,"Cost Center: ",$S($D(^PRCS(410,DA,3)):$E($P(^(3),U,3),1,25),1:"")
W !,"Date Signed (Approved): " S Y=$P(PRCS7,U,5) X:Y ^DD("DD") W Y K PRCS7
K ^UTILITY($J,"W") S DIWL=1,DIWR=62,DIWF="",PRCSDY=8,PRCSI=0
F PRCSJ=1:1 S PRCSI=$O(^PRCS(410,DA,8,PRCSI)) Q:'PRCSI S X=^(PRCSI,0) D DIWP^PRCUTL($G(DA))
S I=$S($D(^UTILITY($J,"W",DIWL)):+^(DIWL),1:0)
I I F J=1:1:I D:PRCSDY>PRCSS S^PRCSP13 Q:PRCSEX[U W ! W:J=1 "Justification:" W ?15,^UTILITY($J,"W",DIWL,J,0) S PRCSDY=PRCSDY+1
Q:PRCSEX[U K PRCSX S PRCS9=$S($D(^PRCS(410,DA,9)):^(9),1:"")
D:PRCSDY>(PRCSS-4) S^PRCSP13 Q:PRCSEX[U W !,"Deliver To/Location: ",$P(PRCS9,U)
S PRCS1=$S($D(^PRCS(410,DA,1)):^(1),1:"") W !,"Classification of Request: " S X=$S($D(^PRCS(410.2,+$P(PRCS1,U,5),0)):$E($P(^(0),U),1,22),1:"") W X K PRCS1
S X=$S($D(^PRCS(410,DA,11)):$P(^(11),U),1:"") S:$P(X,";") X=$P(X,";",2)_$P(X,";"),X="^"_X_",0)",X=$S($D(@X):$P(^(0),U),1:"") W !,"Sort Group: ",X
D SUBC^PRCSP132
S PRCSDY=PRCSDY+4 D RTS^PRCSP132,COM
I PRCSTC="O",$P(PRCS0,"^",4)>1,$O(^PRCS(410,DA,"IT",0)) G ^PRCSP132
Q
COM D:PRCSDY>PRCSS S^PRCSP13 Q:PRCSEX[U K ^UTILITY($J,"W") S DIWL=1,DIWR=68,DIWF="",PRCSDY=PRCSDY+1,PRCSI=0
F PRCSJ=1:1 S PRCSI=$O(^PRCS(410,DA,"CO",PRCSI)) Q:'PRCSI S X=^(PRCSI,0) D DIWP^PRCUTL($G(DA))
S I=$S($D(^UTILITY($J,"W",DIWL)):+^(DIWL),1:0)
I I F J=1:1:I D:PRCSDY>PRCSS S^PRCSP13 Q:PRCSEX[U W ! W:J=1 "Comments:" W ?10,^UTILITY($J,"W",DIWL,J,0) S PRCSDY=PRCSDY+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSP131 2547 printed Apr 09, 2024@21:15:28 Page 2
PRCSP131 ;WISC/SAW-CPA PRINTS CON'T-TRANSACTION STATUS REPORT ;4/21/93 08:56
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 if IO=IO(0)
DO S^PRCSP13
if PRCSEX[U
QUIT
SET PRCS7=$SELECT($DATA(^PRCS(410,DA,7)):^(7),1:"")
+3 NEW XNAME
SET XNAME=$PIECE($GET(^PRCS(410,DA,14)),"^")
+4 IF +XNAME'=0
WRITE !,"Originator of Request: "
IF $PIECE($GET(^VA(200,XNAME,0)),"^")'=""
WRITE $PIECE(^(0),"^")
IF '$TEST
WRITE "*NO NEW PERSON ENTRY*"
+5 WRITE !,"Requestor: "
SET X=$PIECE(^DD(410,40,0),"^",2)
IF X[200
WRITE $SELECT($DATA(^VA(200,+PRCS7,0)):$PIECE(^(0),U),1:"")
+6 WRITE ?41,"Form Type: ",$SELECT($DATA(^PRCS(410.5,+$PIECE(PRCS0,U,4),0)):$PIECE(^(0),U),1:"")
+7 WRITE !,"Requestor's Title: ",$PIECE(PRCS7,U,2)
WRITE ?41,"Requesting Service: "
SET X=$SELECT($DATA(^PRCS(410,DA,3)):$PIECE(^(3),U,5),1:"")
IF $DATA(^DIC(49,+X,0))
WRITE $PIECE(^(0),U)
if $PIECE(^(0),U,8)]""
WRITE " ("_$PIECE(^(0),U,8)_")"
+8 WRITE !,"Approving Official: "
SET X=$PIECE(^DD(410,42,0),"^",2)
IF X[200
WRITE $SELECT($DATA(^VA(200,+$PIECE(PRCS7,U,3),0)):$PIECE(^(0),U),1:"")
+9 WRITE ?41,"Inventory Dist. Point: "
IF $DATA(^PRCS(410,DA,0))
IF $PIECE(^(0),U,6)'=""
WRITE $SELECT($DATA(^PRCP(445,$PIECE(^(0),U,6),0)):$PIECE($PIECE(^(0),U,1),"-",2),1:"")
+10 WRITE !,"Appr. Official's Title: ",$PIECE(PRCS7,U,4)
WRITE ?41,"Cost Center: ",$SELECT($DATA(^PRCS(410,DA,3)):$EXTRACT($PIECE(^(3),U,3),1,25),1:"")
+11 WRITE !,"Date Signed (Approved): "
SET Y=$PIECE(PRCS7,U,5)
if Y
XECUTE ^DD("DD")
WRITE Y
KILL PRCS7
+12 KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=62
SET DIWF=""
SET PRCSDY=8
SET PRCSI=0
+13 FOR PRCSJ=1:1
SET PRCSI=$ORDER(^PRCS(410,DA,8,PRCSI))
if 'PRCSI
QUIT
SET X=^(PRCSI,0)
DO DIWP^PRCUTL($GET(DA))
+14 SET I=$SELECT($DATA(^UTILITY($JOB,"W",DIWL)):+^(DIWL),1:0)
+15 IF I
FOR J=1:1:I
if PRCSDY>PRCSS
DO S^PRCSP13
if PRCSEX[U
QUIT
WRITE !
if J=1
WRITE "Justification:"
WRITE ?15,^UTILITY($JOB,"W",DIWL,J,0)
SET PRCSDY=PRCSDY+1
+16 if PRCSEX[U
QUIT
KILL PRCSX
SET PRCS9=$SELECT($DATA(^PRCS(410,DA,9)):^(9),1:"")
+17 if PRCSDY>(PRCSS-4)
DO S^PRCSP13
if PRCSEX[U
QUIT
WRITE !,"Deliver To/Location: ",$PIECE(PRCS9,U)
+18 SET PRCS1=$SELECT($DATA(^PRCS(410,DA,1)):^(1),1:"")
WRITE !,"Classification of Request: "
SET X=$SELECT($DATA(^PRCS(410.2,+$PIECE(PRCS1,U,5),0)):$EXTRACT($PIECE(^(0),U),1,22),1:"")
WRITE X
KILL PRCS1
+19 SET X=$SELECT($DATA(^PRCS(410,DA,11)):$PIECE(^(11),U),1:"")
if $PIECE(X,";")
SET X=$PIECE(X,";",2)_$PIECE(X,";")
SET X="^"_X_",0)"
SET X=$SELECT($DATA(@X):$PIECE(^(0),U),1:"")
WRITE !,"Sort Group: ",X
+20 DO SUBC^PRCSP132
+21 SET PRCSDY=PRCSDY+4
DO RTS^PRCSP132
DO COM
+22 IF PRCSTC="O"
IF $PIECE(PRCS0,"^",4)>1
IF $ORDER(^PRCS(410,DA,"IT",0))
GOTO ^PRCSP132
+23 QUIT
COM if PRCSDY>PRCSS
DO S^PRCSP13
if PRCSEX[U
QUIT
KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=68
SET DIWF=""
SET PRCSDY=PRCSDY+1
SET PRCSI=0
+1 FOR PRCSJ=1:1
SET PRCSI=$ORDER(^PRCS(410,DA,"CO",PRCSI))
if 'PRCSI
QUIT
SET X=^(PRCSI,0)
DO DIWP^PRCUTL($GET(DA))
+2 SET I=$SELECT($DATA(^UTILITY($JOB,"W",DIWL)):+^(DIWL),1:0)
+3 IF I
FOR J=1:1:I
if PRCSDY>PRCSS
DO S^PRCSP13
if PRCSEX[U
QUIT
WRITE !
if J=1
WRITE "Comments:"
WRITE ?10,^UTILITY($JOB,"W",DIWL,J,0)
SET PRCSDY=PRCSDY+1
+4 QUIT
