- PRCPUTRS ;WISC/RFJ-transaction history file selection ;07 Jul 92
- ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- Q
- ;
- ;
- SELECT(PRCPINPT) ; select transaction register entry for inventory point
- N DA,PIECES,PRCPFLAG,X,Y
- D INFOHELP
- ;
- F D Q:$G(PRCPFLAG)
- . W !,"Select TRANSACTION REGISTER entry: "
- . R X:DTIME S:'$T X="^" I X["^" S X="^",PRCPFLAG=1 Q
- . I X="" S PRCPFLAG=1 Q
- . I X["?" D HELP(""),INFOHELP Q
- . S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- . ; lookup by trans id
- . I "RUACSPE"[$E(X),$D(^PRCP(445.2,"T",PRCPINPT,X)) S DA=$$SHOW("^PRCP(445.2,""T"","_PRCPINPT_","""_X_""",") S:DA PRCPFLAG=1 Q
- . I $E($O(^PRCP(445.2,"T",PRCPINPT,X)))=$E(X) D HELP(X),INFOHELP Q
- . ;
- . ; lookup by voucher number
- . I $D(^PRCP(445.2,"V",X)) S DA=$$SHOW("^PRCP(445.2,""V"","""_X_""",") S:DA PRCPFLAG=1 Q
- . ;
- . ; lookup by transaction number
- . S PIECES=$L(X,"-")
- . I $L($P(X,"-",PIECES))=4 D
- . . I PIECES=5 Q
- . . I PIECES=4 S X=PRC("SITE")_"-"_X
- . . I PIECES=3 S X=PRC("SITE")_"-"_PRC("FY")_"-"_X Q
- . . I PIECES=2 S X=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_X
- . I $L(X,"-")=1 S X=PRC("SITE")_"-"_X
- . I $D(^PRCP(445.2,"C",X)) S DA=$$SHOW("^PRCP(445.2,""C"","""_X_""",") S:DA PRCPFLAG=1 Q
- . W ?65,"invalid entry"
- S X=$G(^PRCP(445.2,+$G(DA),0))
- I X'="" S Y=$P(X,"^",3) W !,"selected: ",$P(X,"^",2),?20,$P(X,"^",19),?40,$P(X,"^",15),?50,$E(Y,4,5),"-",$E(Y,6,7),"-",$E(Y,2,3),?60,"IM#",$P(X,"^",5),?70,$E($$DESCR^PRCPUX1(PRCPINPT,+$P(X,"^",5)),1,9)
- Q +$G(DA)
- ;
- ;
- SHOW(GLOBAL) ; present list of matches to user
- N DA,DATA,ENDLINE,LINE,PRCPFLAG,SELECTDA,STARTLIN,Y
- K ^TMP($J,"PRCPUTRS")
- S LINE=0,DA=0
- F D Q:$G(PRCPFLAG)
- . S STARTLIN=LINE+1 F S DA=$O(@(GLOBAL_DA_")")) Q:'DA I $P($G(^PRCP(445.2,DA,0)),"^")=PRCPINPT S LINE=LINE+1,^TMP($J,"PRCPUTRS",LINE)=DA Q:LINE#15=0
- . I '$D(^TMP($J,"PRCPUTRS",STARTLIN)) S PRCPFLAG=1 Q
- . ; one entry only
- . I LINE=1 S SELECTDA=^TMP($J,"PRCPUTRS",1),PRCPFLAG=1 Q
- . ;
- . W !!?2,"ENTRY",?10,"TRANID",?20,"TRANSACTION",?40,"VOUCHER",?50,"DATE",?60,"ITEM"
- . F ENDLINE=STARTLIN:1 Q:'$D(^TMP($J,"PRCPUTRS",ENDLINE)) S DATA=$G(^PRCP(445.2,+^TMP($J,"PRCPUTRS",ENDLINE),0)) I DATA'="" D
- . . S Y=$P(DATA,"^",3)
- . . W !?2,ENDLINE,?10,$P(DATA,"^",2),?20,$P(DATA,"^",19),?40,$P(DATA,"^",15),?50,$E(Y,4,5),"-",$E(Y,6,7),"-",$E(Y,2,3),?60,"IM#",$P(DATA,"^",5),?70,$E($$DESCR^PRCPUX1(PRCPINPT,+$P(DATA,"^",5)),1,9)
- . I 'DA W !?2,"--- end of list ---"
- . ;
- . W !!,"Select an ENTRY from the list (from 1 to ",ENDLINE-1,"): "
- . R X:DTIME I '$T!(X["^") S PRCPFLAG=1 Q
- . I $D(^TMP($J,"PRCPUTRS",+X)) S SELECTDA=^(+X),PRCPFLAG=1 Q
- . ;
- . ; entire list displayed
- . I 'DA S PRCPFLAG=1
- K ^TMP($J,"PRCPUTRS")
- Q +$G(SELECTDA)
- ;
- ;
- INFOHELP ; display info help text
- N HELP
- S HELP(1)="You may lookup entries in the TRANSACTION REGISTER file by selecting: A) the transaction register id (A123 or RC456, etc); B) the transaction number which is the 2237, issue book, or purchase order number"
- S HELP(2)="(460-94-2-120-0010 or 120-0010 if its the same quarter and year or purchase order G12345); C) the voucher number (I400001)."
- W ! D DISPLAY^PRCPUX2(2,76,.HELP)
- Q
- ;
- ;
- HELP(Y) ; display help (if Y="" ask start with)
- N DATA,DIR,LINE,PRCPFLAG,TRANID,X
- I Y="" D I Y'="A",Y'="R",Y'="RC",Y'="C",Y'="U",Y'="P",Y'="S",Y'="E" Q
- . S DIR(0)="S0^A:adjustment;RC:receipt;R:distribution regular;C:distribution call-in;E:distribution emergency;U:usage;P:physical count;S:case cart/instrument kit assembly or disassembly;"
- . S DIR("A")=" Start HELP with entry type",DIR("B")="adjustment"
- . D ^DIR
- ;
- ; show tranid entries
- S TRANID=Y F LINE=1:1 S TRANID=$O(^PRCP(445.2,"T",PRCPINPT,TRANID)) Q:TRANID="" D I LINE#15=0 D P^PRCPUREP Q:$G(PRCPFLAG)
- . S DATA=$G(^PRCP(445.2,+$O(^PRCP(445.2,"T",PRCPINPT,TRANID,0)),0)),Y=$P(DATA,"^",3)
- . W !?2,"tranid:",?10,$P(DATA,"^",2),?20,$P(DATA,"^",19),?40,$P(DATA,"^",15),?50,$E(Y,4,5),"-",$E(Y,6,7),"-",$E(Y,2,3)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPUTRS 4189 printed Mar 13, 2025@21:21:15 Page 2
- PRCPUTRS ;WISC/RFJ-transaction history file selection ;07 Jul 92
- +1 ;;5.1;IFCAP;;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 QUIT
- +4 ;
- +5 ;
- SELECT(PRCPINPT) ; select transaction register entry for inventory point
- +1 NEW DA,PIECES,PRCPFLAG,X,Y
- +2 DO INFOHELP
- +3 ;
- +4 FOR
- Begin DoDot:1
- +5 WRITE !,"Select TRANSACTION REGISTER entry: "
- +6 READ X:DTIME
- if '$TEST
- SET X="^"
- IF X["^"
- SET X="^"
- SET PRCPFLAG=1
- QUIT
- +7 IF X=""
- SET PRCPFLAG=1
- QUIT
- +8 IF X["?"
- DO HELP("")
- DO INFOHELP
- QUIT
- +9 SET X=$TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- +10 ; lookup by trans id
- +11 IF "RUACSPE"[$EXTRACT(X)
- IF $DATA(^PRCP(445.2,"T",PRCPINPT,X))
- SET DA=$$SHOW("^PRCP(445.2,""T"","_PRCPINPT_","""_X_""",")
- if DA
- SET PRCPFLAG=1
- QUIT
- +12 IF $EXTRACT($ORDER(^PRCP(445.2,"T",PRCPINPT,X)))=$EXTRACT(X)
- DO HELP(X)
- DO INFOHELP
- QUIT
- +13 ;
- +14 ; lookup by voucher number
- +15 IF $DATA(^PRCP(445.2,"V",X))
- SET DA=$$SHOW("^PRCP(445.2,""V"","""_X_""",")
- if DA
- SET PRCPFLAG=1
- QUIT
- +16 ;
- +17 ; lookup by transaction number
- +18 SET PIECES=$LENGTH(X,"-")
- +19 IF $LENGTH($PIECE(X,"-",PIECES))=4
- Begin DoDot:2
- +20 IF PIECES=5
- QUIT
- +21 IF PIECES=4
- SET X=PRC("SITE")_"-"_X
- +22 IF PIECES=3
- SET X=PRC("SITE")_"-"_PRC("FY")_"-"_X
- QUIT
- +23 IF PIECES=2
- SET X=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_X
- End DoDot:2
- +24 IF $LENGTH(X,"-")=1
- SET X=PRC("SITE")_"-"_X
- +25 IF $DATA(^PRCP(445.2,"C",X))
- SET DA=$$SHOW("^PRCP(445.2,""C"","""_X_""",")
- if DA
- SET PRCPFLAG=1
- QUIT
- +26 WRITE ?65,"invalid entry"
- End DoDot:1
- if $GET(PRCPFLAG)
- QUIT
- +27 SET X=$GET(^PRCP(445.2,+$GET(DA),0))
- +28 IF X'=""
- SET Y=$PIECE(X,"^",3)
- WRITE !,"selected: ",$PIECE(X,"^",2),?20,$PIECE(X,"^",19),?40,$PIECE(X,"^",15),?50,$EXTRACT(Y,4,5),"-",$EXTRACT(Y,6,7),"-",$EXTRACT(Y,2,3),?60,"IM#",$PIECE(X,"^",5),?70,$EXTRACT($$DESCR^PRCPUX1(PRCPINPT,+$PIECE(X,"^",5)),1,9)
- +29 QUIT +$GET(DA)
- +30 ;
- +31 ;
- SHOW(GLOBAL) ; present list of matches to user
- +1 NEW DA,DATA,ENDLINE,LINE,PRCPFLAG,SELECTDA,STARTLIN,Y
- +2 KILL ^TMP($JOB,"PRCPUTRS")
- +3 SET LINE=0
- SET DA=0
- +4 FOR
- Begin DoDot:1
- +5 SET STARTLIN=LINE+1
- FOR
- SET DA=$ORDER(@(GLOBAL_DA_")"))
- if 'DA
- QUIT
- IF $PIECE($GET(^PRCP(445.2,DA,0)),"^")=PRCPINPT
- SET LINE=LINE+1
- SET ^TMP($JOB,"PRCPUTRS",LINE)=DA
- if LINE#15=0
- QUIT
- +6 IF '$DATA(^TMP($JOB,"PRCPUTRS",STARTLIN))
- SET PRCPFLAG=1
- QUIT
- +7 ; one entry only
- +8 IF LINE=1
- SET SELECTDA=^TMP($JOB,"PRCPUTRS",1)
- SET PRCPFLAG=1
- QUIT
- +9 ;
- +10 WRITE !!?2,"ENTRY",?10,"TRANID",?20,"TRANSACTION",?40,"VOUCHER",?50,"DATE",?60,"ITEM"
- +11 FOR ENDLINE=STARTLIN:1
- if '$DATA(^TMP($JOB,"PRCPUTRS",ENDLINE))
- QUIT
- SET DATA=$GET(^PRCP(445.2,+^TMP($JOB,"PRCPUTRS",ENDLINE),0))
- IF DATA'=""
- Begin DoDot:2
- +12 SET Y=$PIECE(DATA,"^",3)
- +13 WRITE !?2,ENDLINE,?10,$PIECE(DATA,"^",2),?20,$PIECE(DATA,"^",19),?40,$PIECE(DATA,"^",15),?50,$EXTRACT(Y,4,5),"-",$EXTRACT(Y,6,7),"-",$EXTRACT(Y,2,3),?60,"IM#",$PIECE(DATA,"^",5),?70,$EXTRACT($$DESCR^PRCPUX1(PRCPINPT,+$PIECE(
- DATA,"^",5)),1,9)
- End DoDot:2
- +14 IF 'DA
- WRITE !?2,"--- end of list ---"
- +15 ;
- +16 WRITE !!,"Select an ENTRY from the list (from 1 to ",ENDLINE-1,"): "
- +17 READ X:DTIME
- IF '$TEST!(X["^")
- SET PRCPFLAG=1
- QUIT
- +18 IF $DATA(^TMP($JOB,"PRCPUTRS",+X))
- SET SELECTDA=^(+X)
- SET PRCPFLAG=1
- QUIT
- +19 ;
- +20 ; entire list displayed
- +21 IF 'DA
- SET PRCPFLAG=1
- End DoDot:1
- if $GET(PRCPFLAG)
- QUIT
- +22 KILL ^TMP($JOB,"PRCPUTRS")
- +23 QUIT +$GET(SELECTDA)
- +24 ;
- +25 ;
- INFOHELP ; display info help text
- +1 NEW HELP
- +2 SET HELP(1)="You may lookup entries in the TRANSACTION REGISTER file by selecting: A) the transaction register id (A123 or RC456, etc); B) the transaction number which is the 2237, issue book, or purchase order number"
- +3 SET HELP(2)="(460-94-2-120-0010 or 120-0010 if its the same quarter and year or purchase order G12345); C) the voucher number (I400001)."
- +4 WRITE !
- DO DISPLAY^PRCPUX2(2,76,.HELP)
- +5 QUIT
- +6 ;
- +7 ;
- HELP(Y) ; display help (if Y="" ask start with)
- +1 NEW DATA,DIR,LINE,PRCPFLAG,TRANID,X
- +2 IF Y=""
- Begin DoDot:1
- +3 SET DIR(0)="S0^A:adjustment;RC:receipt;R:distribution regular;C:distribution call-in;E:distribution emergency;U:usage;P:physical count;S:case cart/instrument kit assembly or disassembly;"
- +4 SET DIR("A")=" Start HELP with entry type"
- SET DIR("B")="adjustment"
- +5 DO ^DIR
- End DoDot:1
- IF Y'="A"
- IF Y'="R"
- IF Y'="RC"
- IF Y'="C"
- IF Y'="U"
- IF Y'="P"
- IF Y'="S"
- IF Y'="E"
- QUIT
- +6 ;
- +7 ; show tranid entries
- +8 SET TRANID=Y
- FOR LINE=1:1
- SET TRANID=$ORDER(^PRCP(445.2,"T",PRCPINPT,TRANID))
- if TRANID=""
- QUIT
- Begin DoDot:1
- +9 SET DATA=$GET(^PRCP(445.2,+$ORDER(^PRCP(445.2,"T",PRCPINPT,TRANID,0)),0))
- SET Y=$PIECE(DATA,"^",3)
- +10 WRITE !?2,"tranid:",?10,$PIECE(DATA,"^",2),?20,$PIECE(DATA,"^",19),?40,$PIECE(DATA,"^",15),?50,$EXTRACT(Y,4,5),"-",$EXTRACT(Y,6,7),"-",$EXTRACT(Y,2,3)
- End DoDot:1
- IF LINE#15=0
- DO P^PRCPUREP
- if $GET(PRCPFLAG)
- QUIT
- +11 QUIT
