- PRCOSSO ;WISC/DJM-SSO Server Interface to IFCAP ;10/3/94 10:45 AM
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- Q
- SSO ;SUGGESTED ORDER TRANSACTION FROM AUSTIN USED TO CREATE A REPETITIVE ITEM LIST
- N %,A,AA,AQ,A1,B,C,COUNT,CP,CS,CSF,DA,DIC,DIE,DIK,DR,DT,E,F,FS,FY,INACT,LC,L1,MO,NSN,NSNB,NSNC,NSNF,PRCDA,QTR,QTY,QTYL,REC,SC,SITE,TC,TIME,TYP,UC,VEN,VEN1,VENDOR,WF,Y,Y1,YR
- S A=1,A1="" F S A=$O(^PRC(411,"B",A)) Q:A'>0 S A1=A1_"-"_A
- S:$L(A1)>0 A1=A1_"-" S B=$O(^PRCF(423.6,PRCDA,1,0)),L1=^(B,0),SITE=$P(L1,U,3) I A1'[SITE D MSG1^PRCOSS5(L1) Q
- S B=$O(^PRCF(423.6,PRCDA,1,B)),C=^(B,0) I $P(C,U)'="LC" D MSG2^PRCOSS5(L1) Q
- S COUNT=$P(C,U,2),LC=B I COUNT="" D MSG3^PRCOSS5(L1) Q
- S (QTY,TYP,C,NSNF,CSF)="" F S B=$O(^PRCF(423.6,PRCDA,1,B)) Q:B="" S C=^(B,0) S TYP=$P(C,U) Q:TYP'="SL" S QTY=QTY+1,NSN=$P(C,U,2),CS=$P(C,U,5) S:NSN="" NSNF=1 S:CS="" CSF=1 Q:C="$"
- I TYP'="SL",C'="$" D MSG4^PRCOSS5(L1) Q
- I QTY'=COUNT D MSG5^PRCOSS5(L1) Q
- I NSNF=1 D MSG6^PRCOSS5(L1) Q
- I CSF=1 D MSG8^PRCOSS5(L1) Q
- S B=LC F S B=$O(^PRCF(423.6,PRCDA,1,B)) Q:B'>0 S C=^(B,0),TYP=$P(C,U) Q:TYP'="SL" S NSNF="" D Q:NSNF=1
- .S NSN=$P(C,U,2),NSN=$E(NSN,1,4)_"-"_$E(NSN,5,6)_"-"_$E(NSN,7,9)_"-"_$E(NSN,10,99),NSNB=0
- SOA .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 SOA
- .S CS=$P(C,U,5),VEN=$G(^PRC(441,NSNB,2,0)) I VEN="" S NSNF=1 Q
- .S NSNF=1,VEN=0 F S VEN=$O(^PRC(441,NSNB,2,VEN)) Q:VEN'>0 S SC="" D I CS=$P(SC,U) S NSNF="" Q
- ..S VEN1=^PRC(441,NSNB,2,VEN,0) Q:+VEN1'>0 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
- I NSNF=1 S DIE="^PRCF(423.6,",DA=PRCDA,DR="3///65" D ^DIE Q
- S1 ;IF THERE WAS NO MISSING NSNs THE SSO^PRCOSSO BACKGROUND TASK WILL FALL THROUGH INTO THIS SECTION OF CODE.
- ;NOW TO CHECK FILE 445, THE WAREHOUSE ENTRY, TO SEE IF ALL ITEMS ARE LISTED IN THE INVENTORY.
- S A="" F S A=$O(^PRCP(445,"AC","W",A)) Q:A="" S B=+^PRCP(445,A,0),C=^PRCF(423.6,PRCDA,1,10000,0),CS=$P(C,U,3) I B=CS D Q
- .S Y=0 F S Y=$O(^PRCF(423.6,PRCDA,1,Y)) Q:Y'>0 S Y1=^(Y,0) I $P(Y1,U)="SL" S (NSNF,WF)="" D Q:NSNF=1 Q:WF=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=$O(^PRC(441,"BB",NSN,0)) S:NSNB'>0 NSNF=1 Q:NSNF=1 S:+$G(^PRCP(445,A,1,NSNB,0))'=NSNB WF=1 Q
- I A="" D MSG7^PRCOSS5(C) Q
- I NSNF=1 S DIE="^PRCF(423.6,",DA=PRCDA,DR="3///65" D ^DIE Q
- I WF=1 S DIE="^PRCF(423.6,",DA=PRCDA,DR="4///65" D ^DIE Q
- G S2^PRCOSS6
- SSO1 ;ENTER HERE IF THERE WERE MISSING NSNs. THIS ENTRY POINT IS THE ONE
- ;CALLED FROM THE BACKGROUND JOB SET UP AT THE END OF ENTERING THE MISSING
- ;NSNs. THE ONLY THING THIS ENTRY POINT DOES IS TO NEW THE VARIABLES USED
- ;WITHIN THE S1 SECTION OF THIS ROUTINE. THE SAME VARIABLE NAMES ARE USED
- ;IN THE S1 SECTION AS WERE USED IN SSO SO THAT THE NEW COMMAND FOR THAT
- ;SECTION CAN HANDLE THEM IF THE SSO SECTION FALLS THROUGH INTO THE S1
- ;SECTION.
- N A,B,C,CS,DA,DIE,DR,NSN,NSNB,NSNF,WF,Y,Y1 G S1
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCOSSO 3116 printed Dec 13, 2024@02:12:16 Page 2
- PRCOSSO ;WISC/DJM-SSO Server Interface to IFCAP ;10/3/94 10:45 AM
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 QUIT
- SSO ;SUGGESTED ORDER TRANSACTION FROM AUSTIN USED TO CREATE A REPETITIVE ITEM LIST
- +1 NEW %,A,AA,AQ,A1,B,C,COUNT,CP,CS,CSF,DA,DIC,DIE,DIK,DR,DT,E,F,FS,FY,INACT,LC,L1,MO,NSN,NSNB,NSNC,NSNF,PRCDA,QTR,QTY,QTYL,REC,SC,SITE,TC,TIME,TYP,UC,VEN,VEN1,VENDOR,WF,Y,Y1,YR
- +2 SET A=1
- SET A1=""
- FOR
- SET A=$ORDER(^PRC(411,"B",A))
- if A'>0
- QUIT
- SET A1=A1_"-"_A
- +3 if $LENGTH(A1)>0
- SET A1=A1_"-"
- SET B=$ORDER(^PRCF(423.6,PRCDA,1,0))
- SET L1=^(B,0)
- SET SITE=$PIECE(L1,U,3)
- IF A1'[SITE
- DO MSG1^PRCOSS5(L1)
- QUIT
- +4 SET B=$ORDER(^PRCF(423.6,PRCDA,1,B))
- SET C=^(B,0)
- IF $PIECE(C,U)'="LC"
- DO MSG2^PRCOSS5(L1)
- QUIT
- +5 SET COUNT=$PIECE(C,U,2)
- SET LC=B
- IF COUNT=""
- DO MSG3^PRCOSS5(L1)
- QUIT
- +6 SET (QTY,TYP,C,NSNF,CSF)=""
- FOR
- SET B=$ORDER(^PRCF(423.6,PRCDA,1,B))
- if B=""
- QUIT
- SET C=^(B,0)
- SET TYP=$PIECE(C,U)
- if TYP'="SL"
- QUIT
- SET QTY=QTY+1
- SET NSN=$PIECE(C,U,2)
- SET CS=$PIECE(C,U,5)
- if NSN=""
- SET NSNF=1
- if CS=""
- SET CSF=1
- if C="$"
- QUIT
- +7 IF TYP'="SL"
- IF C'="$"
- DO MSG4^PRCOSS5(L1)
- QUIT
- +8 IF QTY'=COUNT
- DO MSG5^PRCOSS5(L1)
- QUIT
- +9 IF NSNF=1
- DO MSG6^PRCOSS5(L1)
- QUIT
- +10 IF CSF=1
- DO MSG8^PRCOSS5(L1)
- QUIT
- +11 SET B=LC
- FOR
- SET B=$ORDER(^PRCF(423.6,PRCDA,1,B))
- if B'>0
- QUIT
- SET C=^(B,0)
- SET TYP=$PIECE(C,U)
- if TYP'="SL"
- QUIT
- SET NSNF=""
- Begin DoDot:1
- +12 SET NSN=$PIECE(C,U,2)
- SET NSN=$EXTRACT(NSN,1,4)_"-"_$EXTRACT(NSN,5,6)_"-"_$EXTRACT(NSN,7,9)_"-"_$EXTRACT(NSN,10,99)
- SET NSNB=0
- SOA 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 SOA
- +3 SET CS=$PIECE(C,U,5)
- SET VEN=$GET(^PRC(441,NSNB,2,0))
- IF VEN=""
- SET NSNF=1
- QUIT
- +4 SET NSNF=1
- SET VEN=0
- FOR
- SET VEN=$ORDER(^PRC(441,NSNB,2,VEN))
- if VEN'>0
- QUIT
- SET SC=""
- Begin DoDot:2
- +5 SET VEN1=^PRC(441,NSNB,2,VEN,0)
- if +VEN1'>0
- 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:2
- IF CS=$PIECE(SC,U)
- SET NSNF=""
- QUIT
- End DoDot:1
- if NSNF=1
- QUIT
- +6 IF NSNF=1
- SET DIE="^PRCF(423.6,"
- SET DA=PRCDA
- SET DR="3///65"
- DO ^DIE
- QUIT
- S1 ;IF THERE WAS NO MISSING NSNs THE SSO^PRCOSSO BACKGROUND TASK WILL FALL THROUGH INTO THIS SECTION OF CODE.
- +1 ;NOW TO CHECK FILE 445, THE WAREHOUSE ENTRY, TO SEE IF ALL ITEMS ARE LISTED IN THE INVENTORY.
- +2 SET A=""
- FOR
- SET A=$ORDER(^PRCP(445,"AC","W",A))
- if A=""
- QUIT
- SET B=+^PRCP(445,A,0)
- SET C=^PRCF(423.6,PRCDA,1,10000,0)
- SET CS=$PIECE(C,U,3)
- IF B=CS
- Begin DoDot:1
- +3 SET Y=0
- FOR
- SET Y=$ORDER(^PRCF(423.6,PRCDA,1,Y))
- if Y'>0
- QUIT
- SET Y1=^(Y,0)
- IF $PIECE(Y1,U)="SL"
- SET (NSNF,WF)=""
- Begin DoDot:2
- +4 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))
- if NSNB'>0
- SET NSNF=1
- if NSNF=1
- QUIT
- if +$GET(^PRCP(445,A,1,NSNB,0))'=NSNB
- SET WF=1
- QUIT
- End DoDot:2
- if NSNF=1
- QUIT
- if WF=1
- QUIT
- End DoDot:1
- QUIT
- +5 IF A=""
- DO MSG7^PRCOSS5(C)
- QUIT
- +6 IF NSNF=1
- SET DIE="^PRCF(423.6,"
- SET DA=PRCDA
- SET DR="3///65"
- DO ^DIE
- QUIT
- +7 IF WF=1
- SET DIE="^PRCF(423.6,"
- SET DA=PRCDA
- SET DR="4///65"
- DO ^DIE
- QUIT
- +8 GOTO S2^PRCOSS6
- SSO1 ;ENTER HERE IF THERE WERE MISSING NSNs. THIS ENTRY POINT IS THE ONE
- +1 ;CALLED FROM THE BACKGROUND JOB SET UP AT THE END OF ENTERING THE MISSING
- +2 ;NSNs. THE ONLY THING THIS ENTRY POINT DOES IS TO NEW THE VARIABLES USED
- +3 ;WITHIN THE S1 SECTION OF THIS ROUTINE. THE SAME VARIABLE NAMES ARE USED
- +4 ;IN THE S1 SECTION AS WERE USED IN SSO SO THAT THE NEW COMMAND FOR THAT
- +5 ;SECTION CAN HANDLE THEM IF THE SSO SECTION FALLS THROUGH INTO THE S1
- +6 ;SECTION.
- +7 NEW A,B,C,CS,DA,DIE,DR,NSN,NSNB,NSNF,WF,Y,Y1
- GOTO S1