- PRCFFERU ;WISC/SJG/DL-OBLIGATION ERROR PROCESSING CON'T ;6/17/11 17:56
- V ;;5.1;IFCAP;**158**;Oct 20, 2000;Build 1
- ;Per VHA Directive 2004-038, this routine should not be modified.
- QUIT
- ; No top level entry
- NUM S PONUM=$G(GECSDATA(2100.1,GECSDATA,.01,"E"))
- S PONUM=$P(PONUM,"-",2)
- S PATNUM=$E(PONUM,4,9)
- S SITE=$E(PONUM,1,3)
- S PONUM=SITE_"-"_PATNUM
- S PONUM=$$STRIP(PONUM)
- Q
- GET(DIC,X) ; Get P.O. information for review
- K Y
- S DIC(0)="MNZ"
- D ^DIC
- K DIC
- Q
- STRIP(X) ; Strip trailing spaces
- N LOOP
- F LOOP=$L(X):-1:1 Q:$E(X,LOOP)'=" "
- S VAR=$E(X,1,LOOP)
- Q VAR
- PAUSE ; Pause screen when data is displayed
- W !!,"Press 'RETURN' to continue"
- R X:DTIME
- I $D(IOF) W @IOF
- Q
- PAUSE1 ; Pause screen when data is displayed
- W !!,"Press 'RETURN' to start the display"
- R X:DTIME
- I $D(IOF) W @IOF
- Q
- REVIEW(X) ; Prompt user to review obligation document
- S DIR(0)="Y"
- S DIR("B")="YES"
- S DIR("A")="Do you wish to display the source document"
- S DIR("?")="Enter 'NO' or 'N' or '^' if the display is not necessary."
- S DIR("?",1)="Enter 'YES' or 'Y' or 'RETURN' to display the source document."
- D ^DIR
- K DIR
- S RESP=Y
- I $D(Y(0)) S $P(RESP,U,2)=Y(0)
- I $D(DIRUT) S $P(RESP,U,3)=DIRUT
- Q RESP
- RETRANS(X) ; Prompt user to rebuild FMS doc from source doc and retransmit
- S DIR(0)="Y"
- S DIR("B")="YES"
- S DIR("A")="Do you wish to rebuild and retransmit this FMS document"
- S DIR("?")="Enter 'NO' or 'N' or '^' to exit."
- S DIR("?",1)="Enter 'YES' or 'Y' or 'RETURN' to rebuild/retransmit this document."
- D ^DIR K DIR
- S RETRAN=Y
- I $D(Y(0)) S $P(RETRAN,U,2)=Y(0)
- I $D(DIRUT) S $P(RETRAN,U,3)=DIRUT
- Q RETRAN
- ;
- ; OPT = 1 if inquiry, 2 if rebuild/retransmit
- STATR1(OPT) ;
- S LABEL=$S(MOP=1:"Purchase Order",MOP=21:"1358 Obligation",MOP=7:"Imprest Fund",MOP=8:"Requistion",MOP=2:"Certified Invoice",MOP=3:"Payment in Advance",MOP=4:"Guaranteed Delivery",1:"Obligation")
- W !,"The "_LABEL_$S(OPT=1:" will",1:" can")
- W " now be displayed for your review.",!!
- W "Please review the source document very carefully and take",!,"the appropriate corrective action.",!
- I OPT=1 D PAUSE
- I OPT=2 W ! S RESP=$$REVIEW(.RESP)
- Q
- ;
- FYQ(Z) ; Get Fiscal Year and Quarter
- N X,A,B,C,D
- S %DT="",X="T" D ^%DT
- S A=$E(Y,2,3)
- S B=$E(Y,4,5)
- S C=$E(100+$S(B>9:A+1,1:A),2,3)
- S D=$S(B<4:2,B<7:3,B<10:4,1:1)
- Q C_"^"_D
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFFERU 2378 printed Feb 18, 2025@23:29:48 Page 2
- PRCFFERU ;WISC/SJG/DL-OBLIGATION ERROR PROCESSING CON'T ;6/17/11 17:56
- V ;;5.1;IFCAP;**158**;Oct 20, 2000;Build 1
- +1 ;Per VHA Directive 2004-038, this routine should not be modified.
- +2 QUIT
- +3 ; No top level entry
- NUM SET PONUM=$GET(GECSDATA(2100.1,GECSDATA,.01,"E"))
- +1 SET PONUM=$PIECE(PONUM,"-",2)
- +2 SET PATNUM=$EXTRACT(PONUM,4,9)
- +3 SET SITE=$EXTRACT(PONUM,1,3)
- +4 SET PONUM=SITE_"-"_PATNUM
- +5 SET PONUM=$$STRIP(PONUM)
- +6 QUIT
- GET(DIC,X) ; Get P.O. information for review
- +1 KILL Y
- +2 SET DIC(0)="MNZ"
- +3 DO ^DIC
- +4 KILL DIC
- +5 QUIT
- STRIP(X) ; Strip trailing spaces
- +1 NEW LOOP
- +2 FOR LOOP=$LENGTH(X):-1:1
- if $EXTRACT(X,LOOP)'=" "
- QUIT
- +3 SET VAR=$EXTRACT(X,1,LOOP)
- +4 QUIT VAR
- PAUSE ; Pause screen when data is displayed
- +1 WRITE !!,"Press 'RETURN' to continue"
- +2 READ X:DTIME
- +3 IF $DATA(IOF)
- WRITE @IOF
- +4 QUIT
- PAUSE1 ; Pause screen when data is displayed
- +1 WRITE !!,"Press 'RETURN' to start the display"
- +2 READ X:DTIME
- +3 IF $DATA(IOF)
- WRITE @IOF
- +4 QUIT
- REVIEW(X) ; Prompt user to review obligation document
- +1 SET DIR(0)="Y"
- +2 SET DIR("B")="YES"
- +3 SET DIR("A")="Do you wish to display the source document"
- +4 SET DIR("?")="Enter 'NO' or 'N' or '^' if the display is not necessary."
- +5 SET DIR("?",1)="Enter 'YES' or 'Y' or 'RETURN' to display the source document."
- +6 DO ^DIR
- +7 KILL DIR
- +8 SET RESP=Y
- +9 IF $DATA(Y(0))
- SET $PIECE(RESP,U,2)=Y(0)
- +10 IF $DATA(DIRUT)
- SET $PIECE(RESP,U,3)=DIRUT
- +11 QUIT RESP
- RETRANS(X) ; Prompt user to rebuild FMS doc from source doc and retransmit
- +1 SET DIR(0)="Y"
- +2 SET DIR("B")="YES"
- +3 SET DIR("A")="Do you wish to rebuild and retransmit this FMS document"
- +4 SET DIR("?")="Enter 'NO' or 'N' or '^' to exit."
- +5 SET DIR("?",1)="Enter 'YES' or 'Y' or 'RETURN' to rebuild/retransmit this document."
- +6 DO ^DIR
- KILL DIR
- +7 SET RETRAN=Y
- +8 IF $DATA(Y(0))
- SET $PIECE(RETRAN,U,2)=Y(0)
- +9 IF $DATA(DIRUT)
- SET $PIECE(RETRAN,U,3)=DIRUT
- +10 QUIT RETRAN
- +11 ;
- +12 ; OPT = 1 if inquiry, 2 if rebuild/retransmit
- STATR1(OPT) ;
- +1 SET LABEL=$SELECT(MOP=1:"Purchase Order",MOP=21:"1358 Obligation",MOP=7:"Imprest Fund",MOP=8:"Requistion",MOP=2:"Certified Invoice",MOP=3:"Payment in Advance",MOP=4:"Guaranteed Delivery",1:"Obligation")
- +2 WRITE !,"The "_LABEL_$SELECT(OPT=1:" will",1:" can")
- +3 WRITE " now be displayed for your review.",!!
- +4 WRITE "Please review the source document very carefully and take",!,"the appropriate corrective action.",!
- +5 IF OPT=1
- DO PAUSE
- +6 IF OPT=2
- WRITE !
- SET RESP=$$REVIEW(.RESP)
- +7 QUIT
- +8 ;
- FYQ(Z) ; Get Fiscal Year and Quarter
- +1 NEW X,A,B,C,D
- +2 SET %DT=""
- SET X="T"
- DO ^%DT
- +3 SET A=$EXTRACT(Y,2,3)
- +4 SET B=$EXTRACT(Y,4,5)
- +5 SET C=$EXTRACT(100+$SELECT(B>9:A+1,1:A),2,3)
- +6 SET D=$SELECT(B<4:2,B<7:3,B<10:4,1:1)
- +7 QUIT C_"^"_D