- PRCPRPHW ;WISC/RFJ-physical count form ; 3/22/99 11:17am
- ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- D ^PRCPUSEL Q:'$G(PRCP("I"))
- N %,%H,%I,A,ACCOUNT,ACCT,ACCTALL,D,DIR,DIRUT,DTOUT,DUOUT,ITEMDA,MAIN,NOW,NSN,PAGE,PRCPEXIT,PRCPFLAG,PRCPOH,SCREEN,X,Y
- S PRCPOH=0
- S XP="Do you need to print the ON-HAND column"
- S XH="Enter 'YES' only if you are NOT performing a physical count."
- W ! S %=$$YN^PRCPUYN(2)
- I %=0 Q
- I %=1 S PRCPOH=1
- W !!,"Selected account codes will be used to generate the physical count form."
- K ACCOUNT D ALLACCT I $G(PRCPFLAG) Q
- F D I $G(PRCPFLAG) Q
- . I $O(ACCOUNT("YES",0))!($G(ACCTALL)) D
- . . W !!," Currently selected account codes:",!," "
- . . I $G(ACCTALL) W "<< ALL ACCOUNT CODES >>"
- . . E S A=0 F S A=$O(ACCOUNT("YES",A)) Q:'A W:$X>70 !," " W A," "
- . . W !," You can DE-select one of the above account codes by reselecting it."
- . I $O(ACCOUNT("NO",0)) D
- . . W !!," Currently DE-selected account codes:",!," "
- . . S A=0 F S A=$O(ACCOUNT("NO",A)) Q:'A W:$X>70 !," " W A," "
- . . W !," You can RE-select one of the above account codes by reselecting it."
- . W !!,"Select the number of the account code created, '^' to exit."
- . S DIR(0)="SO^1:Account Code 1;2:Account Code 2;3:Account Code 3;6:Account Code 6;8:Account Code 8;",DIR("A")="Select ACCOUNT Code" D ^DIR I $D(DTOUT)!($D(DUOUT)) S (PRCPFLAG,PRCPEXIT)=1 Q
- . S Y=+Y
- . I Y=0,'$O(ACCOUNT("YES",0)),'$G(ACCTALL) D ALLACCT S:$G(PRCPFLAG) PRCPEXIT=1 Q
- . I Y=0 S PRCPFLAG=1 Q
- . I $G(ACCTALL),'$D(ACCOUNT("NO",Y)) K ACCOUNT("YES",Y) S ACCOUNT("NO",Y)="" W !?10,"DE-selected !" Q
- . I $D(ACCOUNT("YES",Y)) K ACCOUNT("YES",Y) S ACCOUNT("NO",Y)="" W !?10,"DE-selected !" Q
- . I $D(ACCOUNT("NO",Y)) K ACCOUNT("NO",Y) S ACCOUNT("YES",Y)="" W !?10,"RE-selected !" Q
- . S ACCOUNT("YES",Y)="" W !?10,"selected !"
- I $G(PRCPEXIT) D Q Q
- I $G(ACCTALL) K ACCOUNT("YES")
- I '$G(ACCTALL),'$O(ACCOUNT("YES",0)) W !!,"NO ACCOUNT CODES SELECTED." D Q Q
- I $G(ACCTALL) F A=1,2,3,6,8 I '$D(ACCOUNT("NO",A)) S ACCOUNT("YES",A)=""
- S %ZIS="Q" W ! D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
- . S ZTDESC="Physical Count Form",ZTRTN="DQ^PRCPRPHW"
- . S ZTSAVE("PRCP*")="",ZTSAVE("ACC*")="",ZTSAVE("ZTREQ")="@"
- W !!,"<*> please wait <*>"
- DQ ;queue comes here
- K ^TMP($J,"PRCPRPH"),PRCPFLAG
- S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA S NSN=$$NSN^PRCPUX1(ITEMDA),ACCT=$$ACCT1^PRCPUX1($E(NSN,1,4)) I $D(ACCOUNT("YES",ACCT)) D
- . S:NSN="" NSN=" "
- . S %=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0)),MAIN=+$P(%,"^",6),MAIN=$$STORELOC^PRCPESTO(MAIN) S:MAIN="?" MAIN=" ?"
- . S ^TMP($J,"PRCPRPH",MAIN,ACCT,NSN,ITEMDA)=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA)_"^"_$$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/")_"^"_$P(%,"^",7)
- D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO D H
- S MAIN="" F S MAIN=$O(^TMP($J,"PRCPRPH",MAIN)) Q:MAIN=""!($G(PRCPFLAG)) D
- . W !!?5,"MAIN STORAGE LOCATION: ",MAIN
- . S ACCT="" F S ACCT=$O(^TMP($J,"PRCPRPH",MAIN,ACCT)) Q:ACCT=""!($G(PRCPFLAG)) D
- . . W !?10,"ACCOUNT CODE: ",ACCT
- . . S NSN="" F S NSN=$O(^TMP($J,"PRCPRPH",MAIN,ACCT,NSN)) Q:NSN=""!($G(PRCPFLAG)) S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPRPH",MAIN,ACCT,NSN,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) S D=^(ITEMDA) D
- . . . W !,$TR(NSN,"-"),?17,$E($P(D,"^"),1,23),?42,ITEMDA,?47,$J($P(D,"^",2),10)
- . . . I PRCPOH=1 W $J($P(D,"^",3),12)
- . . . W ?71,"_________"
- . . . S X=0 F Y=1:1 S X=$O(^PRCP(445,PRCP("I"),1,ITEMDA,1,X)) Q:'X S D=$G(^(X,0)) I D'="" D
- . . . . I Y=1 W !?20,"ADD STORAGE: "
- . . . . I $X>50 W !?20
- . . . . W $E($$STORELOC^PRCPESTO($P(D,"^")),1,15)," "
- . . . . I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
- . . . I $G(PRCPFLAG) Q
- . . . I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
- . . I $G(PRCPFLAG) Q
- . . I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
- . . I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
- . I $G(PRCPFLAG) Q
- . I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
- I '$G(PRCPFLAG) D END^PRCPUREP
- Q K ^TMP($J,"PRCPRPH") D ^%ZISC Q
- ;
- ;
- ALLACCT ; select all account codes
- K ACCTALL,PRCPFLAG
- S XP="Do you want to select ALL account codes",XH="Enter 'YES' to generate the physical count form for ALL acount codes",XH(1)="enter 'NO' to print the physical count form for selectable account codes"
- S XH(2)="or enter '^' to exit."
- W ! S %=$$YN^PRCPUYN(1)
- I %=2 Q
- I %=1 S ACCTALL=1 Q
- S PRCPFLAG=1 Q
- ;
- ;
- H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
- W $C(13),"PHYSICAL COUNT FORM: ",$E(PRCP("IN"),1,12),?(80-$L(%)),%
- S %="",$P(%,"-",81)="" W !,"NSN",?15,"DESCRIPTION",?42,"MI",?50,"UNIT/ISS"
- I PRCPOH=1 W ?62,"ON HAND"
- W ?71,"NEW COUNT",!,%
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRPHW 4998 printed Apr 23, 2025@18:29:50 Page 2
- PRCPRPHW ;WISC/RFJ-physical count form ; 3/22/99 11:17am
- +1 ;;5.1;IFCAP;;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 DO ^PRCPUSEL
- if '$GET(PRCP("I"))
- QUIT
- +4 NEW %,%H,%I,A,ACCOUNT,ACCT,ACCTALL,D,DIR,DIRUT,DTOUT,DUOUT,ITEMDA,MAIN,NOW,NSN,PAGE,PRCPEXIT,PRCPFLAG,PRCPOH,SCREEN,X,Y
- +5 SET PRCPOH=0
- +6 SET XP="Do you need to print the ON-HAND column"
- +7 SET XH="Enter 'YES' only if you are NOT performing a physical count."
- +8 WRITE !
- SET %=$$YN^PRCPUYN(2)
- +9 IF %=0
- QUIT
- +10 IF %=1
- SET PRCPOH=1
- +11 WRITE !!,"Selected account codes will be used to generate the physical count form."
- +12 KILL ACCOUNT
- DO ALLACCT
- IF $GET(PRCPFLAG)
- QUIT
- +13 FOR
- Begin DoDot:1
- +14 IF $ORDER(ACCOUNT("YES",0))!($GET(ACCTALL))
- Begin DoDot:2
- +15 WRITE !!," Currently selected account codes:",!," "
- +16 IF $GET(ACCTALL)
- WRITE "<< ALL ACCOUNT CODES >>"
- +17 IF '$TEST
- SET A=0
- FOR
- SET A=$ORDER(ACCOUNT("YES",A))
- if 'A
- QUIT
- if $X>70
- WRITE !," "
- WRITE A," "
- +18 WRITE !," You can DE-select one of the above account codes by reselecting it."
- End DoDot:2
- +19 IF $ORDER(ACCOUNT("NO",0))
- Begin DoDot:2
- +20 WRITE !!," Currently DE-selected account codes:",!," "
- +21 SET A=0
- FOR
- SET A=$ORDER(ACCOUNT("NO",A))
- if 'A
- QUIT
- if $X>70
- WRITE !," "
- WRITE A," "
- +22 WRITE !," You can RE-select one of the above account codes by reselecting it."
- End DoDot:2
- +23 WRITE !!,"Select the number of the account code created, '^' to exit."
- +24 SET DIR(0)="SO^1:Account Code 1;2:Account Code 2;3:Account Code 3;6:Account Code 6;8:Account Code 8;"
- SET DIR("A")="Select ACCOUNT Code"
- DO ^DIR
- IF $DATA(DTOUT)!($DATA(DUOUT))
- SET (PRCPFLAG,PRCPEXIT)=1
- QUIT
- +25 SET Y=+Y
- +26 IF Y=0
- IF '$ORDER(ACCOUNT("YES",0))
- IF '$GET(ACCTALL)
- DO ALLACCT
- if $GET(PRCPFLAG)
- SET PRCPEXIT=1
- QUIT
- +27 IF Y=0
- SET PRCPFLAG=1
- QUIT
- +28 IF $GET(ACCTALL)
- IF '$DATA(ACCOUNT("NO",Y))
- KILL ACCOUNT("YES",Y)
- SET ACCOUNT("NO",Y)=""
- WRITE !?10,"DE-selected !"
- QUIT
- +29 IF $DATA(ACCOUNT("YES",Y))
- KILL ACCOUNT("YES",Y)
- SET ACCOUNT("NO",Y)=""
- WRITE !?10,"DE-selected !"
- QUIT
- +30 IF $DATA(ACCOUNT("NO",Y))
- KILL ACCOUNT("NO",Y)
- SET ACCOUNT("YES",Y)=""
- WRITE !?10,"RE-selected !"
- QUIT
- +31 SET ACCOUNT("YES",Y)=""
- WRITE !?10,"selected !"
- End DoDot:1
- IF $GET(PRCPFLAG)
- QUIT
- +32 IF $GET(PRCPEXIT)
- DO Q
- QUIT
- +33 IF $GET(ACCTALL)
- KILL ACCOUNT("YES")
- +34 IF '$GET(ACCTALL)
- IF '$ORDER(ACCOUNT("YES",0))
- WRITE !!,"NO ACCOUNT CODES SELECTED."
- DO Q
- QUIT
- +35 IF $GET(ACCTALL)
- FOR A=1,2,3,6,8
- IF '$DATA(ACCOUNT("NO",A))
- SET ACCOUNT("YES",A)=""
- +36 SET %ZIS="Q"
- WRITE !
- DO ^%ZIS
- if POP
- QUIT
- IF $DATA(IO("Q"))
- Begin DoDot:1
- +37 SET ZTDESC="Physical Count Form"
- SET ZTRTN="DQ^PRCPRPHW"
- +38 SET ZTSAVE("PRCP*")=""
- SET ZTSAVE("ACC*")=""
- SET ZTSAVE("ZTREQ")="@"
- End DoDot:1
- DO ^%ZTLOAD
- KILL IO("Q"),ZTSK
- QUIT
- +39 WRITE !!,"<*> please wait <*>"
- DQ ;queue comes here
- +1 KILL ^TMP($JOB,"PRCPRPH"),PRCPFLAG
- +2 SET ITEMDA=0
- FOR
- SET ITEMDA=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA))
- if 'ITEMDA
- QUIT
- SET NSN=$$NSN^PRCPUX1(ITEMDA)
- SET ACCT=$$ACCT1^PRCPUX1($EXTRACT(NSN,1,4))
- IF $DATA(ACCOUNT("YES",ACCT))
- Begin DoDot:1
- +3 if NSN=""
- SET NSN=" "
- +4 SET %=$GET(^PRCP(445,PRCP("I"),1,ITEMDA,0))
- SET MAIN=+$PIECE(%,"^",6)
- SET MAIN=$$STORELOC^PRCPESTO(MAIN)
- if MAIN="?"
- SET MAIN=" ?"
- +5 SET ^TMP($JOB,"PRCPRPH",MAIN,ACCT,NSN,ITEMDA)=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA)_"^"_$$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/")_"^"_$PIECE(%,"^",7)
- End DoDot:1
- +6 DO NOW^%DTC
- SET Y=%
- DO DD^%DT
- SET NOW=Y
- SET PAGE=1
- SET SCREEN=$$SCRPAUSE^PRCPUREP
- USE IO
- DO H
- +7 SET MAIN=""
- FOR
- SET MAIN=$ORDER(^TMP($JOB,"PRCPRPH",MAIN))
- if MAIN=""!($GET(PRCPFLAG))
- QUIT
- Begin DoDot:1
- +8 WRITE !!?5,"MAIN STORAGE LOCATION: ",MAIN
- +9 SET ACCT=""
- FOR
- SET ACCT=$ORDER(^TMP($JOB,"PRCPRPH",MAIN,ACCT))
- if ACCT=""!($GET(PRCPFLAG))
- QUIT
- Begin DoDot:2
- +10 WRITE !?10,"ACCOUNT CODE: ",ACCT
- +11 SET NSN=""
- FOR
- SET NSN=$ORDER(^TMP($JOB,"PRCPRPH",MAIN,ACCT,NSN))
- if NSN=""!($GET(PRCPFLAG))
- QUIT
- SET ITEMDA=0
- FOR
- SET ITEMDA=$ORDER(^TMP($JOB,"PRCPRPH",MAIN,ACCT,NSN,ITEMDA))
- if 'ITEMDA!($GET(PRCPFLAG))
- QUIT
- SET D=^(ITEMDA)
- Begin DoDot:3
- +12 WRITE !,$TRANSLATE(NSN,"-"),?17,$EXTRACT($PIECE(D,"^"),1,23),?42,ITEMDA,?47,$JUSTIFY($PIECE(D,"^",2),10)
- +13 IF PRCPOH=1
- WRITE $JUSTIFY($PIECE(D,"^",3),12)
- +14 WRITE ?71,"_________"
- +15 SET X=0
- FOR Y=1:1
- SET X=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,1,X))
- if 'X
- QUIT
- SET D=$GET(^(X,0))
- IF D'=""
- Begin DoDot:4
- +16 IF Y=1
- WRITE !?20,"ADD STORAGE: "
- +17 IF $X>50
- WRITE !?20
- +18 WRITE $EXTRACT($$STORELOC^PRCPESTO($PIECE(D,"^")),1,15)," "
- +19 IF $Y>(IOSL-4)
- if SCREEN
- DO P^PRCPUREP
- if $DATA(PRCPFLAG)
- QUIT
- DO H
- End DoDot:4
- +20 IF $GET(PRCPFLAG)
- QUIT
- +21 IF $Y>(IOSL-6)
- if SCREEN
- DO P^PRCPUREP
- if $DATA(PRCPFLAG)
- QUIT
- DO H
- End DoDot:3
- +22 IF $GET(PRCPFLAG)
- QUIT
- +23 IF $Y>(IOSL-6)
- if SCREEN
- DO P^PRCPUREP
- if $DATA(PRCPFLAG)
- QUIT
- DO H
- +24 IF $GET(ZTQUEUED)
- IF $$S^%ZTLOAD
- SET PRCPFLAG=1
- WRITE !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
- End DoDot:2
- +25 IF $GET(PRCPFLAG)
- QUIT
- +26 IF $Y>(IOSL-6)
- if SCREEN
- DO P^PRCPUREP
- if $DATA(PRCPFLAG)
- QUIT
- DO H
- End DoDot:1
- +27 IF '$GET(PRCPFLAG)
- DO END^PRCPUREP
- Q KILL ^TMP($JOB,"PRCPRPH")
- DO ^%ZISC
- QUIT
- +1 ;
- +2 ;
- ALLACCT ; select all account codes
- +1 KILL ACCTALL,PRCPFLAG
- +2 SET XP="Do you want to select ALL account codes"
- SET XH="Enter 'YES' to generate the physical count form for ALL acount codes"
- SET XH(1)="enter 'NO' to print the physical count form for selectable account codes"
- +3 SET XH(2)="or enter '^' to exit."
- +4 WRITE !
- SET %=$$YN^PRCPUYN(1)
- +5 IF %=2
- QUIT
- +6 IF %=1
- SET ACCTALL=1
- QUIT
- +7 SET PRCPFLAG=1
- QUIT
- +8 ;
- +9 ;
- H SET %=NOW_" PAGE "_PAGE
- SET PAGE=PAGE+1
- IF PAGE'=2!(SCREEN)
- WRITE @IOF
- +1 WRITE $CHAR(13),"PHYSICAL COUNT FORM: ",$EXTRACT(PRCP("IN"),1,12),?(80-$LENGTH(%)),%
- +2 SET %=""
- SET $PIECE(%,"-",81)=""
- WRITE !,"NSN",?15,"DESCRIPTION",?42,"MI",?50,"UNIT/ISS"
- +3 IF PRCPOH=1
- WRITE ?62,"ON HAND"
- +4 WRITE ?71,"NEW COUNT",!,%
- +5 QUIT
