- PRCOSS2 ;WISC/DJM-SSO Server Interface to IFCAP ;7/8/94 09:02
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- Q
- EN1 ;CALLED FROM PRCPW MAIN MENU OPTION MENU ENTRY ACTION.
- ;NOTIFY PPM THAT NEW ENTRIES SHOULD BE ADDED INTO FILE 445 FOR THE WAREHOUSE
- I $O(^PRCF(423.6,"AD",0))>0 W $C(7),!!!,?3,"There are new GENERIC INVENTORY entries from ISMS SSO transaction to add",!,?3,"to the warehouse inventory." Q
- Q
- DISP(PRCPZ) ;CALLED FROM ^PRCPEITO.
- ;DISPLAY ALL ITEMS THAT ARE NOT IN THE WAREHOUSE INVENTORY LIST
- Q:PRCPZ("DPTYPE")'="W" N HDR,NSN,NSNB,NSNC,SITE,X,X1,X2,Y,Y1,Y2
- S SITE=+^PRCP(445,PRCP("I"),0),HDR="",X=0 F S X=$O(^PRCF(423.6,"AD",65,X)) Q:X'>0 S X1=^PRCF(423.6,X,1,10000,0) I $P(X1,U,3)=SITE D
- .S Y=0 F S Y=$O(^PRCF(423.6,X,1,Y)) Q:Y'>0 S Y1=^(Y,0) I $P(Y1,U)="SL" D
- ..S NSN=$P(Y1,U,2),NSN=$E(NSN,1,4)_"-"_$E(NSN,5,6)_"-"_$E(NSN,7,9)_"-"_$E(NSN,10,99),NSNB=$O(^PRC(441,"BB",NSN,0)),NSNC="" S:NSNB>0 NSNC=^PRC(441,NSNB,0) I NSNB>0 S Y2=$G(^PRCP(445,PRCP("I"),1,NSNB,0)) Q:Y2]""
- ..D:HDR="" W !,"ITEM #: ",NSNB,?17,"ITEM DESCRIPTION: ",$P(NSNC,U,2) Q
- ...S X2="New items from SSO transaction to add to Warehouse" W !,?(IOM-$L(X2))\2,X2,! S HDR=1 Q
- W ! Q
- CHECK(PRCPZ) ;CALLED FROM ^PRCPEITO.
- ;SINCE ALL THE ITEMS NEED NOT BE ENTERED INTO THE WAREHOUSE INVENTORY
- ;LIST IN FILE 445, JUST TAKE OFF THE INVENTORY FLAG AND START UP THE
- ;THIRD PART OF PRCOSSO - CREATE THE REPETITIVE ITEM LIST IN FILE 410.3.
- Q:PRCPZ("DPTYPE")'="W" N %,D,DA,DI,DIC,DIE,DQ,DR,D0,PRCDA,SITE,X,X1,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
- S SITE=+^PRCP(445,PRCP("I"),0),X=0 F S X=$O(^PRCF(423.6,"AD",65,X)) Q:X'>0 S X1=^PRCF(423.6,X,1,10000,0) I $P(X1,U,3)=SITE D
- .S PRCDA=X,ZTSAVE("PRCDA")="",ZTSAVE("ZTREQ")="@",ZTRTN="SSO2^PRCOSS6",ZTDTH=$H,ZTIO="" D ^%ZTLOAD L +^PRCF(423.6,PRCDA,0) S DIE="^PRCF(423.6,",DA=PRCDA,DR="4///@;2///^S X=ZTSK" D ^DIE L -^PRCF(423.6,PRCDA,0)
- .Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCOSS2 1945 printed Mar 13, 2025@21:17 Page 2
- PRCOSS2 ;WISC/DJM-SSO Server Interface to IFCAP ;7/8/94 09:02
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 QUIT
- EN1 ;CALLED FROM PRCPW MAIN MENU OPTION MENU ENTRY ACTION.
- +1 ;NOTIFY PPM THAT NEW ENTRIES SHOULD BE ADDED INTO FILE 445 FOR THE WAREHOUSE
- +2 IF $ORDER(^PRCF(423.6,"AD",0))>0
- WRITE $CHAR(7),!!!,?3,"There are new GENERIC INVENTORY entries from ISMS SSO transaction to add",!,?3,"to the warehouse inventory."
- QUIT
- +3 QUIT
- DISP(PRCPZ) ;CALLED FROM ^PRCPEITO.
- +1 ;DISPLAY ALL ITEMS THAT ARE NOT IN THE WAREHOUSE INVENTORY LIST
- +2 if PRCPZ("DPTYPE")'="W"
- QUIT
- NEW HDR,NSN,NSNB,NSNC,SITE,X,X1,X2,Y,Y1,Y2
- +3 SET SITE=+^PRCP(445,PRCP("I"),0)
- SET HDR=""
- SET X=0
- FOR
- SET X=$ORDER(^PRCF(423.6,"AD",65,X))
- if X'>0
- QUIT
- SET X1=^PRCF(423.6,X,1,10000,0)
- IF $PIECE(X1,U,3)=SITE
- Begin DoDot:1
- +4 SET Y=0
- FOR
- SET Y=$ORDER(^PRCF(423.6,X,1,Y))
- if Y'>0
- QUIT
- SET Y1=^(Y,0)
- IF $PIECE(Y1,U)="SL"
- Begin DoDot:2
- +5 SET NSN=$PIECE(Y1,U,2)
- SET NSN=$EXTRACT(NSN,1,4)_"-"_$EXTRACT(NSN,5,6)_"-"_$EXTRACT(NSN,7,9)_"-"_$EXTRACT(NSN,10,99)
- SET NSNB=$ORDER(^PRC(441,"BB",NSN,0))
- SET NSNC=""
- if NSNB>0
- SET NSNC=^PRC(441,NSNB,0)
- IF NSNB>0
- SET Y2=$GET(^PRCP(445,PRCP("I"),1,NSNB,0))
- if Y2]""
- QUIT
- +6 if HDR=""
- Begin DoDot:3
- +7 SET X2="New items from SSO transaction to add to Warehouse"
- WRITE !,?(IOM-$LENGTH(X2))\2,X2,!
- SET HDR=1
- QUIT
- End DoDot:3
- WRITE !,"ITEM #: ",NSNB,?17,"ITEM DESCRIPTION: ",$PIECE(NSNC,U,2)
- QUIT
- End DoDot:2
- End DoDot:1
- +8 WRITE !
- QUIT
- CHECK(PRCPZ) ;CALLED FROM ^PRCPEITO.
- +1 ;SINCE ALL THE ITEMS NEED NOT BE ENTERED INTO THE WAREHOUSE INVENTORY
- +2 ;LIST IN FILE 445, JUST TAKE OFF THE INVENTORY FLAG AND START UP THE
- +3 ;THIRD PART OF PRCOSSO - CREATE THE REPETITIVE ITEM LIST IN FILE 410.3.
- +4 if PRCPZ("DPTYPE")'="W"
- QUIT
- NEW %,D,DA,DI,DIC,DIE,DQ,DR,D0,PRCDA,SITE,X,X1,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
- +5 SET SITE=+^PRCP(445,PRCP("I"),0)
- SET X=0
- FOR
- SET X=$ORDER(^PRCF(423.6,"AD",65,X))
- if X'>0
- QUIT
- SET X1=^PRCF(423.6,X,1,10000,0)
- IF $PIECE(X1,U,3)=SITE
- Begin DoDot:1
- +6 SET PRCDA=X
- SET ZTSAVE("PRCDA")=""
- SET ZTSAVE("ZTREQ")="@"
- SET ZTRTN="SSO2^PRCOSS6"
- SET ZTDTH=$HOROLOG
- SET ZTIO=""
- DO ^%ZTLOAD
- LOCK +^PRCF(423.6,PRCDA,0)
- SET DIE="^PRCF(423.6,"
- SET DA=PRCDA
- SET DR="4///@;2///^S X=ZTSK"
- DO ^DIE
- LOCK -^PRCF(423.6,PRCDA,0)
- +7 QUIT
- End DoDot:1
- +8 QUIT
