- 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 Mar 13, 2025@21:22:49 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
