- PRCOSS1 ;WISC/DJM-SSO Server Interface to IFCAP ;8/20/93 14:42
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- Q
- EN1 ;CALLED FROM PRCHUSER PPM OPTION MENU ENTRY ACTION.
- ;NOTIFY PPM THAT NEW ENTRIES NEED TO BE ADDED INTO FILE 441.
- I $O(^PRCF(423.6,"AC",0))>0 W $C(7),!!!,?3,"There are new ITEM MASTER entries from ISMS SSO transaction to be added." Q
- Q
- DISP ;CALLED FROM EN1^PRCHE.
- ;DISPLAY ALL "SL" SEGMENTS THAT:
- ; 1. ARE FOR THE USER'S SITE.
- ; 2. THE NSN IS NOT FOUND IN FILE 441.
- N CS,FS,HDR,INACT,INACTF,NSN,NSNB,NSNC,NSND,NSNF,SC,VEN,VENF,VEN1,X,X1,X2,Y,Y1
- S HDR="",X=0 F S X=$O(^PRCF(423.6,"AC",65,X)) Q:X'>0 S X1=^PRCF(423.6,X,1,10000,0) I $P(X1,U,3)=PRC("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" S (NSNF,INACTF,VENF)="" 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=0
- D0 ..S NSNB=$O(^PRC(441,"BB",NSN,NSNB)),NSNC="" I NSNB'>0 S NSNF=1 G D1
- ..S NSNC=^PRC(441,NSNB,0),NSND=NSNB I $P(NSNC,U,5)'=NSN S NSNF=1 G D1
- ..S INACT=$G(^PRC(441,NSNB,3)) I +INACT=1 S INACTF=1 G D0
- ..S CS=$P(Y1,U,5),VEN=$G(^PRC(441,NSNB,2,0)) I VEN="" S VENF=1 G D1
- ..S VENF=1,VEN=0 F S VEN=$O(^PRC(441,NSNB,2,VEN)) G:VEN'>0 D1 S SC="" D I CS=$P(SC,U) S VENF="" G D1
- ...S VEN1=^PRC(441,NSNB,2,VEN,0) Q:VEN1="" S FS=$G(^PRC(440,+VEN1,2)) Q:FS="" S FS=$P(FS,U,2) Q:FS="" S SC=$G(^PRCD(420.8,FS,0)) Q
- D1 ..I NSNF!INACTF!VENF D:HDR="" W !,NSN,?23,$P(Y1,U,3),?32,$P(Y1,U,5) W:INACTF ?42,"YES" W:INACTF!VENF ?52,NSND W:VENF ?65,"NO" Q
- ...S X2="New items from SSO transactions to add" W ?(IOM-$L(X2))\2-10,X2,!!,?6,"NSN",?23,"SKU",?31,"SOURCE",?40,"INACTIVE",?52,"NUMBER",?62,"SOURCE OK" S HDR=1 Q
- W ! Q
- CHECK ;CALLED FROM EN1^PRCHE.
- ;CHECK ALL RECORDS THAT:
- ; 1. ARE FOR THE USER'S SITE.
- ; 2. ALL NSN IN THE "SSO" TRANSACTION EXIST IN FILE 441.
- ; 3. IF NSN FOUND, CHECK THAT ITEM MASTER ENTRY IS ACTIVE.
- ; 4. IF ITEM MASTER ENTRY IS CORRECT, CHECK THAT SOURCE CODE EQUALS
- ; THE SUGGESTED SOURCE IN "SSO" TRANSACTION.
- ;
- ;IF THE RECORD PASSES THE CHECKS, START UP A NEW BACKGROUND TASK TO
- ;CHECK FOR FILE 445 ENTRIES.
- ;
- N CS,DA,DIE,DR,INACT,NSN,NSNB,NSNC,NSNF,PRCDA,SC,VEN,VENF,VEN1,X,X1,Y,Y1,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
- S X=0 F S X=$O(^PRCF(423.6,"AC",65,X)) Q:X'>0 S X1=^PRCF(423.6,X,1,10000,0) I $P(X1,U,3)=PRC("SITE") S NSNF="" 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 Q:NSNF=1
- ..S NSN=$P(Y1,U,2),NSN=$E(NSN,1,4)_"-"_$E(NSN,5,6)_"-"_$E(NSN,7,9)_"-"_$E(NSN,10,99),NSNB=0
- CK1 ..S NSNB=$O(^PRC(441,"BB",NSN,NSNB)),NSNC="" I NSNB'>0 S NSNF=1 Q
- ..S NSNC=^PRC(441,NSNB,0) I $P(NSNC,U,5)'=NSN S NSNF=1 Q
- ..S INACT=$G(^PRC(441,NSNB,3)) I +INACT=1 G CK1
- ..S CS=$P(Y1,U,5),VEN=$G(^PRC(441,NSNB,2,0)) I VEN="" S NSNF=1 Q
- ..S VENF=1,VEN=0 F S VEN=$O(^PRC(441,NSNB,2,VEN)) Q:VEN'>0 S SC="" D I CS=$P(SC,U) S VENF="" Q
- ...S VEN1=^PRC(441,NSNB,2,VEN,0) Q:VEN1="" S FS=$G(^PRC(440,+VEN1,2)) Q:FS="" S FS=$P(FS,U,2) Q:FS'>0 S SC=$G(^PRCD(420.8,FS,0)) Q
- ..S:VENF NSNF=1 Q
- .I NSNF="",X>0 S PRCDA=X,ZTSAVE("PRCDA")="",ZTSAVE("ZTREQ")="@",ZTRTN="SSO1^PRCOSSO",ZTDTH=$H,ZTIO="" D ^%ZTLOAD L +^PRCF(423.6,PRCDA,0) S DIE="^PRCF(423.6,",DA=PRCDA,DR="3///@;2///^S X=ZTSK" D ^DIE L -^PRCF(423.6,PRCDA,0)
- .Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCOSS1 3347 printed Feb 18, 2025@23:38:34 Page 2
- PRCOSS1 ;WISC/DJM-SSO Server Interface to IFCAP ;8/20/93 14:42
- 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 PRCHUSER PPM OPTION MENU ENTRY ACTION.
- +1 ;NOTIFY PPM THAT NEW ENTRIES NEED TO BE ADDED INTO FILE 441.
- +2 IF $ORDER(^PRCF(423.6,"AC",0))>0
- WRITE $CHAR(7),!!!,?3,"There are new ITEM MASTER entries from ISMS SSO transaction to be added."
- QUIT
- +3 QUIT
- DISP ;CALLED FROM EN1^PRCHE.
- +1 ;DISPLAY ALL "SL" SEGMENTS THAT:
- +2 ; 1. ARE FOR THE USER'S SITE.
- +3 ; 2. THE NSN IS NOT FOUND IN FILE 441.
- +4 NEW CS,FS,HDR,INACT,INACTF,NSN,NSNB,NSNC,NSND,NSNF,SC,VEN,VENF,VEN1,X,X1,X2,Y,Y1
- +5 SET HDR=""
- SET X=0
- FOR
- SET X=$ORDER(^PRCF(423.6,"AC",65,X))
- if X'>0
- QUIT
- SET X1=^PRCF(423.6,X,1,10000,0)
- IF $PIECE(X1,U,3)=PRC("SITE")
- Begin DoDot:1
- +6 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"
- SET (NSNF,INACTF,VENF)=""
- Begin DoDot:2
- +7 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=0
- D0 SET NSNB=$ORDER(^PRC(441,"BB",NSN,NSNB))
- SET NSNC=""
- IF NSNB'>0
- SET NSNF=1
- GOTO D1
- +1 SET NSNC=^PRC(441,NSNB,0)
- SET NSND=NSNB
- IF $PIECE(NSNC,U,5)'=NSN
- SET NSNF=1
- GOTO D1
- +2 SET INACT=$GET(^PRC(441,NSNB,3))
- IF +INACT=1
- SET INACTF=1
- GOTO D0
- +3 SET CS=$PIECE(Y1,U,5)
- SET VEN=$GET(^PRC(441,NSNB,2,0))
- IF VEN=""
- SET VENF=1
- GOTO D1
- +4 SET VENF=1
- SET VEN=0
- FOR
- SET VEN=$ORDER(^PRC(441,NSNB,2,VEN))
- if VEN'>0
- GOTO D1
- SET SC=""
- Begin DoDot:3
- +5 SET VEN1=^PRC(441,NSNB,2,VEN,0)
- if VEN1=""
- QUIT
- SET FS=$GET(^PRC(440,+VEN1,2))
- if FS=""
- QUIT
- SET FS=$PIECE(FS,U,2)
- if FS=""
- QUIT
- SET SC=$GET(^PRCD(420.8,FS,0))
- QUIT
- End DoDot:3
- IF CS=$PIECE(SC,U)
- SET VENF=""
- GOTO D1
- D1 IF NSNF!INACTF!VENF
- if HDR=""
- Begin DoDot:3
- +1 SET X2="New items from SSO transactions to add"
- WRITE ?(IOM-$LENGTH(X2))\2-10,X2,!!,?6,"NSN",?23,"SKU",?31,"SOURCE",?40,"INACTIVE",?52,"NUMBER",?62,"SOURCE OK"
- SET HDR=1
- QUIT
- End DoDot:3
- WRITE !,NSN,?23,$PIECE(Y1,U,3),?32,$PIECE(Y1,U,5)
- if INACTF
- WRITE ?42,"YES"
- if INACTF!VENF
- WRITE ?52,NSND
- if VENF
- WRITE ?65,"NO"
- QUIT
- End DoDot:2
- End DoDot:1
- +2 WRITE !
- QUIT
- CHECK ;CALLED FROM EN1^PRCHE.
- +1 ;CHECK ALL RECORDS THAT:
- +2 ; 1. ARE FOR THE USER'S SITE.
- +3 ; 2. ALL NSN IN THE "SSO" TRANSACTION EXIST IN FILE 441.
- +4 ; 3. IF NSN FOUND, CHECK THAT ITEM MASTER ENTRY IS ACTIVE.
- +5 ; 4. IF ITEM MASTER ENTRY IS CORRECT, CHECK THAT SOURCE CODE EQUALS
- +6 ; THE SUGGESTED SOURCE IN "SSO" TRANSACTION.
- +7 ;
- +8 ;IF THE RECORD PASSES THE CHECKS, START UP A NEW BACKGROUND TASK TO
- +9 ;CHECK FOR FILE 445 ENTRIES.
- +10 ;
- +11 NEW CS,DA,DIE,DR,INACT,NSN,NSNB,NSNC,NSNF,PRCDA,SC,VEN,VENF,VEN1,X,X1,Y,Y1,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
- +12 SET X=0
- FOR
- SET X=$ORDER(^PRCF(423.6,"AC",65,X))
- if X'>0
- QUIT
- SET X1=^PRCF(423.6,X,1,10000,0)
- IF $PIECE(X1,U,3)=PRC("SITE")
- SET NSNF=""
- Begin DoDot:1
- +13 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
- +14 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=0
- CK1 SET NSNB=$ORDER(^PRC(441,"BB",NSN,NSNB))
- SET NSNC=""
- IF NSNB'>0
- SET NSNF=1
- QUIT
- +1 SET NSNC=^PRC(441,NSNB,0)
- IF $PIECE(NSNC,U,5)'=NSN
- SET NSNF=1
- QUIT
- +2 SET INACT=$GET(^PRC(441,NSNB,3))
- IF +INACT=1
- GOTO CK1
- +3 SET CS=$PIECE(Y1,U,5)
- SET VEN=$GET(^PRC(441,NSNB,2,0))
- IF VEN=""
- SET NSNF=1
- QUIT
- +4 SET VENF=1
- SET VEN=0
- FOR
- SET VEN=$ORDER(^PRC(441,NSNB,2,VEN))
- if VEN'>0
- QUIT
- SET SC=""
- Begin DoDot:3
- +5 SET VEN1=^PRC(441,NSNB,2,VEN,0)
- if VEN1=""
- QUIT
- SET FS=$GET(^PRC(440,+VEN1,2))
- if FS=""
- QUIT
- SET FS=$PIECE(FS,U,2)
- if FS'>0
- QUIT
- SET SC=$GET(^PRCD(420.8,FS,0))
- QUIT
- End DoDot:3
- IF CS=$PIECE(SC,U)
- SET VENF=""
- QUIT
- +6 if VENF
- SET NSNF=1
- QUIT
- End DoDot:2
- if NSNF=1
- QUIT
- +7 IF NSNF=""
- IF X>0
- SET PRCDA=X
- SET ZTSAVE("PRCDA")=""
- SET ZTSAVE("ZTREQ")="@"
- SET ZTRTN="SSO1^PRCOSSO"
- SET ZTDTH=$HOROLOG
- SET ZTIO=""
- DO ^%ZTLOAD
- LOCK +^PRCF(423.6,PRCDA,0)
- SET DIE="^PRCF(423.6,"
- SET DA=PRCDA
- SET DR="3///@;2///^S X=ZTSK"
- DO ^DIE
- LOCK -^PRCF(423.6,PRCDA,0)
- +8 QUIT
- End DoDot:1
- +9 QUIT